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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (show annotations)
Fri May 21 08:19:47 2004 UTC (9 years, 11 months ago) by heller
Branch: MAIN
Changes since 1.30: +8 -15 lines
(find-fspec-location): Better handling of methods.  Reported by Bill
Clementson.
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
31 ;;;; TCP Server
32
33 (defimplementation preferred-communication-style ()
34 :spawn)
35
36 (defimplementation create-socket (host port)
37 (socket:make-socket :connect :passive :local-port port
38 :local-host host :reuse-address t))
39
40 (defimplementation local-port (socket)
41 (socket:local-port socket))
42
43 (defimplementation close-socket (socket)
44 (close socket))
45
46 (defimplementation accept-connection (socket)
47 (socket:accept-connection socket :wait t))
48
49 (defimplementation emacs-connected ())
50
51 ;;;; Unix signals
52
53 (defimplementation call-without-interrupts (fn)
54 (excl:without-interrupts (funcall fn)))
55
56 (defimplementation getpid ()
57 (excl::getpid))
58
59 (defimplementation lisp-implementation-type-name ()
60 "allegro")
61
62 (defimplementation set-default-directory (directory)
63 (excl:chdir directory)
64 (namestring (setf *default-pathname-defaults*
65 (truename (merge-pathnames directory)))))
66
67 ;;;; Misc
68
69 (defimplementation arglist (symbol)
70 (handler-case (excl:arglist symbol)
71 (simple-error () :not-available)))
72
73 (defimplementation macroexpand-all (form)
74 (excl::walk form))
75
76 (defimplementation describe-symbol-for-emacs (symbol)
77 (let ((result '()))
78 (flet ((doc (kind &optional (sym symbol))
79 (or (documentation sym kind) :not-documented))
80 (maybe-push (property value)
81 (when value
82 (setf result (list* property value result)))))
83 (maybe-push
84 :variable (when (boundp symbol)
85 (doc 'variable)))
86 (maybe-push
87 :function (if (fboundp symbol)
88 (doc 'function)))
89 (maybe-push
90 :class (if (find-class symbol nil)
91 (doc 'class)))
92 result)))
93
94 (defimplementation describe-definition (symbol namespace)
95 (ecase namespace
96 (:variable
97 (describe symbol))
98 ((:function :generic-function)
99 (describe (symbol-function symbol)))
100 (:class
101 (describe (find-class symbol)))))
102
103 ;;;; Debugger
104
105 (defvar *sldb-topframe*)
106
107 (defimplementation call-with-debugging-environment (debugger-loop-fn)
108 (let ((*sldb-topframe* (excl::int-newest-frame))
109 (excl::*break-hook* nil))
110 (funcall debugger-loop-fn)))
111
112 (defun nth-frame (index)
113 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
114 (i index (1- i)))
115 ((zerop i) frame)))
116
117 (defimplementation compute-backtrace (start end)
118 (let ((end (or end most-positive-fixnum)))
119 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
120 for i from start below end
121 while f
122 collect f)))
123
124 (defimplementation print-frame (frame stream)
125 (debugger:output-frame stream frame :moderate))
126
127 (defimplementation frame-locals (index)
128 (let ((frame (nth-frame index)))
129 (loop for i from 0 below (debugger:frame-number-vars frame)
130 collect (list :name (debugger:frame-var-name frame i)
131 :id 0
132 :value (debugger:frame-var-value frame i)))))
133
134 (defimplementation frame-catch-tags (index)
135 (declare (ignore index))
136 nil)
137
138 (defimplementation disassemble-frame (index)
139 (disassemble (debugger:frame-function (nth-frame index))))
140
141 (defimplementation frame-source-location-for-emacs (index)
142 (list :error (format nil "Cannot find source for frame: ~A"
143 (nth-frame index))))
144
145 (defimplementation eval-in-frame (form frame-number)
146 (debugger:eval-form-in-context
147 form
148 (debugger:environment-of-frame (nth-frame frame-number))))
149
150 (defimplementation return-from-frame (frame-number form)
151 (let ((frame (nth-frame frame-number)))
152 (multiple-value-call #'debugger:frame-return
153 frame (debugger:eval-form-in-context
154 form
155 (debugger:environment-of-frame frame)))))
156
157 ;;; XXX doesn't work for frames with arguments
158 (defimplementation restart-frame (frame-number)
159 (let ((frame (nth-frame frame-number)))
160 (debugger:frame-retry frame (debugger:frame-function frame))))
161
162 ;;;; Compiler hooks
163
164 (defvar *buffer-name* nil)
165 (defvar *buffer-start-position*)
166 (defvar *buffer-string*)
167 (defvar *compile-filename*)
168
169 (defun handle-compiler-warning (condition)
170 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
171 (signal (make-condition
172 'compiler-condition
173 :original-condition condition
174 :severity :warning
175 :message (format nil "~A" condition)
176 :location (cond (*buffer-name*
177 (make-location
178 (list :buffer *buffer-name*)
179 (list :position *buffer-start-position*)))
180 (loc
181 (destructuring-bind (file . pos) loc
182 (make-location
183 (list :file (namestring (truename file)))
184 (list :position (1+ pos)))))
185 (t
186 (make-location
187 (list :file *compile-filename*)
188 (list :position 1))))))))
189
190 (defimplementation swank-compile-file (*compile-filename* load-p)
191 (handler-bind ((warning #'handle-compiler-warning))
192 (let ((*buffer-name* nil))
193 (compile-file *compile-filename* :load-after-compile load-p))))
194
195 (defimplementation swank-compile-string (string &key buffer position)
196 (handler-bind ((warning #'handle-compiler-warning))
197 (let ((*buffer-name* buffer)
198 (*buffer-start-position* position)
199 (*buffer-string* string))
200 (funcall (compile nil (read-from-string
201 (format nil "(~S () ~A)" 'lambda string)))))))
202
203 ;;;; Definition Finding
204
205 (defun find-fspec-location (fspec type)
206 (let* ((fspec (if (consp fspec)
207 (excl::to-internal-fspec fspec)
208 fspec))
209 (info (car (excl::fspec-fspec-info fspec)))
210 (file (excl::fspec-info-pathname info)))
211 (etypecase file
212 (pathname
213 (let ((start (scm:find-definition-in-file fspec type file)))
214 (make-location (list :file (namestring (truename file)))
215 (if start
216 (list :position (1+ start))
217 (list :function-name (string (third info)))))))
218 ((member :top-level)
219 (list :error (format nil "Defined at toplevel: ~A" fspec)))
220 (null
221 (list :error (format nil "Unkown source location for ~A" fspec))))))
222
223 (defun fspec-definition-locations (fspec)
224 (let ((defs (excl::find-multiple-definitions fspec)))
225 (loop for (fspec type) in defs
226 collect (list fspec (find-fspec-location fspec type)))))
227
228 (defimplementation find-definitions (symbol)
229 (fspec-definition-locations symbol))
230
231 ;;;; XREF
232
233 (defmacro defxref (name relation name1 name2)
234 `(defimplementation ,name (x)
235 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
236
237 (defxref who-calls :calls :wild x)
238 (defxref who-references :uses :wild x)
239 (defxref who-binds :binds :wild x)
240 (defxref who-macroexpands :macro-calls :wild x)
241 (defxref who-sets :sets :wild x)
242 (defxref list-callees :calls x :wild)
243
244 (defun xref-result (fspecs)
245 (loop for fspec in fspecs
246 append (fspec-definition-locations fspec)))
247
248 ;;;; Inspecting
249
250 (defmethod inspected-parts (o)
251 (let* ((class (class-of o))
252 (slots (clos:class-slots class)))
253 (values (format nil "~A~% is a ~A" o class)
254 (mapcar (lambda (slot)
255 (let ((name (clos:slot-definition-name slot)))
256 (cons (princ-to-string name)
257 (slot-value o name))))
258 slots))))
259
260 ;;;; Multithreading
261
262 (defimplementation startup-multiprocessing ()
263 (mp:start-scheduler))
264
265 (defimplementation spawn (fn &key name)
266 (mp:process-run-function name fn))
267
268 (defimplementation thread-name (thread)
269 (mp:process-name thread))
270
271 (defimplementation thread-status (thread)
272 (format nil "~A ~D" (mp:process-whostate thread)
273 (mp:process-priority thread)))
274
275 (defimplementation make-lock (&key name)
276 (mp:make-process-lock :name name))
277
278 (defimplementation call-with-lock-held (lock function)
279 (mp:with-process-lock (lock) (funcall function)))
280
281 (defimplementation current-thread ()
282 mp:*current-process*)
283
284 (defimplementation all-threads ()
285 (copy-list mp:*all-processes*))
286
287 (defimplementation interrupt-thread (thread fn)
288 (mp:process-interrupt thread fn))
289
290 (defimplementation kill-thread (thread)
291 (mp:process-kill thread))
292
293 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
294
295 (defstruct (mailbox (:conc-name mailbox.))
296 (mutex (mp:make-process-lock :name "process mailbox"))
297 (queue '() :type list))
298
299 (defun mailbox (thread)
300 "Return THREAD's mailbox."
301 (mp:with-process-lock (*mailbox-lock*)
302 (or (getf (mp:process-property-list thread) 'mailbox)
303 (setf (getf (mp:process-property-list thread) 'mailbox)
304 (make-mailbox)))))
305
306 (defimplementation send (thread message)
307 (let* ((mbox (mailbox thread))
308 (mutex (mailbox.mutex mbox)))
309 (mp:process-wait-with-timeout
310 "yielding before sending" 0.1
311 (lambda ()
312 (mp:with-process-lock (mutex)
313 (< (length (mailbox.queue mbox)) 10))))
314 (mp:with-process-lock (mutex)
315 (setf (mailbox.queue mbox)
316 (nconc (mailbox.queue mbox) (list message))))))
317
318 (defimplementation receive ()
319 (let* ((mbox (mailbox mp:*current-process*))
320 (mutex (mailbox.mutex mbox)))
321 (mp:process-wait "receive" #'mailbox.queue mbox)
322 (mp:with-process-lock (mutex)
323 (pop (mailbox.queue mbox)))))
324
325 (defimplementation quit-lisp ()
326 (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5