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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (show annotations)
Fri Nov 19 01:18:19 2004 UTC (9 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.61: +69 -32 lines
(swank-mop:slot-definition-documentation): ACL 7 says documentation
should have 2 args. So, pass t as second argument.

(fspec-primary-name): Recurse until we have a symbol.

(count-cr): Convert file-offsets to match Emacs' eol-convetions.

(find-definition-in-file): Use it.

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

  ViewVC Help
Powered by ViewVC 1.1.5