/[slime]/slime/swank-allegro.lisp
ViewVC logotype

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (hide annotations)
Mon Apr 26 17:11:36 2004 UTC (9 years, 11 months ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-0-13, SLIME-0-12
Changes since 1.29: +2 -1 lines
(arglist): Return :not-available if arglist lookup fails with an
error.
1 heller 1.8 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 heller 1.1 ;;;
3     ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4     ;;;
5     ;;; Created 2003, Helmut Eller
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 heller 1.14 ;;; are disclaimed. This code was written for "Allegro CL Trial
9     ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
10 heller 1.1 ;;;
11    
12 heller 1.21 (in-package :swank-backend)
13    
14 heller 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require :sock)
16     (require :process))
17    
18     (import
19     '(excl:fundamental-character-output-stream
20     excl:stream-write-char
21     excl:stream-force-output
22     excl:fundamental-character-input-stream
23     excl:stream-read-char
24     excl:stream-listen
25     excl:stream-unread-char
26     excl:stream-clear-input
27     excl:stream-line-column
28 heller 1.7 excl:stream-read-char-no-hang
29 heller 1.1 ))
30    
31 heller 1.8 ;;;; TCP Server
32 heller 1.1
33 heller 1.22
34 heller 1.21 (defimplementation preferred-communication-style ()
35     :spawn)
36 heller 1.12
37 heller 1.14 (defimplementation create-socket (host port)
38     (socket:make-socket :connect :passive :local-port port
39     :local-host host :reuse-address t))
40 heller 1.5
41 heller 1.10 (defimplementation local-port (socket)
42 heller 1.6 (socket:local-port socket))
43    
44 heller 1.10 (defimplementation close-socket (socket)
45 heller 1.6 (close socket))
46    
47 heller 1.10 (defimplementation accept-connection (socket)
48 heller 1.6 (socket:accept-connection socket :wait t))
49    
50 heller 1.10 (defimplementation emacs-connected ())
51 heller 1.7
52 heller 1.9 ;;;; Unix signals
53    
54 heller 1.10 (defimplementation call-without-interrupts (fn)
55 heller 1.9 (excl:without-interrupts (funcall fn)))
56    
57 heller 1.10 (defimplementation getpid ()
58 heller 1.8 (excl::getpid))
59 heller 1.6
60 heller 1.15 (defimplementation lisp-implementation-type-name ()
61     "allegro")
62    
63 pseibel 1.28 (defimplementation set-default-directory (directory)
64     (excl:chdir directory)
65 pseibel 1.29 (namestring (setf *default-pathname-defaults* (truename (merge-pathnames directory)))))
66    
67 pseibel 1.28
68 heller 1.8 ;;;; Misc
69 heller 1.1
70 heller 1.21 (defimplementation arglist (symbol)
71 lgorrie 1.30 (handler-case (excl:arglist symbol)
72     (simple-error () :not-available)))
73 heller 1.21
74     (defimplementation macroexpand-all (form)
75     (excl::walk form))
76 heller 1.1
77 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
78 heller 1.1 (let ((result '()))
79     (flet ((doc (kind &optional (sym symbol))
80     (or (documentation sym kind) :not-documented))
81     (maybe-push (property value)
82     (when value
83     (setf result (list* property value result)))))
84     (maybe-push
85     :variable (when (boundp symbol)
86     (doc 'variable)))
87     (maybe-push
88     :function (if (fboundp symbol)
89     (doc 'function)))
90     (maybe-push
91     :class (if (find-class symbol nil)
92     (doc 'class)))
93     result)))
94    
95 heller 1.22
96 heller 1.21 (defimplementation describe-definition (symbol namespace)
97     (ecase namespace
98     (:variable
99     (describe symbol))
100     ((:function :generic-function)
101     (describe (symbol-function symbol)))
102     (:class
103     (describe (find-class symbol)))))
104 heller 1.4
105 heller 1.20 (defimplementation describe-definition (symbol namespace)
106     (ecase namespace
107     (:variable
108     (describe symbol))
109     ((:function :generic-function)
110     (describe (symbol-function symbol)))
111     (:class
112     (describe (find-class symbol)))))
113 heller 1.10
114 heller 1.8 ;;;; Debugger
115    
116 heller 1.1 (defvar *sldb-topframe*)
117 heller 1.4
118 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
119 heller 1.4 (let ((*sldb-topframe* (excl::int-newest-frame))
120 heller 1.20 (excl::*break-hook* nil))
121 heller 1.4 (funcall debugger-loop-fn)))
122 heller 1.1
123     (defun nth-frame (index)
124     (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
125     (i index (1- i)))
126     ((zerop i) frame)))
127    
128 heller 1.20 (defimplementation compute-backtrace (start end)
129 heller 1.1 (let ((end (or end most-positive-fixnum)))
130     (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
131     for i from start below end
132     while f
133     collect f)))
134    
135 heller 1.20 (defimplementation print-frame (frame stream)
136     (debugger:output-frame stream frame :moderate))
137 heller 1.4
138 heller 1.10 (defimplementation frame-locals (index)
139 heller 1.1 (let ((frame (nth-frame index)))
140     (loop for i from 0 below (debugger:frame-number-vars frame)
141 mbaringer 1.19 collect (list :name (debugger:frame-var-name frame i)
142 heller 1.1 :id 0
143 mbaringer 1.19 :value (debugger:frame-var-value frame i)))))
144 heller 1.1
145 heller 1.10 (defimplementation frame-catch-tags (index)
146 heller 1.1 (declare (ignore index))
147     nil)
148    
149 heller 1.21 (defimplementation disassemble-frame (index)
150     (disassemble (debugger:frame-function (nth-frame index))))
151    
152 heller 1.10 (defimplementation frame-source-location-for-emacs (index)
153 heller 1.4 (list :error (format nil "Cannot find source for frame: ~A"
154     (nth-frame index))))
155    
156 heller 1.10 (defimplementation eval-in-frame (form frame-number)
157     (debugger:eval-form-in-context
158     form
159     (debugger:environment-of-frame (nth-frame frame-number))))
160    
161 heller 1.11 (defimplementation return-from-frame (frame-number form)
162     (let ((frame (nth-frame frame-number)))
163     (multiple-value-call #'debugger:frame-return
164     frame (debugger:eval-form-in-context
165 heller 1.20 form
166     (debugger:environment-of-frame frame)))))
167 heller 1.11
168 heller 1.21 ;;; XXX doesn't work for frames with arguments
169 heller 1.11 (defimplementation restart-frame (frame-number)
170     (let ((frame (nth-frame frame-number)))
171     (debugger:frame-retry frame (debugger:frame-function frame))))
172    
173 heller 1.8 ;;;; Compiler hooks
174    
175 heller 1.1 (defvar *buffer-name* nil)
176     (defvar *buffer-start-position*)
177     (defvar *buffer-string*)
178     (defvar *compile-filename*)
179    
180     (defun handle-compiler-warning (condition)
181     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
182     (signal (make-condition
183     'compiler-condition
184     :original-condition condition
185     :severity :warning
186     :message (format nil "~A" condition)
187     :location (cond (*buffer-name*
188     (make-location
189     (list :buffer *buffer-name*)
190     (list :position *buffer-start-position*)))
191     (loc
192     (destructuring-bind (file . pos) loc
193     (make-location
194     (list :file (namestring (truename file)))
195     (list :position (1+ pos)))))
196     (t
197     (make-location
198     (list :file *compile-filename*)
199     (list :position 1))))))))
200    
201 heller 1.20 (defimplementation swank-compile-file (*compile-filename* load-p)
202 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
203     (let ((*buffer-name* nil))
204 heller 1.4 (compile-file *compile-filename* :load-after-compile load-p))))
205 heller 1.1
206 heller 1.20 (defimplementation swank-compile-string (string &key buffer position)
207 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
208 heller 1.20 (let ((*buffer-name* buffer)
209 heller 1.1 (*buffer-start-position* position)
210     (*buffer-string* string))
211 heller 1.20 (funcall (compile nil (read-from-string
212 heller 1.24 (format nil "(~S () ~A)" 'lambda string)))))))
213 heller 1.1
214 heller 1.8 ;;;; Definition Finding
215    
216 heller 1.21 (defun find-fspec-location (fspec type)
217     (let ((file (excl::fspec-pathname fspec type)))
218     (etypecase file
219     (pathname
220     (let ((start (scm:find-definition-in-file fspec type file)))
221     (make-location (list :file (namestring (truename file)))
222     (if start
223     (list :position (1+ start))
224     (list :function-name (string fspec))))))
225     ((member :top-level)
226     (list :error (format nil "Defined at toplevel: ~A" fspec)))
227     (null
228     (list :error (format nil "Unkown source location for ~A" fspec))))))
229    
230     (defun fspec-definition-locations (fspec)
231 heller 1.1 (let ((defs (excl::find-multiple-definitions fspec)))
232 heller 1.21 (loop for (fspec type) in defs
233     collect (list fspec (find-fspec-location fspec type)))))
234    
235     (defimplementation find-definitions (symbol)
236     (fspec-definition-locations symbol))
237 heller 1.1
238 heller 1.8 ;;;; XREF
239    
240 heller 1.21 (defmacro defxref (name relation name1 name2)
241     `(defimplementation ,name (x)
242     (xref-result (xref:get-relation ,relation ,name1 ,name2))))
243    
244     (defxref who-calls :calls :wild x)
245     (defxref who-references :uses :wild x)
246     (defxref who-binds :binds :wild x)
247     (defxref who-macroexpands :macro-calls :wild x)
248     (defxref who-sets :sets :wild x)
249     (defxref list-callees :calls x :wild)
250    
251     (defun xref-result (fspecs)
252     (loop for fspec in fspecs
253     append (fspec-definition-locations fspec)))
254 heller 1.4
255 heller 1.18 ;;;; Inspecting
256    
257     (defmethod inspected-parts (o)
258     (let* ((class (class-of o))
259     (slots (clos:class-slots class)))
260     (values (format nil "~A~% is a ~A" o class)
261     (mapcar (lambda (slot)
262     (let ((name (clos:slot-definition-name slot)))
263 heller 1.20 (cons (princ-to-string name)
264 heller 1.18 (slot-value o name))))
265     slots))))
266    
267     ;;;; Multithreading
268 heller 1.8
269 heller 1.10 (defimplementation startup-multiprocessing ()
270 heller 1.8 (mp:start-scheduler))
271    
272 heller 1.10 (defimplementation spawn (fn &key name)
273 heller 1.8 (mp:process-run-function name fn))
274    
275 heller 1.13 (defimplementation thread-name (thread)
276     (mp:process-name thread))
277 heller 1.8
278 heller 1.13 (defimplementation thread-status (thread)
279     (format nil "~A ~D" (mp:process-whostate thread)
280     (mp:process-priority thread)))
281 heller 1.8
282 heller 1.10 (defimplementation make-lock (&key name)
283 heller 1.8 (mp:make-process-lock :name name))
284    
285 heller 1.10 (defimplementation call-with-lock-held (lock function)
286 heller 1.8 (mp:with-process-lock (lock) (funcall function)))
287 heller 1.12
288     (defimplementation current-thread ()
289     mp:*current-process*)
290    
291     (defimplementation all-threads ()
292 heller 1.13 (copy-list mp:*all-processes*))
293 heller 1.12
294     (defimplementation interrupt-thread (thread fn)
295     (mp:process-interrupt thread fn))
296    
297 heller 1.16 (defimplementation kill-thread (thread)
298     (mp:process-kill thread))
299    
300 heller 1.12 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
301    
302     (defstruct (mailbox (:conc-name mailbox.))
303     (mutex (mp:make-process-lock :name "process mailbox"))
304     (queue '() :type list))
305    
306     (defun mailbox (thread)
307     "Return THREAD's mailbox."
308     (mp:with-process-lock (*mailbox-lock*)
309     (or (getf (mp:process-property-list thread) 'mailbox)
310     (setf (getf (mp:process-property-list thread) 'mailbox)
311     (make-mailbox)))))
312    
313     (defimplementation send (thread message)
314     (let* ((mbox (mailbox thread))
315     (mutex (mailbox.mutex mbox)))
316 heller 1.25 (mp:process-wait-with-timeout
317     "yielding before sending" 0.1
318     (lambda ()
319     (mp:with-process-lock (mutex)
320 heller 1.26 (< (length (mailbox.queue mbox)) 10))))
321 heller 1.12 (mp:with-process-lock (mutex)
322     (setf (mailbox.queue mbox)
323     (nconc (mailbox.queue mbox) (list message))))))
324    
325     (defimplementation receive ()
326     (let* ((mbox (mailbox mp:*current-process*))
327     (mutex (mailbox.mutex mbox)))
328     (mp:process-wait "receive" #'mailbox.queue mbox)
329     (mp:with-process-lock (mutex)
330     (pop (mailbox.queue mbox)))))
331 mbaringer 1.27
332     (defimplementation quit-lisp ()
333     (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5