Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 344 lines (274 sloc) 11.016 kB
fab0b31 Add multiprocessing support.
Helmut Eller authored
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
f912c9c New file.
Helmut Eller authored
2 ;;;
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
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
8 ;;; are disclaimed. This code was written for "Allegro CL Trial
9 ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
f912c9c New file.
Helmut Eller authored
10 ;;;
11
8052a9e Minor modifications.
Helmut Eller authored
12 (in-package :swank-backend)
13
f912c9c New file.
Helmut Eller authored
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require :sock)
aa65d6e Implemented.
Luke Gorrie authored
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 excl:stream-read-char-no-hang)))
f912c9c New file.
Helmut Eller authored
29
fab0b31 Add multiprocessing support.
Helmut Eller authored
30 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
31
8052a9e Minor modifications.
Helmut Eller authored
32 (defimplementation preferred-communication-style ()
33 :spawn)
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
34
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
35 (defimplementation create-socket (host port)
36 (socket:make-socket :connect :passive :local-port port
37 :local-host host :reuse-address t))
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-em…
Helmut Eller authored
38
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
39 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
40 (socket:local-port socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
41
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
42 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
43 (close socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
44
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
45 (defimplementation accept-connection (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
46 (socket:accept-connection socket :wait t))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
47
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
48 ;; The following defitinions are workarounds for the buggy
49 ;; no-applicable-method function in Allegro 5. We have to provide an
50 ;; implementation.
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
51 (defimplementation emacs-connected ())
139b96f (excl:stream-read-char-no-hang): Import it.
Helmut Eller authored
52
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
53 (defimplementation format-sldb-condition (c)
54 (princ-to-string c))
55
56 (defimplementation condition-references (c)
57 (declare (ignore))
58 '())
59
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
60 ;;;; Unix signals
61
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
62 (defimplementation call-without-interrupts (fn)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
63 (excl:without-interrupts (funcall fn)))
64
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
65 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
66 (excl::getpid))
67
6827452 (lisp-implementation-type-name): Implement it.
Helmut Eller authored
68 (defimplementation lisp-implementation-type-name ()
69 "allegro")
70
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
71 (defimplementation set-default-directory (directory)
72 (excl:chdir directory)
bbc42ef (find-fspec-location): Better handling of methods. Reported by Bill
Helmut Eller authored
73 (namestring (setf *default-pathname-defaults*
74 (truename (merge-pathnames directory)))))
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
75
fab0b31 Add multiprocessing support.
Helmut Eller authored
76 ;;;; Misc
f912c9c New file.
Helmut Eller authored
77
8052a9e Minor modifications.
Helmut Eller authored
78 (defimplementation arglist (symbol)
d589600 (arglist): Return :not-available if arglist lookup fails with an
Luke Gorrie authored
79 (handler-case (excl:arglist symbol)
80 (simple-error () :not-available)))
8052a9e Minor modifications.
Helmut Eller authored
81
82 (defimplementation macroexpand-all (form)
83 (excl::walk form))
f912c9c New file.
Helmut Eller authored
84
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
85 (defimplementation describe-symbol-for-emacs (symbol)
f912c9c New file.
Helmut Eller authored
86 (let ((result '()))
87 (flet ((doc (kind &optional (sym symbol))
88 (or (documentation sym kind) :not-documented))
89 (maybe-push (property value)
90 (when value
91 (setf result (list* property value result)))))
92 (maybe-push
93 :variable (when (boundp symbol)
94 (doc 'variable)))
95 (maybe-push
96 :function (if (fboundp symbol)
97 (doc 'function)))
98 (maybe-push
99 :class (if (find-class symbol nil)
100 (doc 'class)))
101 result)))
102
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
103 (defimplementation describe-definition (symbol namespace)
104 (ecase namespace
105 (:variable
106 (describe symbol))
107 ((:function :generic-function)
108 (describe (symbol-function symbol)))
109 (:class
110 (describe (find-class symbol)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
111
fab0b31 Add multiprocessing support.
Helmut Eller authored
112 ;;;; Debugger
113
f912c9c New file.
Helmut Eller authored
114 (defvar *sldb-topframe*)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
115
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
116 (defimplementation call-with-debugging-environment (debugger-loop-fn)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
117 (let ((*sldb-topframe* (excl::int-newest-frame))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
118 (excl::*break-hook* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
119 (funcall debugger-loop-fn)))
f912c9c New file.
Helmut Eller authored
120
121 (defun nth-frame (index)
122 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
123 (i index (1- i)))
124 ((zerop i) frame)))
125
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
126 (defimplementation compute-backtrace (start end)
f912c9c New file.
Helmut Eller authored
127 (let ((end (or end most-positive-fixnum)))
128 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
129 for i from start below end
130 while f
131 collect f)))
132
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
133 (defimplementation print-frame (frame stream)
134 (debugger:output-frame stream frame :moderate))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
135
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
136 (defimplementation frame-locals (index)
f912c9c New file.
Helmut Eller authored
137 (let ((frame (nth-frame index)))
138 (loop for i from 0 below (debugger:frame-number-vars frame)
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
139 collect (list :name (debugger:frame-var-name frame i)
f912c9c New file.
Helmut Eller authored
140 :id 0
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
141 :value (debugger:frame-var-value frame i)))))
f912c9c New file.
Helmut Eller authored
142
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
143 (defimplementation frame-catch-tags (index)
f912c9c New file.
Helmut Eller authored
144 (declare (ignore index))
145 nil)
146
8052a9e Minor modifications.
Helmut Eller authored
147 (defimplementation disassemble-frame (index)
148 (disassemble (debugger:frame-function (nth-frame index))))
149
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
150 (defimplementation frame-source-location-for-emacs (index)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
151 (list :error (format nil "Cannot find source for frame: ~A"
152 (nth-frame index))))
153
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
154 (defimplementation eval-in-frame (form frame-number)
155 (debugger:eval-form-in-context
156 form
157 (debugger:environment-of-frame (nth-frame frame-number))))
158
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
159 (defimplementation return-from-frame (frame-number form)
160 (let ((frame (nth-frame frame-number)))
161 (multiple-value-call #'debugger:frame-return
162 frame (debugger:eval-form-in-context
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
163 form
164 (debugger:environment-of-frame frame)))))
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
165
8052a9e Minor modifications.
Helmut Eller authored
166 ;;; XXX doesn't work for frames with arguments
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
167 (defimplementation restart-frame (frame-number)
168 (let ((frame (nth-frame frame-number)))
169 (debugger:frame-retry frame (debugger:frame-function frame))))
170
fab0b31 Add multiprocessing support.
Helmut Eller authored
171 ;;;; Compiler hooks
172
f912c9c New file.
Helmut Eller authored
173 (defvar *buffer-name* nil)
174 (defvar *buffer-start-position*)
175 (defvar *buffer-string*)
aa65d6e Implemented.
Luke Gorrie authored
176 (defvar *compile-filename* nil)
f912c9c New file.
Helmut Eller authored
177
178 (defun handle-compiler-warning (condition)
179 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
180 (signal (make-condition
181 'compiler-condition
182 :original-condition condition
183 :severity :warning
184 :message (format nil "~A" condition)
185 :location (cond (*buffer-name*
186 (make-location
187 (list :buffer *buffer-name*)
188 (list :position *buffer-start-position*)))
189 (loc
190 (destructuring-bind (file . pos) loc
191 (make-location
192 (list :file (namestring (truename file)))
193 (list :position (1+ pos)))))
aa65d6e Implemented.
Luke Gorrie authored
194 (*compile-filename*
f912c9c New file.
Helmut Eller authored
195 (make-location
196 (list :file *compile-filename*)
aa65d6e Implemented.
Luke Gorrie authored
197 (list :position 1)))
198 (t
199 (list :error "No error location available.")))))))
f912c9c New file.
Helmut Eller authored
200
aa65d6e Implemented.
Luke Gorrie authored
201 (defimplementation call-with-compilation-hooks (function)
f912c9c New file.
Helmut Eller authored
202 (handler-bind ((warning #'handle-compiler-warning))
aa65d6e Implemented.
Luke Gorrie authored
203 (funcall function)))
204
205 (defimplementation swank-compile-file (*compile-filename* load-p)
206 (with-compilation-hooks ()
f912c9c New file.
Helmut Eller authored
207 (let ((*buffer-name* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
208 (compile-file *compile-filename* :load-after-compile load-p))))
f912c9c New file.
Helmut Eller authored
209
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
210 (defimplementation swank-compile-string (string &key buffer position)
aa65d6e Implemented.
Luke Gorrie authored
211 (with-compilation-hooks ()
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
212 (let ((*buffer-name* buffer)
f912c9c New file.
Helmut Eller authored
213 (*buffer-start-position* position)
214 (*buffer-string* string))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
215 (funcall (compile nil (read-from-string
8c86692 (swank-compile-string): Be friendly to case-inverting readtables.
Helmut Eller authored
216 (format nil "(~S () ~A)" 'lambda string)))))))
f912c9c New file.
Helmut Eller authored
217
fab0b31 Add multiprocessing support.
Helmut Eller authored
218 ;;;; Definition Finding
219
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
220 (defun fspec-primary-name (fspec)
221 (etypecase fspec
222 (symbol (string fspec))
223 (list (string (second fspec)))))
224
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
225 (defun find-fspec-location (fspec type)
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
226 (let ((file (excl:source-file fspec)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
227 (etypecase file
228 (pathname
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
229 (let* ((start (scm:find-definition-in-file fspec type file))
230 (pos (if start
231 (list :position (1+ start))
232 (list :function-name (fspec-primary-name fspec)))))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
233 (make-location (list :file (namestring (truename file)))
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
234 pos)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
235 ((member :top-level)
236 (list :error (format nil "Defined at toplevel: ~A" fspec)))
237 (null
238 (list :error (format nil "Unkown source location for ~A" fspec))))))
239
437f909 Remove stupid conflicts.
Helmut Eller authored
240 (defun fspec-definition-locations (fspec)
f912c9c New file.
Helmut Eller authored
241 (let ((defs (excl::find-multiple-definitions fspec)))
8052a9e Minor modifications.
Helmut Eller authored
242 (loop for (fspec type) in defs
243 collect (list fspec (find-fspec-location fspec type)))))
244
245 (defimplementation find-definitions (symbol)
246 (fspec-definition-locations symbol))
fab0b31 Add multiprocessing support.
Helmut Eller authored
247
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
248 ;;;; XREF
f912c9c New file.
Helmut Eller authored
249
8052a9e Minor modifications.
Helmut Eller authored
250 (defmacro defxref (name relation name1 name2)
251 `(defimplementation ,name (x)
252 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
253
254 (defxref who-calls :calls :wild x)
255 (defxref who-references :uses :wild x)
256 (defxref who-binds :binds :wild x)
257 (defxref who-macroexpands :macro-calls :wild x)
258 (defxref who-sets :sets :wild x)
259 (defxref list-callees :calls x :wild)
260
261 (defun xref-result (fspecs)
262 (loop for fspec in fspecs
263 append (fspec-definition-locations fspec)))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
264
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
265 ;;;; Inspecting
266
267 (defmethod inspected-parts (o)
268 (let* ((class (class-of o))
269 (slots (clos:class-slots class)))
270 (values (format nil "~A~% is a ~A" o class)
271 (mapcar (lambda (slot)
272 (let ((name (clos:slot-definition-name slot)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
273 (cons (princ-to-string name)
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
274 (slot-value o name))))
275 slots))))
276
277 ;;;; Multithreading
fab0b31 Add multiprocessing support.
Helmut Eller authored
278
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
279 (defimplementation startup-multiprocessing ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
280 (mp:start-scheduler))
281
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
282 (defimplementation spawn (fn &key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
283 (mp:process-run-function name fn))
284
64ff730 Update for modified thread interface.
Helmut Eller authored
285 (defimplementation thread-name (thread)
286 (mp:process-name thread))
fab0b31 Add multiprocessing support.
Helmut Eller authored
287
64ff730 Update for modified thread interface.
Helmut Eller authored
288 (defimplementation thread-status (thread)
289 (format nil "~A ~D" (mp:process-whostate thread)
290 (mp:process-priority thread)))
fab0b31 Add multiprocessing support.
Helmut Eller authored
291
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
292 (defimplementation make-lock (&key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
293 (mp:make-process-lock :name name))
294
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
295 (defimplementation call-with-lock-held (lock function)
fab0b31 Add multiprocessing support.
Helmut Eller authored
296 (mp:with-process-lock (lock) (funcall function)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
297
298 (defimplementation current-thread ()
299 mp:*current-process*)
300
301 (defimplementation all-threads ()
64ff730 Update for modified thread interface.
Helmut Eller authored
302 (copy-list mp:*all-processes*))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
303
304 (defimplementation interrupt-thread (thread fn)
305 (mp:process-interrupt thread fn))
306
52dc1fc (kill-thread): Implemented.
Helmut Eller authored
307 (defimplementation kill-thread (thread)
308 (mp:process-kill thread))
309
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
310 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
311
312 (defstruct (mailbox (:conc-name mailbox.))
313 (mutex (mp:make-process-lock :name "process mailbox"))
314 (queue '() :type list))
315
316 (defun mailbox (thread)
317 "Return THREAD's mailbox."
318 (mp:with-process-lock (*mailbox-lock*)
319 (or (getf (mp:process-property-list thread) 'mailbox)
320 (setf (getf (mp:process-property-list thread) 'mailbox)
321 (make-mailbox)))))
322
323 (defimplementation send (thread message)
324 (let* ((mbox (mailbox thread))
325 (mutex (mailbox.mutex mbox)))
cbaae0c (send): Wait a bit if there are already many message in the mailbox.
Helmut Eller authored
326 (mp:process-wait-with-timeout
327 "yielding before sending" 0.1
328 (lambda ()
329 (mp:with-process-lock (mutex)
95e3c25 (send): Fix misplaced parens. (From Bill Clementson)
Helmut Eller authored
330 (< (length (mailbox.queue mbox)) 10))))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
331 (mp:with-process-lock (mutex)
332 (setf (mailbox.queue mbox)
333 (nconc (mailbox.queue mbox) (list message))))))
334
335 (defimplementation receive ()
336 (let* ((mbox (mailbox mp:*current-process*))
337 (mutex (mailbox.mutex mbox)))
338 (mp:process-wait "receive" #'mailbox.queue mbox)
339 (mp:with-process-lock (mutex)
340 (pop (mailbox.queue mbox)))))
9decabc See ChangeLog entry 2004-04-06 Marco Baringer
Marco Baringer authored
341
342 (defimplementation quit-lisp ()
343 (excl:exit 0 :quiet t))
Something went wrong with that request. Please try again.