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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5