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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5