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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5