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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.196 - (hide annotations)
Mon May 19 13:12:52 2008 UTC (5 years, 11 months ago) by heller
Branch: MAIN
Changes since 1.195: +16 -4 lines
* swank-sbcl.lisp: Don't require asdf.

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

  ViewVC Help
Powered by ViewVC 1.1.5