Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 374 lines (304 sloc) 12.478 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
8 ;;; are disclaimed.
9 ;;;
10 ;;; $Id$
11 ;;;
12 ;;; This code was written for
13 ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)"
14 ;;;
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (require :sock)
18 (require :process))
19
20 (in-package :swank)
21
22 (import
23 '(excl:fundamental-character-output-stream
24 excl:stream-write-char
25 excl:stream-force-output
26 excl:fundamental-character-input-stream
27 excl:stream-read-char
28 excl:stream-listen
29 excl:stream-unread-char
30 excl:stream-clear-input
31 excl:stream-line-column
139b96f (excl:stream-read-char-no-hang): Import it.
Helmut Eller authored
32 excl:stream-read-char-no-hang
f912c9c New file.
Helmut Eller authored
33 ))
34
fab0b31 Add multiprocessing support.
Helmut Eller authored
35 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
36
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
37 (setq *swank-in-background* :spawn)
38
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
39 (defimplementation create-socket (port)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
40 (socket:make-socket :connect :passive :local-port port :reuse-address t))
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-emacs...
Helmut Eller authored
41
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
42 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
43 (socket:local-port 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 close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
46 (close socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
47
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
48 (defimplementation accept-connection (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
49 (socket:accept-connection socket :wait t))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
50
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
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
53 ;;;; Unix signals
54
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
55 (defimplementation call-without-interrupts (fn)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
56 (excl:without-interrupts (funcall fn)))
57
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
58 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
59 (excl::getpid))
60
61 ;;;; Misc
f912c9c New file.
Helmut Eller authored
62
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
63 (defimplementation arglist-string (fname)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
64 (format-arglist fname #'excl:arglist))
f912c9c New file.
Helmut Eller authored
65
66 (defun apropos-symbols (string &optional external-only package)
67 (remove-if (lambda (sym)
68 (or (keywordp sym)
69 (and external-only
70 (not (equal (symbol-package sym) *buffer-package*))
71 (not (symbol-external-p sym)))))
72 (apropos-list string package external-only t)))
73
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
74 (defimplementation describe-symbol-for-emacs (symbol)
f912c9c New file.
Helmut Eller authored
75 (let ((result '()))
76 (flet ((doc (kind &optional (sym symbol))
77 (or (documentation sym kind) :not-documented))
78 (maybe-push (property value)
79 (when value
80 (setf result (list* property value result)))))
81 (maybe-push
82 :variable (when (boundp symbol)
83 (doc 'variable)))
84 (maybe-push
85 :function (if (fboundp symbol)
86 (doc 'function)))
87 (maybe-push
88 :class (if (find-class symbol nil)
89 (doc 'class)))
90 result)))
91
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
92 (defimplementation macroexpand-all (form)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
93 (excl::walk form))
94
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
95 (defimplementation describe-definition (symbol-name type)
96 (let ((symbol (from-string symbol-name)))
97 (ecase type
98 (:variable (print-description-to-string symbol))
99 ((:function :generic-function)
100 (print-description-to-string (symbol-function symbol)))
101 (:class
102 (print-description-to-string (find-class symbol))))))
103
fab0b31 Add multiprocessing support.
Helmut Eller authored
104 ;;;; Debugger
105
f912c9c New file.
Helmut Eller authored
106 (defvar *sldb-topframe*)
107 (defvar *sldb-source*)
108 (defvar *sldb-restarts*)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
109
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
110 (defimplementation call-with-debugging-environment (debugger-loop-fn)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
111 (let ((*sldb-topframe* (excl::int-newest-frame))
112 (*debugger-hook* nil)
113 (excl::*break-hook* nil)
114 (*package* *buffer-package*)
115 (*sldb-restarts*
116 (compute-restarts *swank-debugger-condition*))
117 (*print-pretty* nil)
118 (*print-readably* nil)
119 (*print-level* 3)
120 (*print-length* 10))
121 (funcall debugger-loop-fn)))
f912c9c New file.
Helmut Eller authored
122
123 (defun format-restarts-for-emacs ()
124 (loop for restart in *sldb-restarts*
125 collect (list (princ-to-string (restart-name restart))
126 (princ-to-string restart))))
127
128 (defun nth-frame (index)
129 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
130 (i index (1- i)))
131 ((zerop i) frame)))
132
133 (defun compute-backtrace (start end)
134 (let ((end (or end most-positive-fixnum)))
135 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
136 for i from start below end
137 while f
138 collect f)))
139
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
140 (defimplementation backtrace (start-frame-number end-frame-number)
f912c9c New file.
Helmut Eller authored
141 (flet ((format-frame (f i)
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-emacs...
Helmut Eller authored
142 (print-with-frame-label
143 i (lambda (s) (debugger:output-frame s f :moderate)))))
f912c9c New file.
Helmut Eller authored
144 (loop for i from start-frame-number
145 for f in (compute-backtrace start-frame-number end-frame-number)
146 collect (list i (format-frame f i)))))
147
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
148 (defimplementation debugger-info-for-emacs (start end)
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-emacs...
Helmut Eller authored
149 (list (debugger-condition-for-emacs)
f912c9c New file.
Helmut Eller authored
150 (format-restarts-for-emacs)
151 (backtrace start end)))
152
153 (defun nth-restart (index)
154 (nth index *sldb-restarts*))
155
156 (defslimefun invoke-nth-restart (index)
5e4650c (function-source-locations): Is replaces
Helmut Eller authored
157 (invoke-restart-interactively (nth-restart index)))
f912c9c New file.
Helmut Eller authored
158
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
159 (defslimefun sldb-abort ()
160 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
161
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
162 (defimplementation frame-locals (index)
f912c9c New file.
Helmut Eller authored
163 (let ((frame (nth-frame index)))
164 (loop for i from 0 below (debugger:frame-number-vars frame)
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-emacs...
Helmut Eller authored
165 collect (list :name (to-string (debugger:frame-var-name frame i))
f912c9c New file.
Helmut Eller authored
166 :id 0
167 :value-string
168 (to-string (debugger:frame-var-value frame i))))))
169
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
170 (defimplementation frame-catch-tags (index)
f912c9c New file.
Helmut Eller authored
171 (declare (ignore index))
172 nil)
173
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
174 (defimplementation frame-source-location-for-emacs (index)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
175 (list :error (format nil "Cannot find source for frame: ~A"
176 (nth-frame index))))
177
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
178 (defimplementation eval-in-frame (form frame-number)
179 (debugger:eval-form-in-context
180 form
181 (debugger:environment-of-frame (nth-frame frame-number))))
182
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
183 (defimplementation return-from-frame (frame-number form)
184 (let ((frame (nth-frame frame-number)))
185 (multiple-value-call #'debugger:frame-return
186 frame (debugger:eval-form-in-context
187 (from-string form) (debugger:environment-of-frame frame)))))
188
189 ;;; XXX doens't work for frames with arguments
190 (defimplementation restart-frame (frame-number)
191 (let ((frame (nth-frame frame-number)))
192 (debugger:frame-retry frame (debugger:frame-function frame))))
193
fab0b31 Add multiprocessing support.
Helmut Eller authored
194 ;;;; Compiler hooks
195
f912c9c New file.
Helmut Eller authored
196 (defvar *buffer-name* nil)
197 (defvar *buffer-start-position*)
198 (defvar *buffer-string*)
199 (defvar *compile-filename*)
200
201 (defun handle-compiler-warning (condition)
202 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
203 (signal (make-condition
204 'compiler-condition
205 :original-condition condition
206 :severity :warning
207 :message (format nil "~A" condition)
208 :location (cond (*buffer-name*
209 (make-location
210 (list :buffer *buffer-name*)
211 (list :position *buffer-start-position*)))
212 (loc
213 (destructuring-bind (file . pos) loc
214 (make-location
215 (list :file (namestring (truename file)))
216 (list :position (1+ pos)))))
217 (t
218 (make-location
219 (list :file *compile-filename*)
220 (list :position 1))))))))
221
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
222 (defimplementation compile-file-for-emacs (*compile-filename* load-p)
f912c9c New file.
Helmut Eller authored
223 (handler-bind ((warning #'handle-compiler-warning))
224 (let ((*buffer-name* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
225 (compile-file *compile-filename* :load-after-compile load-p))))
f912c9c New file.
Helmut Eller authored
226
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
227 (defimplementation compile-string-for-emacs (string &key buffer position)
f912c9c New file.
Helmut Eller authored
228 (handler-bind ((warning #'handle-compiler-warning))
229 (let ((*package* *buffer-package*)
230 (*buffer-name* buffer)
231 (*buffer-start-position* position)
232 (*buffer-string* string))
233 (eval (from-string
234 (format nil "(funcall (compile nil '(lambda () ~A)))" string))))))
235
fab0b31 Add multiprocessing support.
Helmut Eller authored
236 ;;;; Definition Finding
237
f912c9c New file.
Helmut Eller authored
238 (defun fspec-source-locations (fspec)
239 (let ((defs (excl::find-multiple-definitions fspec)))
240 (let ((locations '()))
241 (loop for (fspec type) in defs do
242 (let ((file (excl::fspec-pathname fspec type)))
243 (etypecase file
244 (pathname
245 (let ((start (scm:find-definition-in-file fspec type file)))
246 (push (make-location
247 (list :file (namestring (truename file)))
248 (if start
249 (list :position (1+ start))
250 (list :function-name (string fspec))))
251 locations)))
252 ((member :top-level)
253 (push (list :error (format nil "Defined at toplevel: ~A"
254 fspec))
255 locations))
256 (null
257 (push (list :error (format nil
258 "Unkown source location for ~A"
259 fspec))
260 locations))
261 )))
262 locations)))
263
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
264 (defimplementation find-function-locations (symbol-name)
f912c9c New file.
Helmut Eller authored
265 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
266 (cond ((not foundp)
267 (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
268 ((macro-function symbol)
269 (fspec-source-locations symbol))
270 ((special-operator-p symbol)
271 (list (list :error (format nil "~A is a special-operator" symbol))))
272 ((fboundp symbol)
273 (fspec-source-locations symbol))
274 (t (list (list :error
275 (format nil "Symbol not fbound: ~A" symbol-name))))
276 )))
277
fab0b31 Add multiprocessing support.
Helmut Eller authored
278 ;;;; XREF
279
f912c9c New file.
Helmut Eller authored
280 (defun lookup-xrefs (finder name)
281 (xref-results-for-emacs (funcall finder (from-string name))))
282
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
283 (defimplementation who-calls (function-name)
f912c9c New file.
Helmut Eller authored
284 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
285 function-name))
286
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
287 (defimplementation who-references (variable)
f912c9c New file.
Helmut Eller authored
288 (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))
289 variable))
290
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
291 (defimplementation who-binds (variable)
f912c9c New file.
Helmut Eller authored
292 (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))
293 variable))
294
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
295 (defimplementation who-macroexpands (variable)
296 (lookup-xrefs (lambda (x) (xref:get-relation :macro-calls :wild x))
297 variable))
298
299 (defimplementation who-sets (variable)
f912c9c New file.
Helmut Eller authored
300 (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))
301 variable))
302
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
303 (defimplementation list-callers (name)
f912c9c New file.
Helmut Eller authored
304 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
305 name))
306
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
307 (defimplementation list-callees (name)
f912c9c New file.
Helmut Eller authored
308 (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))
309 name))
310
311 (defun xref-results-for-emacs (fspecs)
312 (let ((xrefs '()))
313 (dolist (fspec fspecs)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
314 (dolist (location (fspec-source-locations fspec))
315 (push (cons (to-string fspec) location) xrefs)))
f912c9c New file.
Helmut Eller authored
316 (group-xrefs xrefs)))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
317
fab0b31 Add multiprocessing support.
Helmut Eller authored
318 ;;;; Multiprocessing
319
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
320 (defimplementation startup-multiprocessing ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
321 (mp:start-scheduler))
322
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
323 (defimplementation spawn (fn &key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
324 (mp:process-run-function name fn))
325
64ff730 Update for modified thread interface.
Helmut Eller authored
326 (defimplementation thread-name (thread)
327 (mp:process-name thread))
fab0b31 Add multiprocessing support.
Helmut Eller authored
328
64ff730 Update for modified thread interface.
Helmut Eller authored
329 (defimplementation thread-status (thread)
330 (format nil "~A ~D" (mp:process-whostate thread)
331 (mp:process-priority thread)))
fab0b31 Add multiprocessing support.
Helmut Eller authored
332
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
333 (defimplementation make-lock (&key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
334 (mp:make-process-lock :name name))
335
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
336 (defimplementation call-with-lock-held (lock function)
fab0b31 Add multiprocessing support.
Helmut Eller authored
337 (mp:with-process-lock (lock) (funcall function)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
338
339 (defimplementation current-thread ()
340 mp:*current-process*)
341
342 (defimplementation all-threads ()
64ff730 Update for modified thread interface.
Helmut Eller authored
343 (copy-list mp:*all-processes*))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
344
345 (defimplementation interrupt-thread (thread fn)
346 (mp:process-interrupt thread fn))
347
348 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
349
350 (defstruct (mailbox (:conc-name mailbox.))
351 (mutex (mp:make-process-lock :name "process mailbox"))
352 (queue '() :type list))
353
354 (defun mailbox (thread)
355 "Return THREAD's mailbox."
356 (mp:with-process-lock (*mailbox-lock*)
357 (or (getf (mp:process-property-list thread) 'mailbox)
358 (setf (getf (mp:process-property-list thread) 'mailbox)
359 (make-mailbox)))))
360
361 (defimplementation send (thread message)
362 (let* ((mbox (mailbox thread))
363 (mutex (mailbox.mutex mbox)))
364 (mp:with-process-lock (mutex)
365 (setf (mailbox.queue mbox)
366 (nconc (mailbox.queue mbox) (list message))))))
367
368 (defimplementation receive ()
369 (let* ((mbox (mailbox mp:*current-process*))
370 (mutex (mailbox.mutex mbox)))
371 (mp:process-wait "receive" #'mailbox.queue mbox)
372 (mp:with-process-lock (mutex)
373 (pop (mailbox.queue mbox)))))
Something went wrong with that request. Please try again.