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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.164 - (hide annotations)
Wed Sep 20 17:52:32 2006 UTC (7 years, 6 months ago) by jsnellman
Branch: MAIN
Changes since 1.163: +6 -6 lines
use INVOKE-STEPPER rather than funcalling *STEPPER-HOOK*
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 jsnellman 1.158 ;;; This code has been placed in the Public Domain. All warranties are
8 dbarlow 1.1 ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14 heller 1.146 (in-package :swank-backend)
15    
16 dbarlow 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require 'sb-bsd-sockets)
18 heller 1.59 (require 'sb-introspect)
19 heller 1.129 (require 'sb-posix))
20 heller 1.107
21 nsiivola 1.161 (declaim (optimize (debug 2) (sb-c:insert-step-conditions 0)))
22 dbarlow 1.1
23 heller 1.146 (import-from :sb-gray *gray-stream-symbols* :swank-backend)
24 heller 1.23
25 mbaringer 1.100 ;;; swank-mop
26    
27 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
28 mbaringer 1.100
29 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
30 jsnellman 1.158 (sb-pcl::documentation slot t))
31 mbaringer 1.100
32 dbarlow 1.1 ;;; TCP Server
33    
34 lgorrie 1.132 (defimplementation preferred-communication-style ()
35 crhodes 1.155 (cond
36     ;; fixme: when SBCL/win32 gains better select() support, remove
37     ;; this.
38     ((member :win32 *features*) nil)
39 jsnellman 1.159 ((member :sb-thread *features*) :spawn)
40 crhodes 1.155 (t :fd-handler)))
41 jsnellman 1.158
42 heller 1.65 (defun resolve-hostname (name)
43     (car (sb-bsd-sockets:host-ent-addresses
44     (sb-bsd-sockets:get-host-by-name name))))
45    
46     (defimplementation create-socket (host port)
47 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
48     :type :stream
49     :protocol :tcp)))
50 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
51 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
52 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
53 heller 1.29 socket))
54    
55 lgorrie 1.54 (defimplementation local-port (socket)
56 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
57    
58 lgorrie 1.54 (defimplementation close-socket (socket)
59 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
60 heller 1.48 (sb-bsd-sockets:socket-close socket))
61    
62 jsnellman 1.158 (defimplementation accept-connection (socket &key
63 heller 1.160 external-format
64     buffering timeout)
65 dcrosher 1.153 (declare (ignore timeout))
66 heller 1.160 (make-socket-io-stream (accept socket)
67     (or external-format :iso-latin-1-unix)
68     (or buffering :full)))
69 heller 1.48
70 heller 1.59 (defvar *sigio-handlers* '()
71     "List of (key . fn) pairs to be called on SIGIO.")
72    
73     (defun sigio-handler (signal code scp)
74 heller 1.60 (declare (ignore signal code scp))
75     (mapc (lambda (handler)
76     (funcall (the function (cdr handler))))
77     *sigio-handlers*))
78 heller 1.59
79     (defun set-sigio-handler ()
80 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
81 heller 1.59 (sigio-handler signal code scp))))
82    
83 heller 1.62 (defun enable-sigio-on-fd (fd)
84 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
85     (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
86 heller 1.62
87 heller 1.67 (defimplementation add-sigio-handler (socket fn)
88 heller 1.62 (set-sigio-handler)
89     (let ((fd (socket-fd socket)))
90     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
91     (enable-sigio-on-fd fd)
92     (push (cons fd fn) *sigio-handlers*)))
93    
94 heller 1.67 (defimplementation remove-sigio-handlers (socket)
95 heller 1.59 (let ((fd (socket-fd socket)))
96     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
97 jsnellman 1.158 (sb-sys:invalidate-descriptor fd))
98 heller 1.51 (close socket))
99 heller 1.67
100     (defimplementation add-fd-handler (socket fn)
101     (declare (type function fn))
102     (let ((fd (socket-fd socket)))
103     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
104 jsnellman 1.158 (sb-sys:add-fd-handler fd :input (lambda (_)
105 heller 1.67 _
106     (funcall fn)))))
107    
108     (defimplementation remove-fd-handlers (socket)
109     (sb-sys:invalidate-descriptor (socket-fd socket)))
110 heller 1.51
111 heller 1.48 (defun socket-fd (socket)
112     (etypecase socket
113     (fixnum socket)
114     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
115     (file-stream (sb-sys:fd-stream-fd socket))))
116    
117 heller 1.137 (defun find-external-format (coding-system)
118     (ecase coding-system
119     (:iso-latin-1-unix :iso-8859-1)
120 heller 1.144 (:utf-8-unix :utf-8)
121     (:euc-jp-unix :euc-jp)))
122 heller 1.137
123 heller 1.150 (defun make-socket-io-stream (socket external-format buffering)
124 heller 1.137 (let ((ef (find-external-format external-format)))
125 heller 1.110 (sb-bsd-sockets:socket-make-stream socket
126     :output t
127     :input t
128     :element-type 'character
129 heller 1.150 :buffering buffering
130 jsnellman 1.158 #+sb-unicode :external-format
131 heller 1.137 #+sb-unicode ef
132 heller 1.112 )))
133 lgorrie 1.46
134 heller 1.29 (defun accept (socket)
135     "Like socket-accept, but retry on EAGAIN."
136 jsnellman 1.158 (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 jsnellman 1.163 (defimplementation 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 jsnellman 1.158 (defvar *shebang-readtable*
193 heller 1.124 (let ((*readtable* (copy-readtable nil)))
194 jsnellman 1.158 (set-dispatch-macro-character #\# #\!
195 heller 1.124 (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 jsnellman 1.158 (handler-bind ((sb-int:bootstrap-package-not-found
219 heller 1.126 #'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 jsnellman 1.158 (cond ((and *debootstrap-packages*
227 heller 1.124 (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 heller 1.160 (defimplementation arglist (fname)
240 heller 1.74 (sb-introspect:function-arglist fname))
241 mbaringer 1.100
242 heller 1.160 (defimplementation function-name (f)
243     (check-type f function)
244 mbaringer 1.100 (sb-impl::%fun-name f))
245 dbarlow 1.1
246 dbarlow 1.42 (defvar *buffer-name* nil)
247 dbarlow 1.1 (defvar *buffer-offset*)
248 heller 1.70 (defvar *buffer-substring* nil)
249 dbarlow 1.1
250 lgorrie 1.24 (defvar *previous-compiler-condition* nil
251     "Used to detect duplicates.")
252    
253 dbarlow 1.1 (defun handle-notification-condition (condition)
254     "Handle a condition caused by a compiler warning.
255     This traps all compiler conditions at a lower-level than using
256     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
257     craft our own error messages, which can omit a lot of redundant
258     information."
259     (let ((context (sb-c::find-error-context nil)))
260 heller 1.36 (unless (eq condition *previous-compiler-condition*)
261 dbarlow 1.1 (setq *previous-compiler-condition* condition)
262 lgorrie 1.24 (signal-compiler-condition condition context))))
263    
264     (defun signal-compiler-condition (condition context)
265     (signal (make-condition
266     'compiler-condition
267     :original-condition condition
268     :severity (etypecase condition
269     (sb-c:compiler-error :error)
270     (sb-ext:compiler-note :note)
271     (style-warning :style-warning)
272 lgorrie 1.96 (warning :warning)
273     (error :error))
274 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
275 heller 1.107 :references (condition-references (real-condition condition))
276 heller 1.66 :message (long-compiler-message-for-emacs condition context)
277 lgorrie 1.24 :location (compiler-note-location context))))
278 heller 1.107
279     (defun real-condition (condition)
280     "Return the encapsulated condition or CONDITION itself."
281     (typecase condition
282     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
283     (t condition)))
284 lgorrie 1.24
285     (defun compiler-note-location (context)
286 heller 1.124 (if context
287 heller 1.127 (locate-compiler-note
288     (sb-c::compiler-error-context-file-name context)
289     (compiler-source-path context)
290     (sb-c::compiler-error-context-original-source context))
291 heller 1.124 (list :error "No error location available")))
292    
293 heller 1.127 (defun locate-compiler-note (file source-path source)
294 jsnellman 1.158 (cond ((and (not (eq file :lisp)) *buffer-name*)
295 heller 1.124 ;; Compiling from a buffer
296     (let ((position (+ *buffer-offset*
297     (source-path-string-position
298 jsnellman 1.158 source-path *buffer-substring*))))
299 heller 1.124 (make-location (list :buffer *buffer-name*)
300     (list :position position))))
301     ((and (pathnamep file) (null *buffer-name*))
302     ;; Compiling from a file
303     (make-location (list :file (namestring file))
304     (list :position
305 jsnellman 1.158 (1+ (source-path-file-position
306 heller 1.124 source-path file)))))
307 heller 1.127 ((and (eq file :lisp) (stringp source))
308     ;; Compiling macro generated code
309     (make-location (list :source-form source)
310     (list :position 1)))
311 dbarlow 1.42 (t
312 heller 1.124 (error "unhandled case"))))
313 dbarlow 1.42
314 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
315 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
316     When Emacs presents the message it already has the source popped up
317     and the source form highlighted. This makes much of the information in
318     the error-context redundant."
319 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
320     (princ-to-string condition)))
321 heller 1.66
322     (defun long-compiler-message-for-emacs (condition error-context)
323     "Describe a compiler error for Emacs including context information."
324 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
325 heller 1.66 (multiple-value-bind (enclosing source)
326     (if error-context
327     (values (sb-c::compiler-error-context-enclosing-source error-context)
328     (sb-c::compiler-error-context-source error-context)))
329 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
330     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
331     enclosing source condition))))
332 dbarlow 1.1
333 heller 1.124 (defun compiler-source-path (context)
334 dbarlow 1.1 "Return the source-path for the current compiler error.
335     Returns NIL if this cannot be determined by examining internal
336     compiler state."
337     (cond ((sb-c::node-p context)
338     (reverse
339     (sb-c::source-path-original-source
340     (sb-c::node-source-path context))))
341     ((sb-c::compiler-error-context-p context)
342     (reverse
343     (sb-c::compiler-error-context-original-source-path context)))))
344    
345 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
346 heller 1.58 (declare (type function function))
347 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
348     (sb-c:compiler-error #'handle-notification-condition)
349 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
350     (style-warning #'handle-notification-condition)
351     (warning #'handle-notification-condition))
352     (funcall function)))
353 lgorrie 1.24
354 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
355     "Handle a condition that caused the file compiler to terminate."
356     (handle-notification-condition
357     (sb-int:encapsulated-condition condition)))
358    
359 heller 1.91 (defvar *trap-load-time-warnings* nil)
360    
361 jsnellman 1.158 (defimplementation swank-compile-file (filename load-p
362 heller 1.137 &optional external-format)
363 jsnellman 1.158 (let ((ef (if external-format
364 heller 1.137 (find-external-format external-format)
365     :default)))
366     (handler-case
367     (let ((output-file (with-compilation-hooks ()
368     (compile-file filename :external-format ef))))
369     (when output-file
370     ;; Cache the latest source file for definition-finding.
371     (source-cache-get filename (file-write-date filename))
372     (when load-p
373     (load output-file))))
374     (sb-c:fatal-compiler-error () nil))))
375 lgorrie 1.24
376 heller 1.124 ;;;; compile-string
377    
378 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
379     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
380     ;;; which the previous approach using
381     ;;; (compile nil `(lambda () ,(read-from-string string)))
382     ;;; did not provide.
383    
384     (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
385     (dest (* sb-alien:c-string)))
386    
387     (defun temp-file-name ()
388     "Return a temporary file name to compile strings into."
389     (concatenate 'string (tmpnam nil) ".lisp"))
390    
391 pseibel 1.98 (defimplementation swank-compile-string (string &key buffer position directory)
392     (declare (ignore directory))
393 heller 1.156 (let ((*buffer-name* buffer)
394     (*buffer-offset* position)
395     (*buffer-substring* string)
396     (filename (temp-file-name)))
397 jsnellman 1.158 (flet ((compile-it (fn)
398 heller 1.139 (with-compilation-hooks ()
399 heller 1.156 (with-compilation-unit
400     (:source-plist (list :emacs-buffer buffer
401     :emacs-string string
402     :emacs-position position))
403     (funcall fn (compile-file filename))))))
404     (with-open-file (s filename :direction :output :if-exists :error)
405     (write-string string s))
406     (unwind-protect
407     (if *trap-load-time-warnings*
408     (compile-it #'load)
409     (load (compile-it #'identity)))
410     (ignore-errors
411     (delete-file filename)
412     (delete-file (compile-file-pathname filename)))))))
413 dbarlow 1.1
414     ;;;; Definitions
415    
416     (defvar *debug-definition-finding* nil
417     "When true don't handle errors while looking for definitions.
418     This is useful when debugging the definition-finding code.")
419    
420 jsnellman 1.149 (defparameter *definition-types*
421     '(:variable defvar
422     :constant defconstant
423     :type deftype
424     :symbol-macro define-symbol-macro
425     :macro defmacro
426     :compiler-macro define-compiler-macro
427     :function defun
428     :generic-function defgeneric
429     :method defmethod
430     :setf-expander define-setf-expander
431     :structure defstruct
432 jsnellman 1.159 :condition define-condition
433 jsnellman 1.149 :class defclass
434     :method-combination define-method-combination
435     :package defpackage
436     :transform :deftransform
437     :optimizer :defoptimizer
438     :vop :define-vop
439     :source-transform :define-source-transform)
440     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
441    
442     (defimplementation find-definitions (name)
443     (loop for type in *definition-types* by #'cddr
444     for locations = (sb-introspect:find-definition-sources-by-name
445     name type)
446     append (loop for source-location in locations collect
447     (make-source-location-specification type name
448     source-location))))
449    
450     (defun make-source-location-specification (type name source-location)
451     (list (list* (getf *definition-types* type)
452     name
453     (sb-introspect::definition-source-description source-location))
454     (if *debug-definition-finding*
455     (make-definition-source-location source-location type name)
456     (handler-case (make-definition-source-location source-location
457     type name)
458     (error (e)
459     (list :error (format nil "Error: ~A" e)))))))
460    
461     (defun make-definition-source-location (definition-source type name)
462     (with-struct (sb-introspect::definition-source-
463     pathname form-path character-offset plist
464     file-write-date)
465     definition-source
466     (destructuring-bind (&key emacs-buffer emacs-position
467     emacs-string &allow-other-keys)
468     plist
469     (cond
470     (emacs-buffer
471     (let ((pos (if form-path
472     (with-debootstrapping
473     (source-path-string-position
474     form-path emacs-string))
475     character-offset)))
476     (make-location `(:buffer ,emacs-buffer)
477     `(:position ,(+ pos emacs-position))
478     `(:snippet ,emacs-string))))
479     ((not pathname)
480     `(:error ,(format nil "Source of ~A ~A not found"
481     (string-downcase type) name)))
482     (t
483     (let* ((namestring (namestring (translate-logical-pathname pathname)))
484     (*readtable* (guess-readtable-for-filename namestring))
485     (pos (1+ (with-debootstrapping
486     ;; Some internal functions have no source path
487     ;; or offset available, just the file (why?).
488     ;; In these cases we can at least try to open
489     ;; the right file.
490     (if form-path
491     (source-path-file-position form-path
492     pathname)
493     0))))
494     (snippet (source-hint-snippet namestring
495     file-write-date pos)))
496     (make-location `(:file ,namestring)
497     `(:position ,pos)
498     `(:snippet ,snippet))))))))
499    
500     (defun source-hint-snippet (filename write-date position)
501     (let ((source (get-source-code filename write-date)))
502     (with-input-from-string (s source)
503     (read-snippet s position))))
504    
505 jsnellman 1.151 (defun function-source-location (function &optional name)
506     (declare (type function function))
507     (let ((location (sb-introspect:find-definition-source function)))
508     (make-definition-source-location location :function name)))
509    
510     (defun safe-function-source-location (fun name)
511     (if *debug-definition-finding*
512     (function-source-location fun name)
513     (handler-case (function-source-location fun name)
514     (error (e)
515     (list :error (format nil "Error: ~A" e))))))
516 heller 1.105
517 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
518 dbarlow 1.1 "Return a plist describing SYMBOL.
519     Return NIL if the symbol is unbound."
520     (let ((result '()))
521 heller 1.133 (flet ((doc (kind)
522     (or (documentation symbol kind) :not-documented))
523     (maybe-push (property value)
524     (when value
525     (setf result (list* property value result)))))
526 dbarlow 1.1 (maybe-push
527     :variable (multiple-value-bind (kind recorded-p)
528     (sb-int:info :variable :kind symbol)
529     (declare (ignore kind))
530     (if (or (boundp symbol) recorded-p)
531     (doc 'variable))))
532 heller 1.133 (when (fboundp symbol)
533     (maybe-push
534     (cond ((macro-function symbol) :macro)
535     ((special-operator-p symbol) :special-operator)
536     ((typep (fdefinition symbol) 'generic-function)
537     :generic-function)
538     (t :function))
539     (doc 'function)))
540 dbarlow 1.1 (maybe-push
541     :setf (if (or (sb-int:info :setf :inverse symbol)
542     (sb-int:info :setf :expander symbol))
543     (doc 'setf)))
544     (maybe-push
545     :type (if (sb-int:info :type :kind symbol)
546     (doc 'type)))
547 lgorrie 1.24 result)))
548 dbarlow 1.1
549 heller 1.74 (defimplementation describe-definition (symbol type)
550 lgorrie 1.54 (case type
551     (:variable
552 heller 1.74 (describe symbol))
553     (:function
554     (describe (symbol-function symbol)))
555 lgorrie 1.54 (:setf
556 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
557     (sb-int:info :setf :expander symbol))))
558 lgorrie 1.54 (:class
559 heller 1.74 (describe (find-class symbol)))
560 lgorrie 1.54 (:type
561 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
562 dbarlow 1.1
563 heller 1.97 (defimplementation list-callers (symbol)
564     (let ((fn (fdefinition symbol)))
565     (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
566    
567     (defimplementation list-callees (symbol)
568     (let ((fn (fdefinition symbol)))
569     (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
570    
571 lgorrie 1.122 (defun function-dspec (fn)
572     "Describe where the function FN was defined.
573     Return a list of the form (NAME LOCATION)."
574     (let ((name (sb-kernel:%fun-name fn)))
575     (list name (safe-function-source-location fn name))))
576    
577 dbarlow 1.4 ;;; macroexpansion
578 dbarlow 1.1
579 lgorrie 1.54 (defimplementation macroexpand-all (form)
580 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
581     (sb-walker:walk-form form)))
582 lgorrie 1.25
583 dbarlow 1.1
584     ;;; Debugging
585    
586 jsnellman 1.162 (eval-when (:compile-toplevel :load-toplevel :execute)
587     ;; Generate a form suitable for testing for stepper support (0.9.17)
588     ;; with #+.
589     (defun sbcl-with-new-stepper-p ()
590     (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
591     '(and)
592     '(or))))
593    
594 dbarlow 1.1 (defvar *sldb-stack-top*)
595    
596 heller 1.148 (defimplementation install-debugger-globally (function)
597 heller 1.152 (setq sb-ext:*invoke-debugger-hook* function))
598 heller 1.148
599 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
600     (defimplementation condition-extras (condition)
601     (when (typep condition 'sb-impl::step-form-condition)
602     `((:short-frame-source 0))))
603    
604 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
605 heller 1.58 (declare (type function debugger-loop-fn))
606 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
607 heller 1.71 (sb-debug:*stack-top-hint* nil))
608 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
609 dbarlow 1.1 (lambda (condition)
610 lgorrie 1.25 (signal (make-condition
611     'sldb-condition
612     :original-condition condition)))))
613     (funcall debugger-loop-fn))))
614 dbarlow 1.1
615 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
616     (progn
617     (defimplementation activate-stepping (frame)
618     (declare (ignore frame))
619     (sb-impl::enable-stepping))
620     (defimplementation sldb-stepper-condition-p (condition)
621     (typep condition 'sb-ext:step-form-condition))
622     (defimplementation sldb-step-into ()
623     (invoke-restart 'sb-ext:step-into))
624     (defimplementation sldb-step-next ()
625     (invoke-restart 'sb-ext:step-next))
626     (defimplementation sldb-step-out ()
627     (invoke-restart 'sb-ext:step-out)))
628    
629 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
630 jsnellman 1.162 (let ((sb-ext:*invoke-debugger-hook* hook)
631     #+#.(swank-backend::sbcl-with-new-stepper-p)
632     (sb-ext:*stepper-hook*
633     (lambda (condition)
634 jsnellman 1.164 (typecase condition
635     (sb-ext:step-form-condition
636     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
637     (sb-impl::invoke-debugger condition)))))))
638     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
639     (sb-ext:step-condition #'sb-impl::invoke-stepper))
640 jsnellman 1.163 (funcall fun))))
641 heller 1.118
642 dbarlow 1.1 (defun nth-frame (index)
643     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
644     (i index (1- i)))
645     ((zerop i) frame)))
646    
647 heller 1.74 (defimplementation compute-backtrace (start end)
648 dbarlow 1.1 "Return a list of frames starting with frame number START and
649     continuing to frame number END or, if END is nil, the last frame on the
650     stack."
651     (let ((end (or end most-positive-fixnum)))
652 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
653     for i from start below end
654     while f
655 heller 1.74 collect f)))
656 dbarlow 1.1
657 heller 1.74 (defimplementation print-frame (frame stream)
658 nsiivola 1.134 (sb-debug::print-frame-call frame stream))
659 dbarlow 1.1
660 heller 1.124 ;;;; Code-location -> source-location translation
661    
662 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
663     ;;; the source-path for a code-location. If the code was compiled
664     ;;; with C-c C-c, we have to search the position in the source string.
665     ;;; If there's no debug-block info, we return the (less precise)
666     ;;; source-location of the corresponding function.
667    
668 nsiivola 1.134 (defun code-location-source-location (code-location)
669     (let* ((dsource (sb-di:code-location-debug-source code-location))
670     (plist (sb-c::debug-source-plist dsource)))
671     (if (getf plist :emacs-buffer)
672     (emacs-buffer-source-location code-location plist)
673     (ecase (sb-di:debug-source-from dsource)
674     (:file (file-source-location code-location))
675     (:lisp (lisp-source-location code-location))))))
676    
677     ;;; FIXME: The naming policy of source-location functions is a bit
678     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
679     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
680     ;;; which returns the source location for a _code-location_.
681 jsnellman 1.158 ;;;
682 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
683 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
684     ;;; least the names should indicate the main entry point vs. helper
685     ;;; status.
686 heller 1.124
687 nsiivola 1.134 (defun file-source-location (code-location)
688     (if (code-location-has-debug-block-info-p code-location)
689     (source-file-source-location code-location)
690     (fallback-source-location code-location)))
691    
692     (defun fallback-source-location (code-location)
693     (let ((fun (code-location-debug-fun-fun code-location)))
694     (cond (fun (function-source-location fun))
695     (t (error "Cannot find source location for: ~A " code-location)))))
696    
697 heller 1.124 (defun lisp-source-location (code-location)
698 jsnellman 1.158 (let ((source (prin1-to-string
699 nsiivola 1.134 (sb-debug::code-location-source-form code-location 100))))
700 heller 1.124 (make-location `(:source-form ,source) '(:position 0))))
701    
702 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
703     (if (code-location-has-debug-block-info-p code-location)
704     (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
705     (let* ((pos (string-source-position code-location emacs-string))
706     (snipped (with-input-from-string (s emacs-string)
707     (read-snippet s pos))))
708 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
709     `(:position ,(+ emacs-position pos))
710 nsiivola 1.134 `(:snippet ,snipped))))
711     (fallback-source-location code-location)))
712    
713 heller 1.124 (defun source-file-source-location (code-location)
714     (let* ((code-date (code-location-debug-source-created code-location))
715     (filename (code-location-debug-source-name code-location))
716 heller 1.126 (source-code (get-source-code filename code-date)))
717 heller 1.124 (with-input-from-string (s source-code)
718 heller 1.128 (let* ((pos (stream-source-position code-location s))
719     (snippet (read-snippet s pos)))
720 heller 1.124 (make-location `(:file ,filename)
721 heller 1.128 `(:position ,(1+ pos))
722     `(:snippet ,snippet))))))
723 heller 1.124
724     (defun code-location-debug-source-name (code-location)
725     (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
726    
727     (defun code-location-debug-source-created (code-location)
728 jsnellman 1.158 (sb-c::debug-source-created
729 heller 1.124 (sb-di::code-location-debug-source code-location)))
730    
731     (defun code-location-debug-fun-fun (code-location)
732     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
733    
734     (defun code-location-has-debug-block-info-p (code-location)
735 jsnellman 1.158 (handler-case
736 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
737     t)
738     (sb-di:no-debug-blocks () nil)))
739    
740     (defun stream-source-position (code-location stream)
741     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
742 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
743 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
744     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
745     (let* ((path-table (sb-di::form-number-translations tlf 0))
746 heller 1.128 (path (cond ((<= (length path-table) form-number)
747 heller 1.129 (warn "inconsistent form-number-translations")
748 heller 1.128 (list 0))
749     (t
750     (reverse (cdr (aref path-table form-number)))))))
751     (source-path-source-position path tlf pos-map)))))
752    
753     (defun string-source-position (code-location string)
754     (with-input-from-string (s string)
755     (stream-source-position code-location s)))
756 dbarlow 1.1
757 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
758 lgorrie 1.121
759 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
760 heller 1.126 (if *debug-definition-finding*
761     (code-location-source-location code-location)
762     (handler-case (code-location-source-location code-location)
763     (error (c) (list :error (format nil "~A" c))))))
764 jsnellman 1.158
765 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
766 jsnellman 1.158 (safe-source-location-for-emacs
767 heller 1.22 (sb-di:frame-code-location (nth-frame index))))
768 dbarlow 1.1
769 heller 1.92 (defun frame-debug-vars (frame)
770     "Return a vector of debug-variables in frame."
771     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
772    
773     (defun debug-var-value (var frame location)
774     (ecase (sb-di:debug-var-validity var location)
775     (:valid (sb-di:debug-var-value var frame))
776     ((:invalid :unknown) ':<not-available>)))
777    
778 lgorrie 1.54 (defimplementation frame-locals (index)
779 dbarlow 1.1 (let* ((frame (nth-frame index))
780 heller 1.92 (loc (sb-di:frame-code-location frame))
781     (vars (frame-debug-vars frame)))
782     (loop for v across vars collect
783     (list :name (sb-di:debug-var-symbol v)
784     :id (sb-di:debug-var-id v)
785     :value (debug-var-value v frame loc)))))
786    
787     (defimplementation frame-var-value (frame var)
788     (let* ((frame (nth-frame frame))
789     (dvar (aref (frame-debug-vars frame) var)))
790     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
791 dbarlow 1.1
792 lgorrie 1.54 (defimplementation frame-catch-tags (index)
793 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
794 lgorrie 1.50
795 heller 1.56 (defimplementation eval-in-frame (form index)
796     (let ((frame (nth-frame index)))
797 heller 1.58 (funcall (the function
798 jsnellman 1.158 (sb-di:preprocess-for-eval form
799 heller 1.58 (sb-di:frame-code-location frame)))
800 heller 1.56 frame)))
801    
802     (defun sb-debug-catch-tag-p (tag)
803     (and (symbolp tag)
804     (not (symbol-package tag))
805     (string= tag :sb-debug-catch-tag)))
806    
807     (defimplementation return-from-frame (index form)
808     (let* ((frame (nth-frame index))
809     (probe (assoc-if #'sb-debug-catch-tag-p
810     (sb-di::frame-catches frame))))
811     (cond (probe (throw (car probe) (eval-in-frame form index)))
812     (t (format nil "Cannot return from frame: ~S" frame)))))
813 heller 1.152
814     ;; FIXME: this implementation doesn't unwind the stack before
815     ;; re-invoking the function, but it's better than no implementation at
816     ;; all.
817     (defimplementation restart-frame (index)
818     (let ((frame (nth-frame index)))
819     (return-from-frame index (sb-debug::frame-call-as-list frame))))
820 jsnellman 1.158
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 heller 1.126 (values "A value cell." (label-value-line*
872     (:value (sb-kernel:value-cell-ref o)))))
873 heller 1.64 (t
874 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
875     (if label
876     (values text (loop for (l . v) in parts
877     append (label-value-line l v)))
878     (values text (loop for value in parts for i from 0
879     append (label-value-line i value))))))))
880 heller 1.64
881 mbaringer 1.102 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
882     (declare (ignore inspector))
883 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
884     (cond ((= header sb-vm:simple-fun-header-widetag)
885 heller 1.126 (values "A simple-fun."
886     (label-value-line*
887     (:name (sb-kernel:%simple-fun-name o))
888     (:arglist (sb-kernel:%simple-fun-arglist o))
889     (:self (sb-kernel:%simple-fun-self o))
890     (:next (sb-kernel:%simple-fun-next o))
891     (:type (sb-kernel:%simple-fun-type o))
892     (:code (sb-kernel:fun-code-header o)))))
893 heller 1.64 ((= header sb-vm:closure-header-widetag)
894 mbaringer 1.102 (values "A closure."
895 jsnellman 1.158 (append
896 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
897     `("Closed over values:" (:newline))
898     (loop for i below (1- (sb-kernel:get-closure-length o))
899 jsnellman 1.158 append (label-value-line
900 heller 1.126 i (sb-kernel:%closure-index-ref o i))))))
901 heller 1.64 (t (call-next-method o)))))
902    
903 heller 1.113 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
904     (declare (ignore _))
905     (values (format nil "~A is a code data-block." o)
906 jsnellman 1.158 (append
907     (label-value-line*
908 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
909     (:entry-points (sb-kernel:%code-entry-points o))
910     (:debug-info (sb-kernel:%code-debug-info o))
911 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
912 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
913     `("Constants:" (:newline))
914 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
915 mbaringer 1.102 below (sb-kernel:get-header-data o)
916 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
917     `("Code:" (:newline)
918     , (with-output-to-string (s)
919     (cond ((sb-kernel:%code-debug-info o)
920     (sb-disassem:disassemble-code-component o :stream s))
921     (t
922 jsnellman 1.158 (sb-disassem:disassemble-memory
923     (sb-disassem::align
924 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
925     sb-vm:lowtag-mask)
926 heller 1.126 (* sb-vm:code-constants-offset
927     sb-vm:n-word-bytes))
928 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
929     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
930     :stream s))))))))
931 mbaringer 1.102
932     (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
933 mbaringer 1.104 (declare (ignore inspector))
934 mbaringer 1.102 (values "A fdefn object."
935 heller 1.126 (label-value-line*
936     (:name (sb-kernel:fdefn-name o))
937     (:function (sb-kernel:fdefn-fun o)))))
938 mbaringer 1.102
939 jsnellman 1.158 (defmethod inspect-for-emacs :around ((o generic-function)
940 heller 1.126 (inspector sbcl-inspector))
941 mbaringer 1.102 (declare (ignore inspector))
942 heller 1.126 (multiple-value-bind (title contents) (call-next-method)
943 mbaringer 1.102 (values title
944 jsnellman 1.158 (append
945 heller 1.126 contents
946     (label-value-line*
947     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
948     (:initial-methods (sb-pcl::generic-function-initial-methods o))
949     )))))
950 heller 1.90
951 heller 1.63
952 lgorrie 1.50 ;;;; Multiprocessing
953    
954 crhodes 1.136 #+(and sb-thread
955     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
956     (progn
957     (defvar *thread-id-counter* 0)
958 jsnellman 1.158
959 crhodes 1.136 (defvar *thread-id-counter-lock*
960     (sb-thread:make-mutex :name "thread id counter lock"))
961    
962     (defun next-thread-id ()
963     (sb-thread:with-mutex (*thread-id-counter-lock*)
964     (incf *thread-id-counter*)))
965 jsnellman 1.158
966 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
967    
968     ;; This should be a thread -> id map but as weak keys are not
969     ;; supported it is id -> map instead.
970     (defvar *thread-id-map-lock*
971     (sb-thread:make-mutex :name "thread id map lock"))
972 jsnellman 1.158
973 crhodes 1.136 (defimplementation spawn (fn &key name)
974     (sb-thread:make-thread fn :name name))
975    
976     (defimplementation thread-id (thread)
977 heller 1.160 (block thread-id
978     (sb-thread:with-mutex (*thread-id-map-lock*)
979     (loop for id being the hash-key in *thread-id-map*
980     using (hash-value thread-pointer)
981     do
982     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
983     (cond ((null maybe-thread)
984     ;; the value is gc'd, remove it manually
985     (remhash id *thread-id-map*))
986     ((eq thread maybe-thread)
987     (return-from thread-id id)))))
988     ;; lazy numbering
989     (let ((id (next-thread-id)))
990     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
991     id))))
992 crhodes 1.136
993     (defimplementation find-thread (id)
994     (sb-thread:with-mutex (*thread-id-map-lock*)
995     (let ((thread-pointer (gethash id *thread-id-map*)))
996     (if thread-pointer
997     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
998     (if maybe-thread
999     maybe-thread
1000     ;; the value is gc'd, remove it manually
1001     (progn
1002     (remhash id *thread-id-map*)
1003     nil)))
1004     nil))))
1005 jsnellman 1.158
1006 crhodes 1.136 (defimplementation thread-name (thread)
1007     ;; sometimes the name is not a string (e.g. NIL)
1008     (princ-to-string (sb-thread:thread-name thread)))
1009    
1010     (defimplementation thread-status (thread)
1011     (if (sb-thread:thread-alive-p thread)
1012     "RUNNING"
1013     "STOPPED"))
1014    
1015     (defimplementation make-lock (&key name)
1016     (sb-thread:make-mutex :name name))
1017    
1018     (defimplementation call-with-lock-held (lock function)
1019     (declare (type function function))
1020     (sb-thread:with-mutex (lock) (funcall function)))
1021    
1022 nsiivola 1.154 (defimplementation make-recursive-lock (&key name)
1023     (sb-thread:make-mutex :name name))
1024    
1025     (defimplementation call-with-recursive-lock-held (lock function)
1026     (declare (type function function))
1027     (sb-thread:with-recursive-lock (lock) (funcall function)))
1028    
1029 crhodes 1.136 (defimplementation current-thread ()
1030     sb-thread:*current-thread*)
1031    
1032     (defimplementation all-threads ()
1033     (sb-thread:list-all-threads))
1034 jsnellman 1.158
1035 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1036     (sb-thread:interrupt-thread thread fn))
1037    
1038     (defimplementation kill-thread (thread)
1039     (sb-thread:terminate-thread thread))
1040    
1041     (defimplementation thread-alive-p (thread)
1042     (sb-thread:thread-alive-p thread))
1043    
1044     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1045     (defvar *mailboxes* (list))
1046     (declaim (type list *mailboxes*))
1047    
1048 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1049 crhodes 1.136 thread
1050     (mutex (sb-thread:make-mutex))
1051     (waitqueue (sb-thread:make-waitqueue))
1052     (queue '() :type list))
1053    
1054     (defun mailbox (thread)
1055     "Return THREAD's mailbox."
1056     (sb-thread:with-mutex (*mailbox-lock*)
1057     (or (find thread *mailboxes* :key #'mailbox.thread)
1058     (let ((mb (make-mailbox :thread thread)))
1059     (push mb *mailboxes*)
1060     mb))))
1061    
1062     (defimplementation send (thread message)
1063     (let* ((mbox (mailbox thread))
1064     (mutex (mailbox.mutex mbox)))
1065     (sb-thread:with-mutex (mutex)
1066     (setf (mailbox.queue mbox)
1067     (nconc (mailbox.queue mbox) (list message)))
1068     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1069    
1070     (defimplementation receive ()
1071     (let* ((mbox (mailbox (current-thread)))
1072     (mutex (mailbox.mutex mbox)))
1073     (sb-thread:with-mutex (mutex)
1074     (loop
1075     (let ((q (mailbox.queue mbox)))
1076     (cond (q (return (pop (mailbox.queue mbox))))
1077     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1078     mutex))))))))
1079    
1080    
1081 heller 1.160 ;;; Auto-flush streams
1082 lgorrie 1.50
1083 heller 1.147 ;; XXX race conditions
1084     (defvar *auto-flush-streams* '())
1085 jsnellman 1.158
1086 heller 1.147 (defvar *auto-flush-thread* nil)
1087 heller 1.59
1088 heller 1.147 (defimplementation make-stream-interactive (stream)
1089     (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
1090     (unless *auto-flush-thread*
1091     (setq *auto-flush-thread*
1092 jsnellman 1.158 (sb-thread:make-thread #'flush-streams
1093 heller 1.147 :name "auto-flush-thread"))))
1094    
1095     (defun flush-streams ()
1096     (loop
1097 jsnellman 1.158 (setq *auto-flush-streams*
1098     (remove-if (lambda (x)
1099 heller 1.147 (not (and (open-stream-p x)
1100     (output-stream-p x))))
1101     *auto-flush-streams*))
1102     (mapc #'finish-output *auto-flush-streams*)
1103     (sleep 0.15)))
1104 heller 1.59
1105     )
1106 heller 1.126
1107     (defimplementation quit-lisp ()
1108     #+sb-thread
1109     (dolist (thread (remove (current-thread) (all-threads)))
1110 jsnellman 1.158 (ignore-errors (sb-thread:interrupt-thread
1111 heller 1.133 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1112 heller 1.126 (sb-ext:quit))
1113 heller 1.133
1114 mbaringer 1.117
1115 heller 1.118
1116 mbaringer 1.117 ;;Trace implementations
1117     ;;In SBCL, we have:
1118     ;; (trace <name>)
1119 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1120 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1121     ;; <name> can be a normal name or a (setf name)
1122    
1123 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1124 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1125     (eval `(untrace ,fspec))
1126     (format nil "~S is now untraced." fspec))
1127     (t
1128     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1129     (format nil "~S is now traced." fspec))))
1130    
1131     (defun process-fspec (fspec)
1132     (cond ((consp fspec)
1133     (ecase (first fspec)
1134     ((:defun :defgeneric) (second fspec))
1135     ((:defmethod) `(method ,@(rest fspec)))
1136     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1137     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1138     (t
1139     fspec)))
1140    
1141 heller 1.119 (defimplementation toggle-trace (spec)
1142     (ecase (car spec)
1143 jsnellman 1.158 ((setf)
1144 heller 1.119 (toggle-trace-aux spec))
1145     ((:defmethod)
1146     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1147     ((:defgeneric)
1148     (toggle-trace-aux (second spec) :methods t))
1149     ((:call)
1150     (destructuring-bind (caller callee) (cdr spec)
1151     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1152 mkoeppe 1.142
1153     ;;; Weak datastructures
1154    
1155 jsnellman 1.143
1156     ;; SBCL doesn't actually implement weak hash-tables, the WEAK-P
1157     ;; keyword is just a decoy. Leave this here, but commented out,
1158     ;; so that no-one tries adding it back.
1159     #+(or)
1160 mkoeppe 1.142 (defimplementation make-weak-key-hash-table (&rest args)
1161     (apply #'make-hash-table :weak-p t args))
1162    

  ViewVC Help
Powered by ViewVC 1.1.5