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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (hide annotations)
Sun Jul 4 00:36:14 2004 UTC (9 years, 9 months ago) by lgorrie
Branch: MAIN
Changes since 1.44: +2 -2 lines
*** empty log message ***
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 lgorrie 1.33 (require :process)
17 heller 1.1
18 lgorrie 1.33 (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 heller 1.1
30 heller 1.8 ;;;; TCP Server
31 heller 1.1
32 heller 1.21 (defimplementation preferred-communication-style ()
33     :spawn)
34 heller 1.12
35 heller 1.14 (defimplementation create-socket (host port)
36     (socket:make-socket :connect :passive :local-port port
37     :local-host host :reuse-address t))
38 heller 1.5
39 heller 1.10 (defimplementation local-port (socket)
40 heller 1.6 (socket:local-port socket))
41    
42 heller 1.10 (defimplementation close-socket (socket)
43 heller 1.6 (close socket))
44    
45 heller 1.10 (defimplementation accept-connection (socket)
46 heller 1.6 (socket:accept-connection socket :wait t))
47    
48 heller 1.34 ;; The following defitinions are workarounds for the buggy
49     ;; no-applicable-method function in Allegro 5. We have to provide an
50     ;; implementation.
51 heller 1.36 (defimplementation emacs-connected (stream)
52 lgorrie 1.43 (declare (ignore stream))
53     (install-advice))
54 heller 1.34
55     (defimplementation format-sldb-condition (c)
56     (princ-to-string c))
57    
58     (defimplementation condition-references (c)
59 heller 1.39 (declare (ignore c))
60 heller 1.34 '())
61 heller 1.7
62 heller 1.39 (defimplementation call-with-syntax-hooks (fn)
63     (funcall fn))
64    
65 heller 1.9 ;;;; Unix signals
66    
67 heller 1.10 (defimplementation call-without-interrupts (fn)
68 heller 1.9 (excl:without-interrupts (funcall fn)))
69    
70 heller 1.10 (defimplementation getpid ()
71 heller 1.8 (excl::getpid))
72 heller 1.6
73 heller 1.15 (defimplementation lisp-implementation-type-name ()
74     "allegro")
75    
76 pseibel 1.28 (defimplementation set-default-directory (directory)
77     (excl:chdir directory)
78 heller 1.31 (namestring (setf *default-pathname-defaults*
79     (truename (merge-pathnames directory)))))
80 pseibel 1.28
81 heller 1.35 (defimplementation default-directory ()
82     (excl:chdir))
83    
84 heller 1.8 ;;;; Misc
85 heller 1.1
86 heller 1.21 (defimplementation arglist (symbol)
87 lgorrie 1.30 (handler-case (excl:arglist symbol)
88     (simple-error () :not-available)))
89 heller 1.21
90     (defimplementation macroexpand-all (form)
91     (excl::walk form))
92 heller 1.1
93 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
94 heller 1.1 (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 heller 1.20 (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 heller 1.10
120 lgorrie 1.43 (defimplementation make-stream-interactive (stream)
121     (setf (interactive-stream-p stream) t))
122    
123 heller 1.8 ;;;; Debugger
124    
125 heller 1.1 (defvar *sldb-topframe*)
126 heller 1.4
127 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
128 heller 1.4 (let ((*sldb-topframe* (excl::int-newest-frame))
129 heller 1.20 (excl::*break-hook* nil))
130 heller 1.4 (funcall debugger-loop-fn)))
131 heller 1.1
132 heller 1.42 (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 heller 1.1 (defun nth-frame (index)
139 heller 1.42 (do ((frame *sldb-topframe* (next-frame frame))
140 heller 1.1 (i index (1- i)))
141     ((zerop i) frame)))
142    
143 heller 1.20 (defimplementation compute-backtrace (start end)
144 heller 1.1 (let ((end (or end most-positive-fixnum)))
145 heller 1.42 (loop for f = (nth-frame start) then (next-frame f)
146 heller 1.1 for i from start below end
147     while f
148 heller 1.42 collect f)))
149 heller 1.1
150 heller 1.20 (defimplementation print-frame (frame stream)
151     (debugger:output-frame stream frame :moderate))
152 heller 1.4
153 heller 1.10 (defimplementation frame-locals (index)
154 heller 1.1 (let ((frame (nth-frame index)))
155     (loop for i from 0 below (debugger:frame-number-vars frame)
156 mbaringer 1.19 collect (list :name (debugger:frame-var-name frame i)
157 heller 1.1 :id 0
158 mbaringer 1.19 :value (debugger:frame-var-value frame i)))))
159 heller 1.1
160 heller 1.39 (defimplementation frame-var-value (frame var)
161     (let ((frame (nth-frame frame)))
162     (debugger:frame-var-value frame var)))
163    
164 heller 1.10 (defimplementation frame-catch-tags (index)
165 heller 1.1 (declare (ignore index))
166     nil)
167    
168 heller 1.21 (defimplementation disassemble-frame (index)
169     (disassemble (debugger:frame-function (nth-frame index))))
170    
171 heller 1.10 (defimplementation frame-source-location-for-emacs (index)
172 lgorrie 1.37 (let* ((frame (nth-frame index))
173     (expr (debugger:frame-expression frame))
174     (fspec (first expr)))
175     (second (first (fspec-definition-locations fspec)))))
176 heller 1.4
177 heller 1.10 (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 heller 1.11 (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 heller 1.20 form
187     (debugger:environment-of-frame frame)))))
188 heller 1.11
189 heller 1.21 ;;; XXX doesn't work for frames with arguments
190 heller 1.11 (defimplementation restart-frame (frame-number)
191     (let ((frame (nth-frame frame-number)))
192     (debugger:frame-retry frame (debugger:frame-function frame))))
193    
194 heller 1.8 ;;;; Compiler hooks
195    
196 heller 1.1 (defvar *buffer-name* nil)
197     (defvar *buffer-start-position*)
198     (defvar *buffer-string*)
199 lgorrie 1.33 (defvar *compile-filename* nil)
200 heller 1.1
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 lgorrie 1.33 (*compile-filename*
218 heller 1.1 (make-location
219     (list :file *compile-filename*)
220 lgorrie 1.33 (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 heller 1.1
228 heller 1.20 (defimplementation swank-compile-file (*compile-filename* load-p)
229 lgorrie 1.33 (with-compilation-hooks ()
230 heller 1.1 (let ((*buffer-name* nil))
231 heller 1.4 (compile-file *compile-filename* :load-after-compile load-p))))
232 heller 1.1
233 heller 1.20 (defimplementation swank-compile-string (string &key buffer position)
234 lgorrie 1.33 (with-compilation-hooks ()
235 heller 1.20 (let ((*buffer-name* buffer)
236 heller 1.1 (*buffer-start-position* position)
237     (*buffer-string* string))
238 heller 1.20 (funcall (compile nil (read-from-string
239 heller 1.24 (format nil "(~S () ~A)" 'lambda string)))))))
240 heller 1.1
241 heller 1.8 ;;;; Definition Finding
242    
243 heller 1.32 (defun fspec-primary-name (fspec)
244     (etypecase fspec
245     (symbol (string fspec))
246     (list (string (second fspec)))))
247    
248 heller 1.21 (defun find-fspec-location (fspec type)
249 heller 1.32 (let ((file (excl:source-file fspec)))
250 heller 1.21 (etypecase file
251     (pathname
252 heller 1.32 (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 heller 1.21 (make-location (list :file (namestring (truename file)))
257 heller 1.32 pos)))
258 heller 1.21 ((member :top-level)
259     (list :error (format nil "Defined at toplevel: ~A" fspec)))
260     (null
261 lgorrie 1.37 (list :error (format nil "Unknown source location for ~A" fspec))))))
262 heller 1.21
263     (defun fspec-definition-locations (fspec)
264 heller 1.1 (let ((defs (excl::find-multiple-definitions fspec)))
265 heller 1.21 (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 heller 1.1
271 heller 1.8 ;;;; XREF
272    
273 heller 1.21 (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 heller 1.4
288 heller 1.18 ;;;; 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 heller 1.20 (cons (princ-to-string name)
297 lgorrie 1.38 (if (slot-boundp o name)
298     (slot-value o name)
299     (make-unbound-slot-filler)))))
300 heller 1.18 slots))))
301    
302     ;;;; Multithreading
303 heller 1.8
304 lgorrie 1.43 (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 heller 1.10 (defimplementation startup-multiprocessing ()
316 heller 1.8 (mp:start-scheduler))
317    
318 heller 1.10 (defimplementation spawn (fn &key name)
319 lgorrie 1.43 (mp:process-run-function name
320     (lambda ()
321     (let ((*swank-thread* t))
322     (funcall fn)))))
323    
324 lgorrie 1.45 #+(version>= 6)
325 lgorrie 1.43 (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 lgorrie 1.45 #+(version>= 6)
340 lgorrie 1.43 (excl:fwrap 'mp:make-process 'make-process/inherit 'make-process/inherit))
341 heller 1.8
342 heller 1.40 (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 heller 1.13 (defimplementation thread-name (thread)
356     (mp:process-name thread))
357 heller 1.8
358 heller 1.13 (defimplementation thread-status (thread)
359     (format nil "~A ~D" (mp:process-whostate thread)
360     (mp:process-priority thread)))
361 heller 1.8
362 heller 1.10 (defimplementation make-lock (&key name)
363 heller 1.8 (mp:make-process-lock :name name))
364    
365 heller 1.10 (defimplementation call-with-lock-held (lock function)
366 heller 1.8 (mp:with-process-lock (lock) (funcall function)))
367 heller 1.12
368     (defimplementation current-thread ()
369     mp:*current-process*)
370    
371     (defimplementation all-threads ()
372 heller 1.13 (copy-list mp:*all-processes*))
373 heller 1.12
374     (defimplementation interrupt-thread (thread fn)
375     (mp:process-interrupt thread fn))
376    
377 heller 1.16 (defimplementation kill-thread (thread)
378     (mp:process-kill thread))
379    
380 heller 1.12 (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 heller 1.25 (mp:process-wait-with-timeout
397     "yielding before sending" 0.1
398     (lambda ()
399     (mp:with-process-lock (mutex)
400 heller 1.26 (< (length (mailbox.queue mbox)) 10))))
401 heller 1.12 (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 mbaringer 1.27
412     (defimplementation quit-lisp ()
413     (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5