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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5