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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (show annotations)
Fri Apr 1 19:44:27 2005 UTC (9 years ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-2, SLIME-1-2-1
Changes since 1.72: +28 -109 lines
(eval-in-frame): Allegro's eval-form-in-context does nothing special
with lexical variables in the frame.  Wrap an explicit LET around the
form to get the similar behavior as in the other Lisps.

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

  ViewVC Help
Powered by ViewVC 1.1.5