Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 374 lines (303 sloc) 12.565 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
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (require :sock)
14 (require :process))
15
16 (in-package :swank)
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
139b96f (excl:stream-read-char-no-hang): Import it.
Helmut Eller authored
28 excl:stream-read-char-no-hang
f912c9c New file.
Helmut Eller authored
29 ))
30
fab0b31 Add multiprocessing support.
Helmut Eller authored
31 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
32
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
33 (setq *swank-in-background* :spawn)
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
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
48 (defimplementation emacs-connected ())
139b96f (excl:stream-read-char-no-hang): Import it.
Helmut Eller authored
49
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
50 ;;;; Unix signals
51
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
52 (defimplementation call-without-interrupts (fn)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
53 (excl:without-interrupts (funcall fn)))
54
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
55 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
56 (excl::getpid))
57
6827452 (lisp-implementation-type-name): Implement it.
Helmut Eller authored
58 (defimplementation lisp-implementation-type-name ()
59 "allegro")
60
fab0b31 Add multiprocessing support.
Helmut Eller authored
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-em…
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-em…
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-em…
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.