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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.125 - (hide annotations)
Mon Mar 21 00:38:43 2005 UTC (9 years ago) by lgorrie
Branch: MAIN
Changes since 1.124: +2 -1 lines
(function-source-location): For definitions compiled in Emacs buffers,
include the :emacs-string as a :snippet hint for search-based M-.
lookup.
1 heller 1.60 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 dbarlow 1.1 ;;;
3     ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4     ;;;
5     ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties are
8     ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14     (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require 'sb-bsd-sockets)
16 heller 1.59 (require 'sb-introspect)
17 heller 1.60 (require 'sb-posix)
18 heller 1.59 )
19 dbarlow 1.1
20 heller 1.107
21 heller 1.74 (in-package :swank-backend)
22 heller 1.107 (declaim (optimize (debug 2)))
23 dbarlow 1.1
24 heller 1.23 (import
25     '(sb-gray:fundamental-character-output-stream
26     sb-gray:stream-write-char
27     sb-gray:stream-line-length
28     sb-gray:stream-force-output
29     sb-gray:fundamental-character-input-stream
30     sb-gray:stream-read-char
31     sb-gray:stream-listen
32     sb-gray:stream-unread-char
33     sb-gray:stream-clear-input
34     sb-gray:stream-line-column
35     sb-gray:stream-line-length))
36    
37 mbaringer 1.100 ;;; swank-mop
38    
39 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
40 mbaringer 1.100
41 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
42     (sb-pcl::documentation slot t))
43 mbaringer 1.100
44 dbarlow 1.1 ;;; TCP Server
45    
46 heller 1.74 (defimplementation preferred-communication-style ()
47 lgorrie 1.94 (if (and (sb-int:featurep :sb-thread)
48     (sb-int:featurep :sb-futex))
49     :spawn
50     :fd-handler))
51 heller 1.82
52 heller 1.65 (defun resolve-hostname (name)
53     (car (sb-bsd-sockets:host-ent-addresses
54     (sb-bsd-sockets:get-host-by-name name))))
55    
56     (defimplementation create-socket (host port)
57 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
58     :type :stream
59     :protocol :tcp)))
60 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
61 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
62 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
63 heller 1.29 socket))
64    
65 lgorrie 1.54 (defimplementation local-port (socket)
66 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
67    
68 lgorrie 1.54 (defimplementation close-socket (socket)
69 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
70 heller 1.48 (sb-bsd-sockets:socket-close socket))
71    
72 heller 1.115 (defimplementation accept-connection (socket
73     &key (external-format :iso-latin-1-unix))
74 heller 1.110 (make-socket-io-stream (accept socket) external-format))
75 heller 1.48
76 heller 1.59 (defvar *sigio-handlers* '()
77     "List of (key . fn) pairs to be called on SIGIO.")
78    
79     (defun sigio-handler (signal code scp)
80 heller 1.60 (declare (ignore signal code scp))
81     (mapc (lambda (handler)
82     (funcall (the function (cdr handler))))
83     *sigio-handlers*))
84 heller 1.59
85     (defun set-sigio-handler ()
86 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
87 heller 1.59 (sigio-handler signal code scp))))
88    
89 heller 1.62 (defun enable-sigio-on-fd (fd)
90 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
91     (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
92 heller 1.62
93 heller 1.67 (defimplementation add-sigio-handler (socket fn)
94 heller 1.62 (set-sigio-handler)
95     (let ((fd (socket-fd socket)))
96     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
97     (enable-sigio-on-fd fd)
98     (push (cons fd fn) *sigio-handlers*)))
99    
100 heller 1.67 (defimplementation remove-sigio-handlers (socket)
101 heller 1.59 (let ((fd (socket-fd socket)))
102     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
103     (sb-sys:invalidate-descriptor fd))
104 heller 1.51 (close socket))
105 heller 1.67
106     (defimplementation add-fd-handler (socket fn)
107     (declare (type function fn))
108     (let ((fd (socket-fd socket)))
109     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
110     (sb-sys:add-fd-handler fd :input (lambda (_)
111     _
112     (funcall fn)))))
113    
114     (defimplementation remove-fd-handlers (socket)
115     (sb-sys:invalidate-descriptor (socket-fd socket)))
116 heller 1.51
117 heller 1.48 (defun socket-fd (socket)
118     (etypecase socket
119     (fixnum socket)
120     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
121     (file-stream (sb-sys:fd-stream-fd socket))))
122    
123 heller 1.110 (defun make-socket-io-stream (socket external-format)
124     (let ((encoding (ecase external-format
125     (:iso-latin-1-unix :iso-8859-1)
126 heller 1.112 #+sb-unicode
127 heller 1.110 (:utf-8-unix :utf-8))))
128     (sb-bsd-sockets:socket-make-stream socket
129     :output t
130     :input t
131     :element-type 'character
132 heller 1.112 #+sb-unicode :external-format
133     #+sb-unicode encoding
134     )))
135 lgorrie 1.46
136 heller 1.29 (defun accept (socket)
137     "Like socket-accept, but retry on EAGAIN."
138     (loop (handler-case
139     (return (sb-bsd-sockets:socket-accept socket))
140     (sb-bsd-sockets:interrupted-error ()))))
141 dbarlow 1.6
142 heller 1.52 (defmethod call-without-interrupts (fn)
143 heller 1.58 (declare (type function fn))
144 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
145    
146 heller 1.81 (defimplementation getpid ()
147 lgorrie 1.80 (sb-posix:getpid))
148 heller 1.52
149 heller 1.68 (defimplementation lisp-implementation-type-name ()
150     "sbcl")
151    
152 heller 1.85 (defimplementation quit-lisp ()
153     (sb-ext:quit))
154    
155 heller 1.124
156     ;;;; Support for SBCL syntax
157    
158     (defun feature-in-list-p (feature list)
159     (etypecase feature
160     (symbol (member feature list :test #'eq))
161     (cons (flet ((subfeature-in-list-p (subfeature)
162     (feature-in-list-p subfeature list)))
163     (ecase (first feature)
164     (:or (some #'subfeature-in-list-p (rest feature)))
165     (:and (every #'subfeature-in-list-p (rest feature)))
166     (:not (destructuring-bind (e) (cdr feature)
167     (not (subfeature-in-list-p e)))))))))
168    
169     (defun shebang-reader (stream sub-character infix-parameter)
170     (declare (ignore sub-character))
171     (when infix-parameter
172     (error "illegal read syntax: #~D!" infix-parameter))
173     (let ((next-char (read-char stream)))
174     (unless (find next-char "+-")
175     (error "illegal read syntax: #!~C" next-char))
176     ;; When test is not satisfied
177     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
178     ;; would become "unless test is satisfied"..
179     (when (let* ((*package* (find-package "KEYWORD"))
180     (*read-suppress* nil)
181     (not-p (char= next-char #\-))
182     (feature (read stream)))
183     (if (feature-in-list-p feature *features*)
184     not-p
185     (not not-p)))
186     ;; Read (and discard) a form from input.
187     (let ((*read-suppress* t))
188     (read stream t nil t))))
189     (values))
190    
191     (defvar *shebang-readtable*
192     (let ((*readtable* (copy-readtable nil)))
193     (set-dispatch-macro-character #\# #\!
194     (lambda (s c n) (shebang-reader s c n))
195     *readtable*)
196     *readtable*))
197    
198     (defun shebang-readtable ()
199     *shebang-readtable*)
200    
201     (defun sbcl-package-p (package)
202     (let ((name (package-name package)))
203     (eql (mismatch "SB-" name) 3)))
204    
205     (defvar *debootstrap-packages* t)
206    
207     (defmacro with-debootstrapping (&body body)
208     (let ((not-found (find-symbol "BOOTSTRAP-PACKAGE-NOT-FOUND" "SB-INT"))
209     (debootstrap (find-symbol "DEBOOTSTRAP-PACKAGE" "SB-INT")))
210     (if (and not-found debootstrap)
211     `(handler-bind ((,not-found #',debootstrap)) ,@body)
212     `(progn ,@body))))
213    
214     (defimplementation call-with-syntax-hooks (fn)
215     (cond ((and *debootstrap-packages*
216     (sbcl-package-p *package*))
217     (with-debootstrapping (funcall fn)))
218     (t
219     (funcall fn))))
220    
221     (defimplementation default-readtable-alist ()
222     (let ((readtable (shebang-readtable)))
223     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
224     collect (cons (package-name p) readtable))))
225    
226 dbarlow 1.1 ;;; Utilities
227    
228 mbaringer 1.100 (defimplementation arglist ((fname t))
229 heller 1.74 (sb-introspect:function-arglist fname))
230 mbaringer 1.100
231     (defimplementation function-name ((f function))
232     (sb-impl::%fun-name f))
233 dbarlow 1.1
234 dbarlow 1.42 (defvar *buffer-name* nil)
235 dbarlow 1.1 (defvar *buffer-offset*)
236 heller 1.70 (defvar *buffer-substring* nil)
237 dbarlow 1.1
238 lgorrie 1.24 (defvar *previous-compiler-condition* nil
239     "Used to detect duplicates.")
240    
241 dbarlow 1.1 (defun handle-notification-condition (condition)
242     "Handle a condition caused by a compiler warning.
243     This traps all compiler conditions at a lower-level than using
244     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
245     craft our own error messages, which can omit a lot of redundant
246     information."
247     (let ((context (sb-c::find-error-context nil)))
248 heller 1.36 (unless (eq condition *previous-compiler-condition*)
249 dbarlow 1.1 (setq *previous-compiler-condition* condition)
250 lgorrie 1.24 (signal-compiler-condition condition context))))
251    
252     (defun signal-compiler-condition (condition context)
253     (signal (make-condition
254     'compiler-condition
255     :original-condition condition
256     :severity (etypecase condition
257     (sb-c:compiler-error :error)
258     (sb-ext:compiler-note :note)
259     (style-warning :style-warning)
260 lgorrie 1.96 (warning :warning)
261     (error :error))
262 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
263 heller 1.107 :references (condition-references (real-condition condition))
264 heller 1.66 :message (long-compiler-message-for-emacs condition context)
265 lgorrie 1.24 :location (compiler-note-location context))))
266 heller 1.107
267     (defun real-condition (condition)
268     "Return the encapsulated condition or CONDITION itself."
269     (typecase condition
270     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
271     (t condition)))
272 lgorrie 1.24
273     (defun compiler-note-location (context)
274 heller 1.124 (if context
275     (with-struct (sb-c::compiler-error-context- file-name) context
276     (locate-compiler-note file-name (compiler-source-path context)))
277     (list :error "No error location available")))
278    
279     (defun locate-compiler-note (file source-path)
280     (cond ((and (pathnamep file) *buffer-name*)
281     ;; Compiling from a buffer
282     (let ((position (+ *buffer-offset*
283     (source-path-string-position
284     source-path *buffer-substring*))))
285     (make-location (list :buffer *buffer-name*)
286     (list :position position))))
287     ((and (pathnamep file) (null *buffer-name*))
288     ;; Compiling from a file
289     (make-location (list :file (namestring file))
290     (list :position
291     (1+ (source-path-file-position
292     source-path file)))))
293 dbarlow 1.42 (t
294 heller 1.124 (error "unhandled case"))))
295 dbarlow 1.42
296 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
297 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
298     When Emacs presents the message it already has the source popped up
299     and the source form highlighted. This makes much of the information in
300     the error-context redundant."
301 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
302     (princ-to-string condition)))
303 heller 1.66
304     (defun long-compiler-message-for-emacs (condition error-context)
305     "Describe a compiler error for Emacs including context information."
306 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
307 heller 1.66 (multiple-value-bind (enclosing source)
308     (if error-context
309     (values (sb-c::compiler-error-context-enclosing-source error-context)
310     (sb-c::compiler-error-context-source error-context)))
311 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
312     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
313     enclosing source condition))))
314 dbarlow 1.1
315 heller 1.124 (defun compiler-source-path (context)
316 dbarlow 1.1 "Return the source-path for the current compiler error.
317     Returns NIL if this cannot be determined by examining internal
318     compiler state."
319     (cond ((sb-c::node-p context)
320     (reverse
321     (sb-c::source-path-original-source
322     (sb-c::node-source-path context))))
323     ((sb-c::compiler-error-context-p context)
324     (reverse
325     (sb-c::compiler-error-context-original-source-path context)))))
326    
327 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
328 heller 1.58 (declare (type function function))
329 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
330     (sb-c:compiler-error #'handle-notification-condition)
331 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
332     (style-warning #'handle-notification-condition)
333     (warning #'handle-notification-condition))
334     (funcall function)))
335 lgorrie 1.24
336 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
337     "Handle a condition that caused the file compiler to terminate."
338     (handle-notification-condition
339     (sb-int:encapsulated-condition condition)))
340    
341 heller 1.91 (defvar *trap-load-time-warnings* nil)
342    
343 heller 1.74 (defimplementation swank-compile-file (filename load-p)
344 lgorrie 1.96 (handler-case
345     (let ((output-file (with-compilation-hooks ()
346     (compile-file filename))))
347 lgorrie 1.122 (when output-file
348     ;; Cache the latest source file for definition-finding.
349     (source-cache-get filename (file-write-date filename))
350     (when load-p
351     (load output-file))))
352 lgorrie 1.96 (sb-c:fatal-compiler-error () nil)))
353 lgorrie 1.24
354 heller 1.124 ;;;; compile-string
355    
356     ;;; We patch sb-c::debug-source-for-info so that we can dump our own
357     ;;; bits of source info. Our *user-source-info* is stored in the
358     ;;; debug-source-info slot.
359    
360     (defvar *real-debug-source-for-info*)
361     (defvar *user-source-info*)
362    
363     (defun debug-source-for-info-advice (info)
364     (destructuring-bind (source) (funcall *real-debug-source-for-info* info)
365     (when (boundp '*user-source-info*)
366     (setf (sb-c::debug-source-info source) *user-source-info*))
367     (list source)))
368    
369     (defun install-debug-source-patch ()
370     (unless (boundp '*real-debug-source-for-info*)
371     (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info))
372     (sb-ext:without-package-locks
373     (setf (symbol-function 'sb-c::debug-source-for-info)
374     #'debug-source-for-info-advice)))
375    
376 pseibel 1.98 (defimplementation swank-compile-string (string &key buffer position directory)
377     (declare (ignore directory))
378 heller 1.124 (install-debug-source-patch)
379     (call/temp-file
380     string
381     (lambda (filename)
382     (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string
383     :emacs-position position))
384     (*buffer-name* buffer)
385     (*buffer-offset* position)
386     (*buffer-substring* string))
387     (let ((fasl (with-compilation-hooks ()
388     (compile-file filename))))
389     (load fasl)
390     (delete-file fasl))))))
391    
392     (defun call/temp-file (string fun)
393     (let ((filename (temp-file-name)))
394     (unwind-protect
395     (with-open-file (s filename :direction :output :if-exists :error)
396     (write-string string s)
397     (finish-output s)
398     (funcall fun filename))
399     (when (probe-file filename)
400     (delete-file filename)))))
401    
402     (defun temp-file-name ()
403     "Return a temporary file name to compile strings into."
404     (sb-alien:alien-funcall
405     (sb-alien:extern-alien
406     "tmpnam"
407     (function sb-alien:c-string sb-alien:system-area-pointer))
408     (sb-sys:int-sap 0)))
409 dbarlow 1.1
410     ;;;; Definitions
411    
412     (defvar *debug-definition-finding* nil
413     "When true don't handle errors while looking for definitions.
414     This is useful when debugging the definition-finding code.")
415    
416 lgorrie 1.122 (defimplementation find-definitions (name)
417     (append (function-definitions name)
418     (compiler-definitions name)))
419    
420     ;;;;; Function definitions
421    
422     (defun function-definitions (name)
423     (flet ((loc (fn name) (safe-function-source-location fn name)))
424     (append
425     (cond ((and (symbolp name) (macro-function name))
426     (list (list `(defmacro ,name)
427     (loc (macro-function name) name))))
428     ((fboundp name)
429     (let ((fn (fdefinition name)))
430     (typecase fn
431     (generic-function
432     (cons (list `(defgeneric ,name) (loc fn name))
433     (method-definitions fn)))
434     (t
435     (list (list `(function ,name) (loc fn name))))))))
436     (when (compiler-macro-function name)
437     (list (list `(define-compiler-macro ,name)
438     (loc (compiler-macro-function name) name)))))))
439    
440     (defun safe-function-source-location (fun name)
441     (if *debug-definition-finding*
442     (function-source-location fun name)
443     (handler-case (function-source-location fun name)
444     (error (e)
445     (list (list :error (format nil "Error: ~A" e)))))))
446    
447 dbarlow 1.1 ;;; FIXME we don't handle the compiled-interactively case yet. That
448     ;;; should have NIL :filename & :position, and non-NIL :source-form
449 heller 1.36 (defun function-source-location (function &optional name)
450 dbarlow 1.1 "Try to find the canonical source location of FUNCTION."
451     (let* ((def (sb-introspect:find-definition-source function))
452 heller 1.124 (stamp (definition-source-file-write-date def)))
453     (with-struct (sb-introspect::definition-source-
454     pathname form-path character-offset) def
455     (cond ((function-from-emacs-buffer-p function)
456     (let ((info (function-debug-source-info function)))
457     (destructuring-bind (&key emacs-buffer emacs-position
458     emacs-string) info
459     (let ((pos (if form-path
460     (with-debootstrapping
461     (source-path-string-position
462     form-path emacs-string))
463     character-offset)))
464     (make-location `(:buffer ,(getf info :emacs-buffer))
465 lgorrie 1.125 `(:position ,(+ pos emacs-position))
466     `(:snippet ,(getf info :emacs-string)))))))
467 heller 1.124 (t
468     (let* ((filename (namestring (truename pathname)))
469     (pos (if form-path
470     (with-debootstrapping
471     (source-path-file-position form-path filename) )
472     character-offset)))
473     (make-location
474     `(:file ,filename)
475     (if pos
476     `(:position ,pos)
477     `(:function-name
478     ,(or (and name (string name))
479     (string (sb-kernel:%fun-name function)))))
480     (let ((source (get-source-code pathname stamp)))
481     (if source
482     (with-input-from-string (stream source)
483     (file-position stream pos)
484     (list :snippet (read-snippet stream))))))))))))
485    
486     ;; FIXME: Symbol doesn't exist in released SBCL yet.
487     (defun definition-source-file-write-date (def)
488     (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"
489     (find-package "SB-INTROSPECT"))))
490     (when sym (funcall sym def))))
491 heller 1.74
492     (defun method-definitions (gf)
493     (let ((methods (sb-mop:generic-function-methods gf))
494     (name (sb-mop:generic-function-name gf)))
495     (loop for method in methods
496 heller 1.75 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
497 heller 1.74 (safe-function-source-location method name)))))
498    
499 lgorrie 1.122 ;;;;; Compiler definitions
500    
501     (defun compiler-definitions (name)
502     (let ((fun-info (sb-int:info :function :info name)))
503     (when fun-info
504     (append (transform-definitions fun-info name)
505     (optimizer-definitions fun-info name)))))
506 heller 1.105
507     (defun transform-definitions (fun-info name)
508     (loop for xform in (sb-c::fun-info-transforms fun-info)
509     for loc = (safe-function-source-location
510     (sb-c::transform-function xform) name)
511     for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
512     for note = (sb-c::transform-note xform)
513     for spec = (if (consp typespec)
514     `(sb-c:deftransform ,(second typespec) ,note)
515     `(sb-c:deftransform ,note))
516     collect `(,spec ,loc)))
517    
518     (defun optimizer-definitions (fun-info fun-name)
519     (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
520     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
521     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
522     (sb-c::fun-info-optimizer . sb-c:optimizer))))
523     (loop for (reader . name) in otypes
524     for fn = (funcall reader fun-info)
525     when fn collect `((sb-c:defoptimizer ,name)
526     ,(safe-function-source-location fn fun-name)))))
527    
528 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
529 dbarlow 1.1 "Return a plist describing SYMBOL.
530     Return NIL if the symbol is unbound."
531     (let ((result '()))
532 lgorrie 1.24 (labels ((doc (kind)
533     (or (documentation symbol kind) :not-documented))
534 dbarlow 1.1 (maybe-push (property value)
535     (when value
536     (setf result (list* property value result)))))
537     (maybe-push
538     :variable (multiple-value-bind (kind recorded-p)
539     (sb-int:info :variable :kind symbol)
540     (declare (ignore kind))
541     (if (or (boundp symbol) recorded-p)
542     (doc 'variable))))
543     (maybe-push
544     :function (if (fboundp symbol)
545     (doc 'function)))
546     (maybe-push
547     :setf (if (or (sb-int:info :setf :inverse symbol)
548     (sb-int:info :setf :expander symbol))
549     (doc 'setf)))
550     (maybe-push
551     :type (if (sb-int:info :type :kind symbol)
552     (doc 'type)))
553 lgorrie 1.24 result)))
554 dbarlow 1.1
555 heller 1.74 (defimplementation describe-definition (symbol type)
556 lgorrie 1.54 (case type
557     (:variable
558 heller 1.74 (describe symbol))
559     (:function
560     (describe (symbol-function symbol)))
561 lgorrie 1.54 (:setf
562 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
563     (sb-int:info :setf :expander symbol))))
564 lgorrie 1.54 (:class
565 heller 1.74 (describe (find-class symbol)))
566 lgorrie 1.54 (:type
567 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
568 dbarlow 1.1
569 heller 1.97 (defimplementation list-callers (symbol)
570     (let ((fn (fdefinition symbol)))
571     (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
572    
573     (defimplementation list-callees (symbol)
574     (let ((fn (fdefinition symbol)))
575     (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
576    
577 lgorrie 1.122 (defun function-dspec (fn)
578     "Describe where the function FN was defined.
579     Return a list of the form (NAME LOCATION)."
580     (let ((name (sb-kernel:%fun-name fn)))
581     (list name (safe-function-source-location fn name))))
582    
583 dbarlow 1.4 ;;; macroexpansion
584 dbarlow 1.1
585 lgorrie 1.54 (defimplementation macroexpand-all (form)
586 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
587     (sb-walker:walk-form form)))
588 lgorrie 1.25
589 dbarlow 1.1
590     ;;; Debugging
591    
592     (defvar *sldb-stack-top*)
593    
594 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
595 heller 1.58 (declare (type function debugger-loop-fn))
596 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
597 heller 1.71 (sb-debug:*stack-top-hint* nil))
598 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
599     (lambda (condition)
600 lgorrie 1.25 (signal (make-condition
601     'sldb-condition
602     :original-condition condition)))))
603     (funcall debugger-loop-fn))))
604 dbarlow 1.1
605 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
606     (let ((sb-ext:*invoke-debugger-hook* hook))
607     (funcall fun)))
608    
609 dbarlow 1.1 (defun nth-frame (index)
610     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
611     (i index (1- i)))
612     ((zerop i) frame)))
613    
614 heller 1.74 (defimplementation compute-backtrace (start end)
615 dbarlow 1.1 "Return a list of frames starting with frame number START and
616     continuing to frame number END or, if END is nil, the last frame on the
617     stack."
618     (let ((end (or end most-positive-fixnum)))
619 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
620     for i from start below end
621     while f
622 heller 1.74 collect f)))
623 dbarlow 1.1
624 heller 1.74 (defimplementation print-frame (frame stream)
625 lgorrie 1.121 (macrolet ((printer-form ()
626     ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
627     ;; our usage of unexported interfaces came back to haunt
628     ;; us. And since we still use the same interfaces it will
629     ;; haunt us again.
630     (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
631     (if (fboundp print-sym)
632     (let* ((args (sb-introspect:function-arglist print-sym))
633     (key-pos (position '&key args)))
634     (cond ((eql 2 key-pos)
635     `(,print-sym frame stream))
636     ((eql 1 key-pos)
637     `(let ((*standard-output* stream))
638     (,print-sym frame)))
639     (t
640     (error "*THWAP* SBCL changes internals ~
641     again!"))))
642     (error "You're in a twisty little maze of unsupported
643     SBCL interfaces, all different.")))))
644     (printer-form)))
645 dbarlow 1.1
646 heller 1.124 ;;;; Code-location -> source-location translation
647    
648     (defun code-location-source-location (code-location)
649     (let ((dsource (sb-di:code-location-debug-source code-location)))
650     (ecase (sb-di:debug-source-from dsource)
651     (:file (file-source-location code-location))
652     (:lisp (lisp-source-location code-location)))))
653    
654     (defun file-source-location (code-location)
655     (cond ((code-location-has-debug-block-info-p code-location)
656     (if (code-location-from-emacs-buffer-p code-location)
657     (temp-file-source-location code-location)
658     (source-file-source-location code-location)))
659     (t
660     (let ((fun (code-location-debug-fun-fun code-location)))
661     (cond (fun (function-source-location fun))
662     (t (error "Cannot find source location for: ~A "
663     code-location)))))))
664    
665     (defun lisp-source-location (code-location)
666     (let ((source (with-output-to-string (*standard-output*)
667     (print-code-location-source-form code-location 100))))
668     (make-location `(:source-form ,source) '(:position 0))))
669    
670     (defun temp-file-source-location (code-location)
671     (let ((info (code-location-debug-source-info code-location)))
672     (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
673     (let* ((pos (string-source-position code-location emacs-string))
674     (snipped (with-input-from-string (s emacs-string)
675     (file-position s pos)
676     (read-snippet s))))
677     (make-location `(:buffer ,emacs-buffer)
678     `(:position ,(+ emacs-position pos))
679     `(:snippet ,snipped))))))
680    
681     (defun source-file-source-location (code-location)
682     (let* ((code-date (code-location-debug-source-created code-location))
683     (filename (code-location-debug-source-name code-location))
684     (source-code (get-source-code filename code-date))
685     (cloc code-location))
686     (with-input-from-string (s source-code)
687     (make-location `(:file ,filename)
688     `(:position ,(1+ (stream-source-position cloc s)))
689     `(:snippet ,(read-snippet s))))))
690    
691     (defun string-source-position (code-location string)
692     (with-input-from-string (s string)
693     (stream-source-position code-location s)))
694    
695     (defun code-location-debug-source-info (code-location)
696     (sb-c::debug-source-info (sb-di::code-location-debug-source code-location)))
697    
698     (defun code-location-debug-source-name (code-location)
699     (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
700    
701     (defun code-location-debug-source-created (code-location)
702     (sb-c::debug-source-created
703     (sb-di::code-location-debug-source code-location)))
704    
705     (defun code-location-debug-fun-fun (code-location)
706     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
707    
708     (defun code-location-from-emacs-buffer-p (code-location)
709     (info-from-emacs-buffer-p (code-location-debug-source-info code-location)))
710    
711     (defun function-from-emacs-buffer-p (function)
712     (info-from-emacs-buffer-p (function-debug-source-info function)))
713    
714     (defun function-debug-source-info (function)
715     (let* ((comp (sb-di::compiled-debug-fun-component
716     (sb-di::fun-debug-fun function))))
717     (sb-c::debug-source-info (car (sb-c::debug-info-source
718     (sb-kernel:%code-debug-info comp))))))
719    
720     (defun info-from-emacs-buffer-p (info)
721     (and info
722     (consp info)
723     (eq :emacs-buffer (car info))))
724    
725     (defun code-location-has-debug-block-info-p (code-location)
726     (handler-case
727     (progn (sb-di:code-location-debug-block code-location)
728     t)
729     (sb-di:no-debug-blocks () nil)))
730    
731     (defun stream-source-position (code-location stream)
732     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
733     (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
734     (form-number (sb-di::code-location-form-number cloc)))
735     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
736     (let* ((path-table (sb-di::form-number-translations tlf 0))
737     (source-path (if (<= (length path-table) form-number)
738     (list 0) ; file is out of sync
739     (reverse (cdr (aref path-table form-number))))))
740     (source-path-source-position source-path tlf pos-map)))))
741 dbarlow 1.1
742 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
743 dbarlow 1.1
744 lgorrie 1.121 (defun print-code-location-source-form (code-location context)
745     (macrolet ((printer-form ()
746     ;; KLUDGE: These are both unexported interfaces, used
747     ;; by different versions of SBCL. ...sooner or later
748     ;; this will change again: hopefully by then we have
749     ;; figured out the interface we want to drive the
750     ;; debugger with and requested it from the SBCL
751     ;; folks.
752     (let ((print-code-sym
753     (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
754     :sb-debug))
755     (code-sym
756     (find-symbol "CODE-LOCATION-SOURCE-FORM"
757     :sb-debug)))
758     (cond ((fboundp print-code-sym)
759     `(,print-code-sym code-location context))
760     ((fboundp code-sym)
761     `(prin1 (,code-sym code-location context)))
762     (t
763     (error
764     "*THWAP* SBCL changes its debugger interface ~
765     again!"))))))
766     (printer-form)))
767    
768 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
769 heller 1.124 (handler-case (code-location-source-location code-location)
770 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
771    
772 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
773 heller 1.22 (safe-source-location-for-emacs
774     (sb-di:frame-code-location (nth-frame index))))
775 dbarlow 1.1
776 heller 1.92 (defun frame-debug-vars (frame)
777     "Return a vector of debug-variables in frame."
778     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
779    
780     (defun debug-var-value (var frame location)
781     (ecase (sb-di:debug-var-validity var location)
782     (:valid (sb-di:debug-var-value var frame))
783     ((:invalid :unknown) ':<not-available>)))
784    
785 lgorrie 1.54 (defimplementation frame-locals (index)
786 dbarlow 1.1 (let* ((frame (nth-frame index))
787 heller 1.92 (loc (sb-di:frame-code-location frame))
788     (vars (frame-debug-vars frame)))
789     (loop for v across vars collect
790     (list :name (sb-di:debug-var-symbol v)
791     :id (sb-di:debug-var-id v)
792     :value (debug-var-value v frame loc)))))
793    
794     (defimplementation frame-var-value (frame var)
795     (let* ((frame (nth-frame frame))
796     (dvar (aref (frame-debug-vars frame) var)))
797     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
798 dbarlow 1.1
799 lgorrie 1.54 (defimplementation frame-catch-tags (index)
800 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
801 lgorrie 1.50
802 heller 1.56 (defimplementation eval-in-frame (form index)
803     (let ((frame (nth-frame index)))
804 heller 1.58 (funcall (the function
805     (sb-di:preprocess-for-eval form
806     (sb-di:frame-code-location frame)))
807 heller 1.56 frame)))
808    
809     (defun sb-debug-catch-tag-p (tag)
810     (and (symbolp tag)
811     (not (symbol-package tag))
812     (string= tag :sb-debug-catch-tag)))
813    
814     (defimplementation return-from-frame (index form)
815     (let* ((frame (nth-frame index))
816     (probe (assoc-if #'sb-debug-catch-tag-p
817     (sb-di::frame-catches frame))))
818     (cond (probe (throw (car probe) (eval-in-frame form index)))
819     (t (format nil "Cannot return from frame: ~S" frame)))))
820    
821 lgorrie 1.87 ;;;;; reference-conditions
822    
823     (defimplementation format-sldb-condition (condition)
824     (let ((sb-int:*print-condition-references* nil))
825     (princ-to-string condition)))
826    
827     (defimplementation condition-references (condition)
828     (if (typep condition 'sb-int:reference-condition)
829     (sb-int:reference-condition-references condition)
830     '()))
831    
832 heller 1.57
833     ;;;; Profiling
834    
835     (defimplementation profile (fname)
836     (when fname (eval `(sb-profile:profile ,fname))))
837    
838     (defimplementation unprofile (fname)
839     (when fname (eval `(sb-profile:unprofile ,fname))))
840    
841     (defimplementation unprofile-all ()
842     (sb-profile:unprofile)
843     "All functions unprofiled.")
844    
845     (defimplementation profile-report ()
846     (sb-profile:report))
847    
848     (defimplementation profile-reset ()
849     (sb-profile:reset)
850     "Reset profiling counters.")
851    
852     (defimplementation profiled-functions ()
853     (sb-profile:profile))
854    
855 heller 1.116 (defimplementation profile-package (package callers methods)
856     (declare (ignore callers methods))
857     (eval `(sb-profile:profile ,(package-name (find-package package)))))
858    
859 heller 1.57
860 heller 1.64 ;;;; Inspector
861 heller 1.63
862 mbaringer 1.102 (defclass sbcl-inspector (inspector)
863     ())
864    
865     (defimplementation make-default-inspector ()
866     (make-instance 'sbcl-inspector))
867    
868     (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
869     (declare (ignore inspector))
870 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
871 mbaringer 1.102 (values "A value cell."
872     `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))
873 heller 1.64 (t
874     (multiple-value-bind (text labeledp parts)
875     (sb-impl::inspected-parts o)
876 mbaringer 1.102 (if labeledp
877     (values text
878     (loop for (label . value) in parts
879     collect `(:value ,label)
880     collect " = "
881     collect `(:value ,value)
882     collect '(:newline)))
883     (values text
884     (loop for value in parts
885     for i from 0
886     collect (princ-to-string i)
887     collect " = "
888     collect `(:value ,value)
889     collect '(:newline))))))))
890 heller 1.64
891 mbaringer 1.102 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
892     (declare (ignore inspector))
893 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
894     (cond ((= header sb-vm:simple-fun-header-widetag)
895 mbaringer 1.102 (values "A simple-fun."
896 mbaringer 1.103 `("Name: " (:value ,(sb-kernel:%simple-fun-name o))
897 mbaringer 1.102 (:newline)
898 mbaringer 1.103 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
899 mbaringer 1.102 (:newline)
900 mbaringer 1.103 ,@(when (documentation o t)
901     `("Documentation: " (:newline) ,(documentation o t) (:newline)))
902     "Self: " (:value ,(sb-kernel:%simple-fun-self o))
903 mbaringer 1.102 (:newline)
904 mbaringer 1.103 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
905 mbaringer 1.102 (:newline)
906     "Type: " (:value ,(sb-kernel:%simple-fun-type o))
907     (:newline)
908     "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
909 heller 1.64 ((= header sb-vm:closure-header-widetag)
910 mbaringer 1.102 (values "A closure."
911     `("Function: " (:value ,(sb-kernel:%closure-fun o))
912     (:newline)
913 mbaringer 1.103 ,@(when (documentation o t)
914     `("Documentation: " (:newline) ,(documentation o t) (:newline)))
915 mbaringer 1.102 "Closed over values:"
916     (:newline)
917     ,@(loop for i from 0
918 heller 1.64 below (- (sb-kernel:get-closure-length o)
919     (1- sb-vm:closure-info-offset))
920 mbaringer 1.102 collect (princ-to-string i)
921     collect " = "
922     collect `(:value ,(sb-kernel:%closure-index-ref o i))
923     collect '(:newline)))))
924 heller 1.64 (t (call-next-method o)))))
925    
926 heller 1.113 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
927     (declare (ignore _))
928     (values (format nil "~A is a code data-block." o)
929     (append
930     (label-value-line*
931     (:code-size (sb-kernel:%code-code-size o))
932     (:entry-points (sb-kernel:%code-entry-points o))
933     (:debug-info (sb-kernel:%code-debug-info o))
934     (:trace-table-offset (sb-kernel:code-header-ref
935     o sb-vm:code-trace-table-offset-slot)))
936     `("Constants:" (:newline))
937     (loop for i from sb-vm:code-constants-offset
938 mbaringer 1.102 below (sb-kernel:get-header-data o)
939 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
940     `("Code:" (:newline)
941     , (with-output-to-string (s)
942     (cond ((sb-kernel:%code-debug-info o)
943     (sb-disassem:disassemble-code-component o :stream s))
944     (t
945     (sb-disassem:disassemble-memory
946     (sb-disassem::align
947     (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
948     sb-vm:lowtag-mask)
949     (* sb-vm:code-constants-offset sb-vm:n-word-bytes))
950     (ash 1 sb-vm:n-lowtag-bits))
951     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
952     :stream s))))))))
953 mbaringer 1.102
954     (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
955 mbaringer 1.104 (declare (ignore inspector))
956 mbaringer 1.102 (values "A fdefn object."
957     `("Name: " (:value ,(sb-kernel:fdefn-name o))
958     (:newline)
959 mbaringer 1.103 "Function" (:value,(sb-kernel:fdefn-fun o))
960     (:newline)
961     ,@(when (documentation o t)
962     `("Documentation: " (:newline) ,(documentation o t) (:newline))))))
963 mbaringer 1.102
964     (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))
965     (declare (ignore inspector))
966     (multiple-value-bind (title contents)
967     (call-next-method)
968     (values title
969     (append contents
970     `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))
971     (:newline)
972     "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods o)))))))
973 heller 1.90
974 heller 1.63
975 lgorrie 1.50 ;;;; Multiprocessing
976    
977 heller 1.81 #+sb-thread
978 lgorrie 1.50 (progn
979 lgorrie 1.54 (defimplementation spawn (fn &key name)
980 lgorrie 1.50 (declare (ignore name))
981     (sb-thread:make-thread fn))
982    
983 heller 1.85 (defimplementation startup-multiprocessing ())
984 lgorrie 1.50
985 heller 1.93 (defimplementation thread-id (thread)
986     thread)
987    
988     (defimplementation find-thread (id)
989     (if (member id (all-threads))
990     id))
991    
992 heller 1.63 (defimplementation thread-name (thread)
993     (format nil "Thread ~D" thread))
994 lgorrie 1.50
995 heller 1.114 (defun %thread-state-slot (thread)
996     (sb-sys:without-gcing
997     (sb-kernel:make-lisp-obj
998     (sb-sys:sap-int
999     (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
1000     (* sb-vm::thread-state-slot
1001     sb-vm::n-word-bytes))))))
1002    
1003     (defun %thread-state (thread)
1004     (ecase (%thread-state-slot thread)
1005     (0 :running)
1006     (1 :stopping)
1007     (2 :stopped)
1008     (3 :dead)))
1009    
1010 heller 1.63 (defimplementation thread-status (thread)
1011 heller 1.114 (string (%thread-state thread)))
1012 lgorrie 1.50
1013 lgorrie 1.54 (defimplementation make-lock (&key name)
1014 lgorrie 1.50 (sb-thread:make-mutex :name name))
1015    
1016 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
1017 heller 1.58 (declare (type function function))
1018 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
1019 heller 1.59
1020     (defimplementation current-thread ()
1021     (sb-thread:current-thread-id))
1022    
1023 heller 1.63 (defimplementation all-threads ()
1024 heller 1.114 (let ((pids (sb-sys:without-gcing
1025     (sb-thread::mapcar-threads
1026     (lambda (sap)
1027     (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
1028     sb-vm::thread-pid-slot)))))))
1029     (remove :dead pids :key #'%thread-state)))
1030 heller 1.59
1031     (defimplementation interrupt-thread (thread fn)
1032     (sb-thread:interrupt-thread thread fn))
1033    
1034 heller 1.70 (defimplementation kill-thread (thread)
1035     (sb-thread:terminate-thread thread))
1036 heller 1.59
1037     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1038     (defvar *mailboxes* (list))
1039 heller 1.60 (declaim (type list *mailboxes*))
1040 heller 1.59
1041     (defstruct (mailbox (:conc-name mailbox.))
1042     thread
1043     (mutex (sb-thread:make-mutex))
1044     (waitqueue (sb-thread:make-waitqueue))
1045     (queue '() :type list))
1046    
1047     (defun mailbox (thread)
1048     "Return THREAD's mailbox."
1049     (sb-thread:with-mutex (*mailbox-lock*)
1050     (or (find thread *mailboxes* :key #'mailbox.thread)
1051     (let ((mb (make-mailbox :thread thread)))
1052     (push mb *mailboxes*)
1053     mb))))
1054    
1055     (defimplementation send (thread message)
1056     (let* ((mbox (mailbox thread))
1057     (mutex (mailbox.mutex mbox)))
1058     (sb-thread:with-mutex (mutex)
1059     (setf (mailbox.queue mbox)
1060     (nconc (mailbox.queue mbox) (list message)))
1061     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1062    
1063     (defimplementation receive ()
1064     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
1065     (mutex (mailbox.mutex mbox)))
1066     (sb-thread:with-mutex (mutex)
1067     (loop
1068     (let ((q (mailbox.queue mbox)))
1069     (cond (q (return (pop (mailbox.queue mbox))))
1070     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1071     mutex))))))))
1072    
1073     )
1074 mbaringer 1.117
1075 heller 1.118
1076 mbaringer 1.117 ;;Trace implementations
1077     ;;In SBCL, we have:
1078     ;; (trace <name>)
1079 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1080 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1081     ;; <name> can be a normal name or a (setf name)
1082    
1083 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1084 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1085     (eval `(untrace ,fspec))
1086     (format nil "~S is now untraced." fspec))
1087     (t
1088     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1089     (format nil "~S is now traced." fspec))))
1090    
1091     (defun process-fspec (fspec)
1092     (cond ((consp fspec)
1093     (ecase (first fspec)
1094     ((:defun :defgeneric) (second fspec))
1095     ((:defmethod) `(method ,@(rest fspec)))
1096     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1097     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1098     (t
1099     fspec)))
1100    
1101 heller 1.119 (defimplementation toggle-trace (spec)
1102     (ecase (car spec)
1103     ((setf)
1104     (toggle-trace-aux spec))
1105     ((:defmethod)
1106     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1107     ((:defgeneric)
1108     (toggle-trace-aux (second spec) :methods t))
1109     ((:call)
1110     (destructuring-bind (caller callee) (cdr spec)
1111     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))

  ViewVC Help
Powered by ViewVC 1.1.5