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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44 - (show annotations)
Sun Jul 4 00:34:55 2004 UTC (9 years, 9 months ago) by lgorrie
Branch: MAIN
Changes since 1.43: +2 -2 lines
Changed reader conditionals to use fwrappers for #+(version>= 6.2).
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
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. This code was written for "Allegro CL Trial
9 ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
10 ;;;
11
12 (in-package :swank-backend)
13
14 (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 excl:stream-read-char-no-hang)))
29
30 ;;;; TCP Server
31
32 (defimplementation preferred-communication-style ()
33 :spawn)
34
35 (defimplementation create-socket (host port)
36 (socket:make-socket :connect :passive :local-port port
37 :local-host host :reuse-address t))
38
39 (defimplementation local-port (socket)
40 (socket:local-port socket))
41
42 (defimplementation close-socket (socket)
43 (close socket))
44
45 (defimplementation accept-connection (socket)
46 (socket:accept-connection socket :wait t))
47
48 ;; The following defitinions are workarounds for the buggy
49 ;; no-applicable-method function in Allegro 5. We have to provide an
50 ;; implementation.
51 (defimplementation emacs-connected (stream)
52 (declare (ignore stream))
53 (install-advice))
54
55 (defimplementation format-sldb-condition (c)
56 (princ-to-string c))
57
58 (defimplementation condition-references (c)
59 (declare (ignore c))
60 '())
61
62 (defimplementation call-with-syntax-hooks (fn)
63 (funcall fn))
64
65 ;;;; Unix signals
66
67 (defimplementation call-without-interrupts (fn)
68 (excl:without-interrupts (funcall fn)))
69
70 (defimplementation getpid ()
71 (excl::getpid))
72
73 (defimplementation lisp-implementation-type-name ()
74 "allegro")
75
76 (defimplementation set-default-directory (directory)
77 (excl:chdir directory)
78 (namestring (setf *default-pathname-defaults*
79 (truename (merge-pathnames directory)))))
80
81 (defimplementation default-directory ()
82 (excl:chdir))
83
84 ;;;; Misc
85
86 (defimplementation arglist (symbol)
87 (handler-case (excl:arglist symbol)
88 (simple-error () :not-available)))
89
90 (defimplementation macroexpand-all (form)
91 (excl::walk form))
92
93 (defimplementation describe-symbol-for-emacs (symbol)
94 (let ((result '()))
95 (flet ((doc (kind &optional (sym symbol))
96 (or (documentation sym kind) :not-documented))
97 (maybe-push (property value)
98 (when value
99 (setf result (list* property value result)))))
100 (maybe-push
101 :variable (when (boundp symbol)
102 (doc 'variable)))
103 (maybe-push
104 :function (if (fboundp symbol)
105 (doc 'function)))
106 (maybe-push
107 :class (if (find-class symbol nil)
108 (doc 'class)))
109 result)))
110
111 (defimplementation describe-definition (symbol namespace)
112 (ecase namespace
113 (:variable
114 (describe symbol))
115 ((:function :generic-function)
116 (describe (symbol-function symbol)))
117 (:class
118 (describe (find-class symbol)))))
119
120 (defimplementation make-stream-interactive (stream)
121 (setf (interactive-stream-p stream) t))
122
123 ;;;; Debugger
124
125 (defvar *sldb-topframe*)
126
127 (defimplementation call-with-debugging-environment (debugger-loop-fn)
128 (let ((*sldb-topframe* (excl::int-newest-frame))
129 (excl::*break-hook* nil))
130 (funcall debugger-loop-fn)))
131
132 (defun next-frame (frame)
133 (let ((next (excl::int-next-older-frame frame)))
134 (cond ((not next) nil)
135 ((debugger:frame-visible-p next) next)
136 (t (next-frame next)))))
137
138 (defun nth-frame (index)
139 (do ((frame *sldb-topframe* (next-frame frame))
140 (i index (1- i)))
141 ((zerop i) frame)))
142
143 (defimplementation compute-backtrace (start end)
144 (let ((end (or end most-positive-fixnum)))
145 (loop for f = (nth-frame start) then (next-frame f)
146 for i from start below end
147 while f
148 collect f)))
149
150 (defimplementation print-frame (frame stream)
151 (debugger:output-frame stream frame :moderate))
152
153 (defimplementation frame-locals (index)
154 (let ((frame (nth-frame index)))
155 (loop for i from 0 below (debugger:frame-number-vars frame)
156 collect (list :name (debugger:frame-var-name frame i)
157 :id 0
158 :value (debugger:frame-var-value frame i)))))
159
160 (defimplementation frame-var-value (frame var)
161 (let ((frame (nth-frame frame)))
162 (debugger:frame-var-value frame var)))
163
164 (defimplementation frame-catch-tags (index)
165 (declare (ignore index))
166 nil)
167
168 (defimplementation disassemble-frame (index)
169 (disassemble (debugger:frame-function (nth-frame index))))
170
171 (defimplementation frame-source-location-for-emacs (index)
172 (let* ((frame (nth-frame index))
173 (expr (debugger:frame-expression frame))
174 (fspec (first expr)))
175 (second (first (fspec-definition-locations fspec)))))
176
177 (defimplementation eval-in-frame (form frame-number)
178 (debugger:eval-form-in-context
179 form
180 (debugger:environment-of-frame (nth-frame frame-number))))
181
182 (defimplementation return-from-frame (frame-number form)
183 (let ((frame (nth-frame frame-number)))
184 (multiple-value-call #'debugger:frame-return
185 frame (debugger:eval-form-in-context
186 form
187 (debugger:environment-of-frame frame)))))
188
189 ;;; XXX doesn'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
194 ;;;; Compiler hooks
195
196 (defvar *buffer-name* nil)
197 (defvar *buffer-start-position*)
198 (defvar *buffer-string*)
199 (defvar *compile-filename* nil)
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 (*compile-filename*
218 (make-location
219 (list :file *compile-filename*)
220 (list :position 1)))
221 (t
222 (list :error "No error location available.")))))))
223
224 (defimplementation call-with-compilation-hooks (function)
225 (handler-bind ((warning #'handle-compiler-warning))
226 (funcall function)))
227
228 (defimplementation swank-compile-file (*compile-filename* load-p)
229 (with-compilation-hooks ()
230 (let ((*buffer-name* nil))
231 (compile-file *compile-filename* :load-after-compile load-p))))
232
233 (defimplementation swank-compile-string (string &key buffer position)
234 (with-compilation-hooks ()
235 (let ((*buffer-name* buffer)
236 (*buffer-start-position* position)
237 (*buffer-string* string))
238 (funcall (compile nil (read-from-string
239 (format nil "(~S () ~A)" 'lambda string)))))))
240
241 ;;;; Definition Finding
242
243 (defun fspec-primary-name (fspec)
244 (etypecase fspec
245 (symbol (string fspec))
246 (list (string (second fspec)))))
247
248 (defun find-fspec-location (fspec type)
249 (let ((file (excl:source-file fspec)))
250 (etypecase file
251 (pathname
252 (let* ((start (scm:find-definition-in-file fspec type file))
253 (pos (if start
254 (list :position (1+ start))
255 (list :function-name (fspec-primary-name fspec)))))
256 (make-location (list :file (namestring (truename file)))
257 pos)))
258 ((member :top-level)
259 (list :error (format nil "Defined at toplevel: ~A" fspec)))
260 (null
261 (list :error (format nil "Unknown source location for ~A" fspec))))))
262
263 (defun fspec-definition-locations (fspec)
264 (let ((defs (excl::find-multiple-definitions fspec)))
265 (loop for (fspec type) in defs
266 collect (list fspec (find-fspec-location fspec type)))))
267
268 (defimplementation find-definitions (symbol)
269 (fspec-definition-locations symbol))
270
271 ;;;; XREF
272
273 (defmacro defxref (name relation name1 name2)
274 `(defimplementation ,name (x)
275 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
276
277 (defxref who-calls :calls :wild x)
278 (defxref who-references :uses :wild x)
279 (defxref who-binds :binds :wild x)
280 (defxref who-macroexpands :macro-calls :wild x)
281 (defxref who-sets :sets :wild x)
282 (defxref list-callees :calls x :wild)
283
284 (defun xref-result (fspecs)
285 (loop for fspec in fspecs
286 append (fspec-definition-locations fspec)))
287
288 ;;;; Inspecting
289
290 (defmethod inspected-parts (o)
291 (let* ((class (class-of o))
292 (slots (clos:class-slots class)))
293 (values (format nil "~A~% is a ~A" o class)
294 (mapcar (lambda (slot)
295 (let ((name (clos:slot-definition-name slot)))
296 (cons (princ-to-string name)
297 (if (slot-boundp o name)
298 (slot-value o name)
299 (make-unbound-slot-filler)))))
300 slots))))
301
302 ;;;; Multithreading
303
304 (defvar *swank-thread* nil
305 "Bound to true in any thread with an ancestor created by SPAWN.
306 Such threads always use Emacs for debugging and user interaction.")
307
308 (defvar *inherited-bindings*
309 '(*debugger-hook*
310 *standard-output* *error-output* *trace-output*
311 *standard-input*
312 *debug-io* *query-io* *terminal-io*)
313 "Variables whose values are inherited by children of Swank threads.")
314
315 (defimplementation startup-multiprocessing ()
316 (mp:start-scheduler))
317
318 (defimplementation spawn (fn &key name)
319 (mp:process-run-function name
320 (lambda ()
321 (let ((*swank-thread* t))
322 (funcall fn)))))
323
324 #+(version>= 6.2)
325 (excl:def-fwrapper make-process/inherit (&key &allow-other-keys)
326 "Advice for MP:MAKE-PROCESS.
327 New threads that have a Swank thread for an ancestor will inherit
328 debugging and I/O bindings from their parent."
329 (let ((process (excl:call-next-fwrapper)))
330 (when *swank-thread*
331 (push (cons '*swank-thread* t)
332 (mp:process-initial-bindings process))
333 (dolist (variable *inherited-bindings*)
334 (push (cons variable (symbol-value variable))
335 (mp:process-initial-bindings process))))
336 process))
337
338 (defun install-advice ()
339 #+(version>= 6.2)
340 (excl:fwrap 'mp:make-process 'make-process/inherit 'make-process/inherit))
341
342 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
343 (defvar *thread-id-counter* 0)
344
345 (defimplementation thread-id (thread)
346 (mp:with-process-lock (*id-lock*)
347 (or (getf (mp:process-property-list thread) 'id)
348 (setf (getf (mp:process-property-list thread) 'id)
349 (incf *thread-id-counter*)))))
350
351 (defimplementation find-thread (id)
352 (find id mp:*all-processes*
353 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
354
355 (defimplementation thread-name (thread)
356 (mp:process-name thread))
357
358 (defimplementation thread-status (thread)
359 (format nil "~A ~D" (mp:process-whostate thread)
360 (mp:process-priority thread)))
361
362 (defimplementation make-lock (&key name)
363 (mp:make-process-lock :name name))
364
365 (defimplementation call-with-lock-held (lock function)
366 (mp:with-process-lock (lock) (funcall function)))
367
368 (defimplementation current-thread ()
369 mp:*current-process*)
370
371 (defimplementation all-threads ()
372 (copy-list mp:*all-processes*))
373
374 (defimplementation interrupt-thread (thread fn)
375 (mp:process-interrupt thread fn))
376
377 (defimplementation kill-thread (thread)
378 (mp:process-kill thread))
379
380 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
381
382 (defstruct (mailbox (:conc-name mailbox.))
383 (mutex (mp:make-process-lock :name "process mailbox"))
384 (queue '() :type list))
385
386 (defun mailbox (thread)
387 "Return THREAD's mailbox."
388 (mp:with-process-lock (*mailbox-lock*)
389 (or (getf (mp:process-property-list thread) 'mailbox)
390 (setf (getf (mp:process-property-list thread) 'mailbox)
391 (make-mailbox)))))
392
393 (defimplementation send (thread message)
394 (let* ((mbox (mailbox thread))
395 (mutex (mailbox.mutex mbox)))
396 (mp:process-wait-with-timeout
397 "yielding before sending" 0.1
398 (lambda ()
399 (mp:with-process-lock (mutex)
400 (< (length (mailbox.queue mbox)) 10))))
401 (mp:with-process-lock (mutex)
402 (setf (mailbox.queue mbox)
403 (nconc (mailbox.queue mbox) (list message))))))
404
405 (defimplementation receive ()
406 (let* ((mbox (mailbox mp:*current-process*))
407 (mutex (mailbox.mutex mbox)))
408 (mp:process-wait "receive" #'mailbox.queue mbox)
409 (mp:with-process-lock (mutex)
410 (pop (mailbox.queue mbox)))))
411
412 (defimplementation quit-lisp ()
413 (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5