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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Thu Mar 4 22:15:40 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.17: +13 -1 lines
(thread-alive-p): Add default implementation.

(describe-primitive-type): Add default implementation.
(inspected-parts): Implemented for Allegro and CLISP.
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 (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
28 excl:stream-read-char-no-hang
29 ))
30
31 ;;;; TCP Server
32
33 (setq *swank-in-background* :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 (defimplementation emacs-connected ())
49
50 ;;;; Unix signals
51
52 (defimplementation call-without-interrupts (fn)
53 (excl:without-interrupts (funcall fn)))
54
55 (defimplementation getpid ()
56 (excl::getpid))
57
58 (defimplementation lisp-implementation-type-name ()
59 "allegro")
60
61 ;;;; Misc
62
63 (defimplementation arglist-string (fname)
64 (format-arglist fname #'excl:arglist))
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
74 (defimplementation describe-symbol-for-emacs (symbol)
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
92 (defimplementation macroexpand-all (form)
93 (excl::walk form))
94
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
104 ;;;; Debugger
105
106 (defvar *sldb-topframe*)
107 (defvar *sldb-source*)
108 (defvar *sldb-restarts*)
109
110 (defimplementation call-with-debugging-environment (debugger-loop-fn)
111 (let ((*sldb-topframe* (excl::int-newest-frame))
112 (excl::*break-hook* nil)
113 (*sldb-restarts*
114 (compute-restarts *swank-debugger-condition*)))
115 (funcall debugger-loop-fn)))
116
117 (defun format-restarts-for-emacs ()
118 (loop for restart in *sldb-restarts*
119 collect (list (princ-to-string (restart-name restart))
120 (princ-to-string restart))))
121
122 (defun nth-frame (index)
123 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
124 (i index (1- i)))
125 ((zerop i) frame)))
126
127 (defun compute-backtrace (start end)
128 (let ((end (or end most-positive-fixnum)))
129 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
130 for i from start below end
131 while f
132 collect f)))
133
134 (defimplementation backtrace (start-frame-number end-frame-number)
135 (flet ((format-frame (f i)
136 (print-with-frame-label
137 i (lambda (s) (debugger:output-frame s f :moderate)))))
138 (loop for i from start-frame-number
139 for f in (compute-backtrace start-frame-number end-frame-number)
140 collect (list i (format-frame f i)))))
141
142 (defimplementation debugger-info-for-emacs (start end)
143 (list (debugger-condition-for-emacs)
144 (format-restarts-for-emacs)
145 (backtrace start end)))
146
147 (defun nth-restart (index)
148 (nth index *sldb-restarts*))
149
150 (defslimefun invoke-nth-restart (index)
151 (invoke-restart-interactively (nth-restart index)))
152
153 (defslimefun sldb-abort ()
154 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
155
156 (defimplementation frame-locals (index)
157 (let ((frame (nth-frame index)))
158 (loop for i from 0 below (debugger:frame-number-vars frame)
159 collect (list :name (to-string (debugger:frame-var-name frame i))
160 :id 0
161 :value-string
162 (to-string (debugger:frame-var-value frame i))))))
163
164 (defimplementation frame-catch-tags (index)
165 (declare (ignore index))
166 nil)
167
168 (defimplementation frame-source-location-for-emacs (index)
169 (list :error (format nil "Cannot find source for frame: ~A"
170 (nth-frame index))))
171
172 (defimplementation eval-in-frame (form frame-number)
173 (debugger:eval-form-in-context
174 form
175 (debugger:environment-of-frame (nth-frame frame-number))))
176
177 (defimplementation return-from-frame (frame-number form)
178 (let ((frame (nth-frame frame-number)))
179 (multiple-value-call #'debugger:frame-return
180 frame (debugger:eval-form-in-context
181 (from-string form) (debugger:environment-of-frame frame)))))
182
183 ;;; XXX doens't work for frames with arguments
184 (defimplementation restart-frame (frame-number)
185 (let ((frame (nth-frame frame-number)))
186 (debugger:frame-retry frame (debugger:frame-function frame))))
187
188 ;;;; Compiler hooks
189
190 (defvar *buffer-name* nil)
191 (defvar *buffer-start-position*)
192 (defvar *buffer-string*)
193 (defvar *compile-filename*)
194
195 (defun handle-compiler-warning (condition)
196 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
197 (signal (make-condition
198 'compiler-condition
199 :original-condition condition
200 :severity :warning
201 :message (format nil "~A" condition)
202 :location (cond (*buffer-name*
203 (make-location
204 (list :buffer *buffer-name*)
205 (list :position *buffer-start-position*)))
206 (loc
207 (destructuring-bind (file . pos) loc
208 (make-location
209 (list :file (namestring (truename file)))
210 (list :position (1+ pos)))))
211 (t
212 (make-location
213 (list :file *compile-filename*)
214 (list :position 1))))))))
215
216 (defimplementation compile-file-for-emacs (*compile-filename* load-p)
217 (handler-bind ((warning #'handle-compiler-warning))
218 (let ((*buffer-name* nil))
219 (compile-file *compile-filename* :load-after-compile load-p))))
220
221 (defimplementation compile-string-for-emacs (string &key buffer position)
222 (handler-bind ((warning #'handle-compiler-warning))
223 (let ((*package* *buffer-package*)
224 (*buffer-name* buffer)
225 (*buffer-start-position* position)
226 (*buffer-string* string))
227 (eval (from-string
228 (format nil "(funcall (compile nil '(lambda () ~A)))" string))))))
229
230 ;;;; Definition Finding
231
232 (defun fspec-source-locations (fspec)
233 (let ((defs (excl::find-multiple-definitions fspec)))
234 (let ((locations '()))
235 (loop for (fspec type) in defs do
236 (let ((file (excl::fspec-pathname fspec type)))
237 (etypecase file
238 (pathname
239 (let ((start (scm:find-definition-in-file fspec type file)))
240 (push (make-location
241 (list :file (namestring (truename file)))
242 (if start
243 (list :position (1+ start))
244 (list :function-name (string fspec))))
245 locations)))
246 ((member :top-level)
247 (push (list :error (format nil "Defined at toplevel: ~A"
248 fspec))
249 locations))
250 (null
251 (push (list :error (format nil
252 "Unkown source location for ~A"
253 fspec))
254 locations))
255 )))
256 locations)))
257
258 (defimplementation find-function-locations (symbol-name)
259 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
260 (cond ((not foundp)
261 (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
262 ((macro-function symbol)
263 (fspec-source-locations symbol))
264 ((special-operator-p symbol)
265 (list (list :error (format nil "~A is a special-operator" symbol))))
266 ((fboundp symbol)
267 (fspec-source-locations symbol))
268 (t (list (list :error
269 (format nil "Symbol not fbound: ~A" symbol-name))))
270 )))
271
272 ;;;; XREF
273
274 (defun lookup-xrefs (finder name)
275 (xref-results-for-emacs (funcall finder (from-string name))))
276
277 (defimplementation who-calls (function-name)
278 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
279 function-name))
280
281 (defimplementation who-references (variable)
282 (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))
283 variable))
284
285 (defimplementation who-binds (variable)
286 (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))
287 variable))
288
289 (defimplementation who-macroexpands (variable)
290 (lookup-xrefs (lambda (x) (xref:get-relation :macro-calls :wild x))
291 variable))
292
293 (defimplementation who-sets (variable)
294 (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))
295 variable))
296
297 (defimplementation list-callers (name)
298 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
299 name))
300
301 (defimplementation list-callees (name)
302 (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))
303 name))
304
305 (defun xref-results-for-emacs (fspecs)
306 (let ((xrefs '()))
307 (dolist (fspec fspecs)
308 (dolist (location (fspec-source-locations fspec))
309 (push (cons (to-string fspec) location) xrefs)))
310 (group-xrefs xrefs)))
311
312 ;;;; Inspecting
313
314 (defmethod inspected-parts (o)
315 (let* ((class (class-of o))
316 (slots (clos:class-slots class)))
317 (values (format nil "~A~% is a ~A" o class)
318 (mapcar (lambda (slot)
319 (let ((name (clos:slot-definition-name slot)))
320 (cons (to-string name)
321 (slot-value o name))))
322 slots))))
323
324 ;;;; Multithreading
325
326 (defimplementation startup-multiprocessing ()
327 (mp:start-scheduler))
328
329 (defimplementation spawn (fn &key name)
330 (mp:process-run-function name fn))
331
332 (defimplementation thread-name (thread)
333 (mp:process-name thread))
334
335 (defimplementation thread-status (thread)
336 (format nil "~A ~D" (mp:process-whostate thread)
337 (mp:process-priority thread)))
338
339 (defimplementation make-lock (&key name)
340 (mp:make-process-lock :name name))
341
342 (defimplementation call-with-lock-held (lock function)
343 (mp:with-process-lock (lock) (funcall function)))
344
345 (defimplementation current-thread ()
346 mp:*current-process*)
347
348 (defimplementation all-threads ()
349 (copy-list mp:*all-processes*))
350
351 (defimplementation interrupt-thread (thread fn)
352 (mp:process-interrupt thread fn))
353
354 (defimplementation kill-thread (thread)
355 (mp:process-kill thread))
356
357 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
358
359 (defstruct (mailbox (:conc-name mailbox.))
360 (mutex (mp:make-process-lock :name "process mailbox"))
361 (queue '() :type list))
362
363 (defun mailbox (thread)
364 "Return THREAD's mailbox."
365 (mp:with-process-lock (*mailbox-lock*)
366 (or (getf (mp:process-property-list thread) 'mailbox)
367 (setf (getf (mp:process-property-list thread) 'mailbox)
368 (make-mailbox)))))
369
370 (defimplementation send (thread message)
371 (let* ((mbox (mailbox thread))
372 (mutex (mailbox.mutex mbox)))
373 (mp:with-process-lock (mutex)
374 (setf (mailbox.queue mbox)
375 (nconc (mailbox.queue mbox) (list message))))))
376
377 (defimplementation receive ()
378 (let* ((mbox (mailbox mp:*current-process*))
379 (mutex (mailbox.mutex mbox)))
380 (mp:process-wait "receive" #'mailbox.queue mbox)
381 (mp:with-process-lock (mutex)
382 (pop (mailbox.queue mbox)))))

  ViewVC Help
Powered by ViewVC 1.1.5