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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5