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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (show annotations)
Mon Aug 2 05:23:57 2004 UTC (9 years, 8 months ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-1-0-BETA
Changes since 1.46: +1 -40 lines
Removed fwrapper-based code for inheriting "swankiness" to newly
spawned threads. This was fighting the system and not the right thing.
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 (defimplementation format-sldb-condition (c)
49 (princ-to-string c))
50
51 (defimplementation condition-references (c)
52 (declare (ignore c))
53 '())
54
55 (defimplementation call-with-syntax-hooks (fn)
56 (funcall fn))
57
58 ;;;; Unix signals
59
60 (defimplementation call-without-interrupts (fn)
61 (excl:without-interrupts (funcall fn)))
62
63 (defimplementation getpid ()
64 (excl::getpid))
65
66 (defimplementation lisp-implementation-type-name ()
67 "allegro")
68
69 (defimplementation set-default-directory (directory)
70 (excl:chdir directory)
71 (namestring (setf *default-pathname-defaults*
72 (truename (merge-pathnames directory)))))
73
74 (defimplementation default-directory ()
75 (excl:chdir))
76
77 ;;;; Misc
78
79 (defimplementation arglist (symbol)
80 (handler-case (excl:arglist symbol)
81 (simple-error () :not-available)))
82
83 (defimplementation macroexpand-all (form)
84 (excl::walk form))
85
86 (defimplementation describe-symbol-for-emacs (symbol)
87 (let ((result '()))
88 (flet ((doc (kind &optional (sym symbol))
89 (or (documentation sym kind) :not-documented))
90 (maybe-push (property value)
91 (when value
92 (setf result (list* property value result)))))
93 (maybe-push
94 :variable (when (boundp symbol)
95 (doc 'variable)))
96 (maybe-push
97 :function (if (fboundp symbol)
98 (doc 'function)))
99 (maybe-push
100 :class (if (find-class symbol nil)
101 (doc 'class)))
102 result)))
103
104 (defimplementation describe-definition (symbol namespace)
105 (ecase namespace
106 (:variable
107 (describe symbol))
108 ((:function :generic-function)
109 (describe (symbol-function symbol)))
110 (:class
111 (describe (find-class symbol)))))
112
113 (defimplementation make-stream-interactive (stream)
114 (setf (interactive-stream-p stream) t))
115
116 ;;;; Debugger
117
118 (defvar *sldb-topframe*)
119
120 (defimplementation call-with-debugging-environment (debugger-loop-fn)
121 (let ((*sldb-topframe* (excl::int-newest-frame))
122 (excl::*break-hook* nil))
123 (funcall debugger-loop-fn)))
124
125 (defun next-frame (frame)
126 (let ((next (excl::int-next-older-frame frame)))
127 (cond ((not next) nil)
128 ((debugger:frame-visible-p next) next)
129 (t (next-frame next)))))
130
131 (defun nth-frame (index)
132 (do ((frame *sldb-topframe* (next-frame frame))
133 (i index (1- i)))
134 ((zerop i) frame)))
135
136 (defimplementation compute-backtrace (start end)
137 (let ((end (or end most-positive-fixnum)))
138 (loop for f = (nth-frame start) then (next-frame f)
139 for i from start below end
140 while f
141 collect f)))
142
143 (defimplementation print-frame (frame stream)
144 (debugger:output-frame stream frame :moderate))
145
146 (defimplementation frame-locals (index)
147 (let ((frame (nth-frame index)))
148 (loop for i from 0 below (debugger:frame-number-vars frame)
149 collect (list :name (debugger:frame-var-name frame i)
150 :id 0
151 :value (debugger:frame-var-value frame i)))))
152
153 (defimplementation frame-var-value (frame var)
154 (let ((frame (nth-frame frame)))
155 (debugger:frame-var-value frame var)))
156
157 (defimplementation frame-catch-tags (index)
158 (declare (ignore index))
159 nil)
160
161 (defimplementation disassemble-frame (index)
162 (disassemble (debugger:frame-function (nth-frame index))))
163
164 (defimplementation frame-source-location-for-emacs (index)
165 (let* ((frame (nth-frame index))
166 (expr (debugger:frame-expression frame))
167 (fspec (first expr)))
168 (second (first (fspec-definition-locations fspec)))))
169
170 (defimplementation eval-in-frame (form frame-number)
171 (debugger:eval-form-in-context
172 form
173 (debugger:environment-of-frame (nth-frame frame-number))))
174
175 (defimplementation return-from-frame (frame-number form)
176 (let ((frame (nth-frame frame-number)))
177 (multiple-value-call #'debugger:frame-return
178 frame (debugger:eval-form-in-context
179 form
180 (debugger:environment-of-frame frame)))))
181
182 ;;; XXX doesn't work for frames with arguments
183 (defimplementation restart-frame (frame-number)
184 (let ((frame (nth-frame frame-number)))
185 (debugger:frame-retry frame (debugger:frame-function frame))))
186
187 ;;;; Compiler hooks
188
189 (defvar *buffer-name* nil)
190 (defvar *buffer-start-position*)
191 (defvar *buffer-string*)
192 (defvar *compile-filename* nil)
193
194 (defun handle-compiler-warning (condition)
195 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
196 (signal (make-condition
197 'compiler-condition
198 :original-condition condition
199 :severity :warning
200 :message (format nil "~A" condition)
201 :location (cond (*buffer-name*
202 (make-location
203 (list :buffer *buffer-name*)
204 (list :position *buffer-start-position*)))
205 (loc
206 (destructuring-bind (file . pos) loc
207 (make-location
208 (list :file (namestring (truename file)))
209 (list :position (1+ pos)))))
210 (*compile-filename*
211 (make-location
212 (list :file *compile-filename*)
213 (list :position 1)))
214 (t
215 (list :error "No error location available.")))))))
216
217 (defimplementation call-with-compilation-hooks (function)
218 (handler-bind ((warning #'handle-compiler-warning))
219 (funcall function)))
220
221 (defimplementation swank-compile-file (*compile-filename* load-p)
222 (with-compilation-hooks ()
223 (let ((*buffer-name* nil))
224 (compile-file *compile-filename* :load-after-compile load-p))))
225
226 (defun call-with-temp-file (fn)
227 (let ((tmpname (system:make-temp-file-name)))
228 (unwind-protect
229 (with-open-file (file tmpname :direction :output :if-exists :error)
230 (funcall fn file tmpname))
231 (delete-file tmpname))))
232
233 (defun compile-from-temp-file (string)
234 (call-with-temp-file
235 (lambda (stream filename)
236 (write-string string stream)
237 (finish-output stream)
238 (let ((binary-filename (compile-file filename :load-after-compile t)))
239 (when binary-filename
240 (delete-file binary-filename))))))
241
242 (defimplementation swank-compile-string (string &key buffer position)
243 ;; We store the source buffer in excl::*source-pathname* as a string
244 ;; of the form <buffername>:<start-offset>. Quite ugly encoding, but
245 ;; the fasl file is corrupted if we use some other datatype.
246 (with-compilation-hooks ()
247 (let ((*buffer-name* buffer)
248 (*buffer-start-position* position)
249 (*buffer-string* string))
250 (compile-from-temp-file
251 (format nil "~S ~S~%~A"
252 `(in-package ,(package-name *package*))
253 `(eval-when (:compile-toplevel :load-toplevel)
254 (setq excl::*source-pathname*
255 (format nil "~A:~D" ',buffer ',position)))
256 string)))))
257
258 ;;;; Definition Finding
259
260 (defun fspec-primary-name (fspec)
261 (etypecase fspec
262 (symbol (string fspec))
263 (list (string (second fspec)))))
264
265 (defun find-fspec-location (fspec type)
266 (let ((file (excl:source-file fspec)))
267 (etypecase file
268 (pathname
269 (let* ((start (scm:find-definition-in-file fspec type file))
270 (pos (if start
271 (list :position (1+ start))
272 (list :function-name (fspec-primary-name fspec)))))
273 (make-location (list :file (namestring (truename file)))
274 pos)))
275 ((member :top-level)
276 (list :error (format nil "Defined at toplevel: ~A" fspec)))
277 (string
278 (let ((pos (position #\: file)))
279 (make-location
280 (list :buffer (subseq file 0 pos))
281 (list :position (parse-integer (subseq file (1+ pos)))))))
282 (null
283 (list :error (format nil "Unknown source location for ~A" fspec))))))
284
285 (defun fspec-definition-locations (fspec)
286 (let ((defs (excl::find-multiple-definitions fspec)))
287 (loop for (fspec type) in defs
288 collect (list fspec (find-fspec-location fspec type)))))
289
290 (defimplementation find-definitions (symbol)
291 (fspec-definition-locations symbol))
292
293 ;;;; XREF
294
295 (defmacro defxref (name relation name1 name2)
296 `(defimplementation ,name (x)
297 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
298
299 (defxref who-calls :calls :wild x)
300 (defxref who-references :uses :wild x)
301 (defxref who-binds :binds :wild x)
302 (defxref who-macroexpands :macro-calls :wild x)
303 (defxref who-sets :sets :wild x)
304 (defxref list-callees :calls x :wild)
305
306 (defun xref-result (fspecs)
307 (loop for fspec in fspecs
308 append (fspec-definition-locations fspec)))
309
310 ;; list-callers implemented by groveling through all fbound symbols.
311 ;; Only symbols are considered. Functions in the constant pool are
312 ;; searched recursevly. Closure environments are ignored at the
313 ;; moment (constants in methods are therefore not found).
314
315 (defun map-function-constants (function fn depth)
316 "Call FN with the elements of FUNCTION's constant pool."
317 (do ((i 0 (1+ i))
318 (max (excl::function-constant-count function)))
319 ((= i max))
320 (let ((c (excl::function-constant function i)))
321 (cond ((and (functionp c)
322 (not (eq c function))
323 (plusp depth))
324 (map-function-constants c fn (1- depth)))
325 (t
326 (funcall fn c))))))
327
328 (defun in-constants-p (fn symbol)
329 (map-function-constants
330 fn
331 (lambda (c) (if (eq c symbol) (return-from in-constants-p t)))
332 3))
333
334 (defun function-callers (name)
335 (let ((callers '()))
336 (do-all-symbols (sym)
337 (when (fboundp sym)
338 (let ((fn (fdefinition sym)))
339 (when (in-constants-p fn name)
340 (push sym callers)))))
341 callers))
342
343 (defimplementation list-callers (name)
344 (xref-result (function-callers name)))
345
346 ;;;; Inspecting
347
348 (defmethod inspected-parts (o)
349 (let* ((class (class-of o))
350 (slots (clos:class-slots class)))
351 (values (format nil "~A~% is a ~A" o class)
352 (mapcar (lambda (slot)
353 (let ((name (clos:slot-definition-name slot)))
354 (cons (princ-to-string name)
355 (if (slot-boundp o name)
356 (slot-value o name)
357 (make-unbound-slot-filler)))))
358 slots))))
359
360 ;;;; Multithreading
361
362 (defimplementation startup-multiprocessing ()
363 (mp:start-scheduler))
364
365 (defimplementation spawn (fn &key name)
366 (mp:process-run-function name fn))
367
368 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
369 (defvar *thread-id-counter* 0)
370
371 (defimplementation thread-id (thread)
372 (mp:with-process-lock (*id-lock*)
373 (or (getf (mp:process-property-list thread) 'id)
374 (setf (getf (mp:process-property-list thread) 'id)
375 (incf *thread-id-counter*)))))
376
377 (defimplementation find-thread (id)
378 (find id mp:*all-processes*
379 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
380
381 (defimplementation thread-name (thread)
382 (mp:process-name thread))
383
384 (defimplementation thread-status (thread)
385 (format nil "~A ~D" (mp:process-whostate thread)
386 (mp:process-priority thread)))
387
388 (defimplementation make-lock (&key name)
389 (mp:make-process-lock :name name))
390
391 (defimplementation call-with-lock-held (lock function)
392 (mp:with-process-lock (lock) (funcall function)))
393
394 (defimplementation current-thread ()
395 mp:*current-process*)
396
397 (defimplementation all-threads ()
398 (copy-list mp:*all-processes*))
399
400 (defimplementation interrupt-thread (thread fn)
401 (mp:process-interrupt thread fn))
402
403 (defimplementation kill-thread (thread)
404 (mp:process-kill thread))
405
406 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
407
408 (defstruct (mailbox (:conc-name mailbox.))
409 (mutex (mp:make-process-lock :name "process mailbox"))
410 (queue '() :type list))
411
412 (defun mailbox (thread)
413 "Return THREAD's mailbox."
414 (mp:with-process-lock (*mailbox-lock*)
415 (or (getf (mp:process-property-list thread) 'mailbox)
416 (setf (getf (mp:process-property-list thread) 'mailbox)
417 (make-mailbox)))))
418
419 (defimplementation send (thread message)
420 (let* ((mbox (mailbox thread))
421 (mutex (mailbox.mutex mbox)))
422 (mp:process-wait-with-timeout
423 "yielding before sending" 0.1
424 (lambda ()
425 (mp:with-process-lock (mutex)
426 (< (length (mailbox.queue mbox)) 10))))
427 (mp:with-process-lock (mutex)
428 (setf (mailbox.queue mbox)
429 (nconc (mailbox.queue mbox) (list message))))))
430
431 (defimplementation receive ()
432 (let* ((mbox (mailbox mp:*current-process*))
433 (mutex (mailbox.mutex mbox)))
434 (mp:process-wait "receive" #'mailbox.queue mbox)
435 (mp:with-process-lock (mutex)
436 (pop (mailbox.queue mbox)))))
437
438 (defimplementation quit-lisp ()
439 (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5