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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5