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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5