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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (show annotations)
Tue Sep 14 16:01:07 2004 UTC (9 years, 7 months ago) by mbaringer
Branch: MAIN
Changes since 1.55: +32 -22 lines
2004-09-14  Marco Baringer  <mb@bese.it>

	* swank-backend.lisp (inspector, make-default-inspector): Add an
	INSPECTOR object argument to the inspector protocol. This allows
	implementations to provide more information regarding cretain
	objects which can't be, or simply aren't, inspected using the
	generic inspector implementation. also export inspect-for-emacs
	and related symbols from the backend package.
	(make-default-inspector): New function.

	* swank.lisp (inspected-parts): Rename to inspect-for-emacs and
	add an inspector argument. Move inspect-for-emacs to
	swank-backend.lisp, leave only the default implementations.

	* swank-openml.lisp, swank-sbcl.lisp, swank-allegro.lisp,
	swank-cmucl.lisp, swank-lispworks.lisp (inspected-parts): Rename
	and change argument list. Many of the inspected-parts methods were
	being clobbered by the inspected-parts in swank.lisp, now that
	they're being used the return values have been updated for the new
	inspect-for-emacs API.
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 ;;; swank-mop
31
32 ;; maybe better change MOP to ACLMOP ?
33 (import-to-swank-mop
34 '( ;; classes
35 cl:standard-generic-function
36 mop::standard-slot-definition
37 cl:method
38 cl:standard-class
39 ;; standard-class readers
40 mop:class-default-initargs
41 mop:class-direct-default-initargs
42 mop:class-direct-slots
43 mop:class-direct-subclasses
44 mop:class-direct-superclasses
45 mop:class-finalized-p
46 cl:class-name
47 mop:class-precedence-list
48 mop:class-prototype
49 mop:class-slots
50 ;; generic function readers
51 mop:generic-function-argument-precedence-order
52 mop:generic-function-declarations
53 mop:generic-function-lambda-list
54 mop:generic-function-methods
55 mop:generic-function-method-class
56 mop:generic-function-method-combination
57 mop:generic-function-name
58 ;; method readers
59 mop:method-generic-function
60 mop:method-function
61 mop:method-lambda-list
62 mop:method-specializers
63 excl::method-qualifiers
64 ;; slot readers
65 mop:slot-definition-allocation
66 mop:slot-definition-initargs
67 mop:slot-definition-initform
68 mop:slot-definition-initfunction
69 mop:slot-definition-name
70 mop:slot-definition-type
71 mop:slot-definition-readers
72 mop:slot-definition-writers))
73
74 (defun swank-mop:slot-definition-documentation (slot)
75 (documentation slot))
76
77 ;;;; TCP Server
78
79 (defimplementation preferred-communication-style ()
80 :spawn)
81
82 (defimplementation create-socket (host port)
83 (socket:make-socket :connect :passive :local-port port
84 :local-host host :reuse-address t))
85
86 (defimplementation local-port (socket)
87 (socket:local-port socket))
88
89 (defimplementation close-socket (socket)
90 (close socket))
91
92 (defimplementation accept-connection (socket)
93 (socket:accept-connection socket :wait t))
94
95 (defimplementation format-sldb-condition (c)
96 (princ-to-string c))
97
98 (defimplementation condition-references (c)
99 (declare (ignore c))
100 '())
101
102 (defimplementation call-with-syntax-hooks (fn)
103 (funcall fn))
104
105 ;;;; Unix signals
106
107 (defimplementation call-without-interrupts (fn)
108 (excl:without-interrupts (funcall fn)))
109
110 (defimplementation getpid ()
111 (excl::getpid))
112
113 (defimplementation lisp-implementation-type-name ()
114 "allegro")
115
116 (defimplementation set-default-directory (directory)
117 (excl:chdir directory)
118 (namestring (setf *default-pathname-defaults*
119 (truename (merge-pathnames directory)))))
120
121 (defimplementation default-directory ()
122 (excl:chdir))
123
124 ;;;; Misc
125
126 (defimplementation arglist (symbol)
127 (handler-case (excl:arglist symbol)
128 (simple-error () :not-available)))
129
130 (defimplementation macroexpand-all (form)
131 (excl::walk form))
132
133 (defimplementation describe-symbol-for-emacs (symbol)
134 (let ((result '()))
135 (flet ((doc (kind &optional (sym symbol))
136 (or (documentation sym kind) :not-documented))
137 (maybe-push (property value)
138 (when value
139 (setf result (list* property value result)))))
140 (maybe-push
141 :variable (when (boundp symbol)
142 (doc 'variable)))
143 (maybe-push
144 :function (if (fboundp symbol)
145 (doc 'function)))
146 (maybe-push
147 :class (if (find-class symbol nil)
148 (doc 'class)))
149 result)))
150
151 (defimplementation describe-definition (symbol namespace)
152 (ecase namespace
153 (:variable
154 (describe symbol))
155 ((:function :generic-function)
156 (describe (symbol-function symbol)))
157 (:class
158 (describe (find-class symbol)))))
159
160 (defimplementation make-stream-interactive (stream)
161 (setf (interactive-stream-p stream) t))
162
163 ;;;; Debugger
164
165 (defvar *sldb-topframe*)
166
167 (defimplementation call-with-debugging-environment (debugger-loop-fn)
168 (let ((*sldb-topframe* (excl::int-newest-frame))
169 (excl::*break-hook* nil))
170 (funcall debugger-loop-fn)))
171
172 (defun next-frame (frame)
173 (let ((next (excl::int-next-older-frame frame)))
174 (cond ((not next) nil)
175 ((debugger:frame-visible-p next) next)
176 (t (next-frame next)))))
177
178 (defun nth-frame (index)
179 (do ((frame *sldb-topframe* (next-frame frame))
180 (i index (1- i)))
181 ((zerop i) frame)))
182
183 (defimplementation compute-backtrace (start end)
184 (let ((end (or end most-positive-fixnum)))
185 (loop for f = (nth-frame start) then (next-frame f)
186 for i from start below end
187 while f
188 collect f)))
189
190 (defimplementation print-frame (frame stream)
191 (debugger:output-frame stream frame :moderate))
192
193 (defimplementation frame-locals (index)
194 (let ((frame (nth-frame index)))
195 (loop for i from 0 below (debugger:frame-number-vars frame)
196 collect (list :name (debugger:frame-var-name frame i)
197 :id 0
198 :value (debugger:frame-var-value frame i)))))
199
200 (defimplementation frame-var-value (frame var)
201 (let ((frame (nth-frame frame)))
202 (debugger:frame-var-value frame var)))
203
204 (defimplementation frame-catch-tags (index)
205 (declare (ignore index))
206 nil)
207
208 (defimplementation disassemble-frame (index)
209 (disassemble (debugger:frame-function (nth-frame index))))
210
211 (defimplementation frame-source-location-for-emacs (index)
212 (let* ((frame (nth-frame index))
213 (expr (debugger:frame-expression frame))
214 (fspec (first expr)))
215 (second (first (fspec-definition-locations fspec)))))
216
217 (defimplementation eval-in-frame (form frame-number)
218 (debugger:eval-form-in-context
219 form
220 (debugger:environment-of-frame (nth-frame frame-number))))
221
222 (defimplementation return-from-frame (frame-number form)
223 (let ((frame (nth-frame frame-number)))
224 (multiple-value-call #'debugger:frame-return
225 frame (debugger:eval-form-in-context
226 form
227 (debugger:environment-of-frame frame)))))
228
229 ;;; XXX doesn't work for frames with arguments
230 (defimplementation restart-frame (frame-number)
231 (let ((frame (nth-frame frame-number)))
232 (debugger:frame-retry frame (debugger:frame-function frame))))
233
234 ;;;; Compiler hooks
235
236 (defvar *buffer-name* nil)
237 (defvar *buffer-start-position*)
238 (defvar *buffer-string*)
239 (defvar *compile-filename* nil)
240
241 (defun handle-compiler-warning (condition)
242 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
243 (signal (make-condition
244 'compiler-condition
245 :original-condition condition
246 :severity :warning
247 :message (format nil "~A" condition)
248 :location (cond (*buffer-name*
249 (make-location
250 (list :buffer *buffer-name*)
251 (list :position *buffer-start-position*)))
252 (loc
253 (destructuring-bind (file . pos) loc
254 (make-location
255 (list :file (namestring (truename file)))
256 (list :position (1+ pos)))))
257 (*compile-filename*
258 (make-location
259 (list :file *compile-filename*)
260 (list :position 1)))
261 (t
262 (list :error "No error location available.")))))))
263
264 (defimplementation call-with-compilation-hooks (function)
265 (handler-bind ((warning #'handle-compiler-warning))
266 (funcall function)))
267
268 (defimplementation swank-compile-file (*compile-filename* load-p)
269 (with-compilation-hooks ()
270 (let ((*buffer-name* nil))
271 (compile-file *compile-filename* :load-after-compile load-p))))
272
273 (defun call-with-temp-file (fn)
274 (let ((tmpname (system:make-temp-file-name)))
275 (unwind-protect
276 (with-open-file (file tmpname :direction :output :if-exists :error)
277 (funcall fn file tmpname))
278 (delete-file tmpname))))
279
280 (defun compile-from-temp-file (string)
281 (call-with-temp-file
282 (lambda (stream filename)
283 (write-string string stream)
284 (finish-output stream)
285 (let ((binary-filename (compile-file filename :load-after-compile t)))
286 (when binary-filename
287 (delete-file binary-filename))))))
288
289 (defimplementation swank-compile-string (string &key buffer position directory)
290 ;; We store the source buffer in excl::*source-pathname* as a string
291 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
292 ;; the fasl file is corrupted if we use some other datatype.
293 (with-compilation-hooks ()
294 (let ((*buffer-name* buffer)
295 (*buffer-start-position* position)
296 (*buffer-string* string)
297 (*default-pathname-defaults*
298 (if directory (merge-pathnames (pathname directory))
299 *default-pathname-defaults*)))
300 (compile-from-temp-file
301 (format nil "~S ~S~%~A"
302 `(in-package ,(package-name *package*))
303 `(eval-when (:compile-toplevel :load-toplevel)
304 (setq excl::*source-pathname*
305 ',(format nil "~A;~D" buffer position)))
306 string)))))
307
308 ;;;; Definition Finding
309
310 (defun fspec-primary-name (fspec)
311 (etypecase fspec
312 (symbol (string fspec))
313 (list (string (second fspec)))))
314
315 (defun find-fspec-location (fspec type)
316 (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
317 (etypecase file
318 (pathname
319 (let* ((start (scm:find-definition-in-file fspec type file))
320 (pos (if start
321 (list :position (1+ start))
322 (list :function-name (fspec-primary-name fspec)))))
323 (make-location (list :file (namestring (truename file)))
324 pos)))
325 ((member :top-level)
326 (list :error (format nil "Defined at toplevel: ~A"
327 (fspec->string fspec))))
328 (string
329 (let ((pos (position #\; file :from-end t)))
330 (make-location
331 (list :buffer (subseq file 0 pos))
332 (list :position (parse-integer (subseq file (1+ pos)))))))
333 (null
334 (list :error (if err
335 (princ-to-string err)
336 (format nil "Unknown source location for ~A"
337 (fspec->string fspec))))))))
338
339 (defun fspec->string (fspec)
340 (etypecase fspec
341 (symbol (let ((*package* (find-package :keyword)))
342 (prin1-to-string fspec)))
343 (list (format nil "(~A ~A)"
344 (prin1-to-string (first fspec))
345 (let ((*package* (find-package :keyword)))
346 (prin1-to-string (second fspec)))))))
347
348 (defun fspec-definition-locations (fspec)
349 (let ((defs (excl::find-multiple-definitions fspec)))
350 (loop for (fspec type) in defs
351 collect (list (list type fspec)
352 (find-fspec-location fspec type)))))
353
354 (defimplementation find-definitions (symbol)
355 (fspec-definition-locations symbol))
356
357 ;;;; XREF
358
359 (defmacro defxref (name relation name1 name2)
360 `(defimplementation ,name (x)
361 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
362
363 (defxref who-calls :calls :wild x)
364 (defxref who-references :uses :wild x)
365 (defxref who-binds :binds :wild x)
366 (defxref who-macroexpands :macro-calls :wild x)
367 (defxref who-sets :sets :wild x)
368 (defxref list-callees :calls x :wild)
369
370 (defun xref-result (fspecs)
371 (loop for fspec in fspecs
372 append (fspec-definition-locations fspec)))
373
374 ;; list-callers implemented by groveling through all fbound symbols.
375 ;; Only symbols are considered. Functions in the constant pool are
376 ;; searched recursevly. Closure environments are ignored at the
377 ;; moment (constants in methods are therefore not found).
378
379 (defun map-function-constants (function fn depth)
380 "Call FN with the elements of FUNCTION's constant pool."
381 (do ((i 0 (1+ i))
382 (max (excl::function-constant-count function)))
383 ((= i max))
384 (let ((c (excl::function-constant function i)))
385 (cond ((and (functionp c)
386 (not (eq c function))
387 (plusp depth))
388 (map-function-constants c fn (1- depth)))
389 (t
390 (funcall fn c))))))
391
392 (defun in-constants-p (fn symbol)
393 (map-function-constants
394 fn
395 (lambda (c) (if (eq c symbol) (return-from in-constants-p t)))
396 3))
397
398 (defun function-callers (name)
399 (let ((callers '()))
400 (do-all-symbols (sym)
401 (when (fboundp sym)
402 (let ((fn (fdefinition sym)))
403 (when (in-constants-p fn name)
404 (push sym callers)))))
405 callers))
406
407 (defimplementation list-callers (name)
408 (xref-result (function-callers name)))
409
410 ;;;; Inspecting
411
412 (defclass acl-inspector (inspector)
413 ())
414
415 (defimplementation make-default-inspector ()
416 (make-instance 'acl-inspector))
417
418 (defimplementation inspect-for-emacs ((o t) (inspector acl-inspector))
419 (declare (ignore inspector))
420 (values "A value."
421 `("Type: " (:value ,(class-of o))
422 (:newline)
423 "Slots:" (:newline)
424 ,@(loop
425 for slot in (clos:class-slots class)
426 for name = (clos:slot-definition-name slot)
427 collect `(:value ,name)
428 collect " = "
429 collect (if (slot-boundp o name)
430 `(:value ,(slot-value o name))
431 "#<unbound>")))))
432
433 ;; duplicated from swank.lisp in order to avoid package dependencies
434 (defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v))))
435 (butlast
436 (loop
437 for i in list
438 collect (funcall callback i)
439 collect ", ")))
440
441 (defmethod inspect-for-emacs ((f function) (inspector acl-inspector))
442 (declare (ignore inspector))
443 (values "A function."
444 `("Name: " (:value ,(function-name f)) (:newline)
445 "It's argument list is: " ,(princ-to-string (arglist f)) (:newline)
446 "Documentation:" (:newline)
447 ;; AllegroCL doesn't support (documentation <function-obj> t)
448 ;; so we get the symbol and then its doc
449 ,(documentation (excl::external-fn_symdef obj) 'function))))
450
451 (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector))
452 (declare (ignore inspector))
453 (values "A structure class."
454 `("Name: " (:value ,(class-name class))
455 (:newline)
456 "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
457 (:newline)
458 "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class)
459 (lambda (slot)
460 `(:value ,slot ,(princ-to-string
461 (swank-mop:slot-definition-name slot)))))
462 (:newline)
463 "Effective Slots: " ,@(if (swank-mop:class-finalized-p class)
464 (common-seperated-spec (swank-mop:class-slots class)
465 (lambda (slot)
466 `(:value ,slot ,(princ-to-string
467 (swank-mop:slot-definition-name slot)))))
468 '("N/A (class not finalized)"))
469 (:newline)
470 "Documentation:" (:newline)
471 ,@(when (documentation class t)
472 `(,(documentation class t) (:newline)))
473 "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
474 (lambda (sub)
475 `(:value ,sub ,(princ-to-string (class-name sub)))))
476 (:newline)
477 "Precedence List: " ,@(if (swank-mop:class-finalized-p class)
478 (common-seperated-spec (swank-mop:class-precedence-list class)
479 (lambda (class)
480 `(:value ,class ,(princ-to-string (class-name class)))))
481 '("N/A (class not finalized)"))
482 (:newline)
483 "Prototype: " ,(if (swank-mop:class-finalized-p class)
484 `(:value ,(swank-mop:class-prototype class))
485 '"N/A (class not finalized)"))))
486
487 (defmethod inspect-for-emacs ((slot excl::structure-slot-definition) (inspector acl-inspector))
488 (declare (ignore inspector))
489 (values "A structure slot."
490 `("Name: " (:value ,(mop:slot-definition-name slot))
491 (:newline)
492 "Documentation:" (:newline)
493 ,@(when (documentation slot)
494 `((:value ,(documentation slot)) (:newline)))
495 "Initform: " ,(if (swank-mop:slot-definition-initform slot)
496 `(:value ,(swank-mop:slot-definition-initform slot))
497 "#<unspecified>") (:newline)
498 "Type: " ,(if (swank-mop:slot-definition-type slot)
499 `(:value ,(swank-mop:slot-definition-type slot))
500 "#<unspecified>") (:newline)
501 "Allocation: " (:value ,(excl::slotd-allocation slot)) (:newline)
502 "Read-only: " (:value ,(excl::slotd-read-only slot)) (:newline))))
503
504 (defmethod inspect-for-emacs ((o structure-object) (inspector acl-inspector))
505 (declare (ignore inspector))
506 (values "An structure object."
507 `("Structure class: " (:value ,(class-of o))
508 (:newline)
509 "Slots:" (:newline)
510 ,@(loop
511 with direct-slots = (swank-mop:class-direct-slots (class-of o))
512 for slot in (swank-mop:class-slots (class-of o))
513 for slot-def = (or (find-if (lambda (a)
514 ;; find the direct slot with the same as
515 ;; SLOT (an effective slot).
516 (eql (swank-mop:slot-definition-name a)
517 (swank-mop:slot-definition-name slot)))
518 direct-slots)
519 slot)
520 collect `(:value ,slot-def ,(princ-to-string (swank-mop:slot-definition-name slot-def)))
521 collect " = "
522 if (slot-boundp o (swank-mop:slot-definition-name slot-def))
523 collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
524 else
525 collect "#<unbound>"
526 collect '(:newline)))))
527
528 ;;;; Multithreading
529
530 (defimplementation startup-multiprocessing ()
531 (mp:start-scheduler))
532
533 (defimplementation spawn (fn &key name)
534 (mp:process-run-function name fn))
535
536 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
537 (defvar *thread-id-counter* 0)
538
539 (defimplementation thread-id (thread)
540 (mp:with-process-lock (*id-lock*)
541 (or (getf (mp:process-property-list thread) 'id)
542 (setf (getf (mp:process-property-list thread) 'id)
543 (incf *thread-id-counter*)))))
544
545 (defimplementation find-thread (id)
546 (find id mp:*all-processes*
547 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
548
549 (defimplementation thread-name (thread)
550 (mp:process-name thread))
551
552 (defimplementation thread-status (thread)
553 (format nil "~A ~D" (mp:process-whostate thread)
554 (mp:process-priority thread)))
555
556 (defimplementation make-lock (&key name)
557 (mp:make-process-lock :name name))
558
559 (defimplementation call-with-lock-held (lock function)
560 (mp:with-process-lock (lock) (funcall function)))
561
562 (defimplementation current-thread ()
563 mp:*current-process*)
564
565 (defimplementation all-threads ()
566 (copy-list mp:*all-processes*))
567
568 (defimplementation interrupt-thread (thread fn)
569 (mp:process-interrupt thread fn))
570
571 (defimplementation kill-thread (thread)
572 (mp:process-kill thread))
573
574 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
575
576 (defstruct (mailbox (:conc-name mailbox.))
577 (mutex (mp:make-process-lock :name "process mailbox"))
578 (queue '() :type list))
579
580 (defun mailbox (thread)
581 "Return THREAD's mailbox."
582 (mp:with-process-lock (*mailbox-lock*)
583 (or (getf (mp:process-property-list thread) 'mailbox)
584 (setf (getf (mp:process-property-list thread) 'mailbox)
585 (make-mailbox)))))
586
587 (defimplementation send (thread message)
588 (let* ((mbox (mailbox thread))
589 (mutex (mailbox.mutex mbox)))
590 (mp:process-wait-with-timeout
591 "yielding before sending" 0.1
592 (lambda ()
593 (mp:with-process-lock (mutex)
594 (< (length (mailbox.queue mbox)) 10))))
595 (mp:with-process-lock (mutex)
596 (setf (mailbox.queue mbox)
597 (nconc (mailbox.queue mbox) (list message))))))
598
599 (defimplementation receive ()
600 (let* ((mbox (mailbox mp:*current-process*))
601 (mutex (mailbox.mutex mbox)))
602 (mp:process-wait "receive" #'mailbox.queue mbox)
603 (mp:with-process-lock (mutex)
604 (pop (mailbox.queue mbox)))))
605
606 (defimplementation quit-lisp ()
607 (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5