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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.192 - (hide annotations)
Thu Feb 28 19:37:57 2008 UTC (6 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.191: +8 -6 lines
This change has been advertized in the Changelog on 2008-02-21.
But it was in fact never committed.


	Fix regressions in the `find-definition' test case on SBCL:

	M-. on e.g. SWANK::READ-FROM-EMACS would bring the user to

	  (|defun read-from-emacs ...)

	and not

	  |(defun read-from-emacs ...)

	* swank-sbcl.lisp (source-file-position): Don't 1+ the returned
	position; i.e. return a position usable as a CL /file position/
	which start from 0, and not a position usable in Emacs where
	buffer points start from 1. This is important because the return
	value is passed to SWANK-BACKEND::READ-SNIPPET which invokes
	CL:FILE-POSITION on it.
	(make-definition-source-location): Adapted to 1+ the position
	passed to Emacs, to reflect above change.
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 trittweiler 1.192 `(:error ,(format nil "Source definition of ~A ~A not found"
529 jsnellman 1.149 (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 trittweiler 1.192 ;; /file positions/ in Common Lisp start
537     ;; from 0, in Emacs they start from 1.
538     `(:position ,(1+ pos))
539 jsnellman 1.149 `(:snippet ,snippet))))))))
540    
541 jsnellman 1.172 (defun string-path-snippet (string form-path position)
542     (if form-path
543     ;; If we have a form-path, use it to derive a more accurate
544     ;; snippet, so that we can point to the individual form rather
545     ;; than just the toplevel form.
546     (multiple-value-bind (data end)
547     (let ((*read-suppress* t))
548     (read-from-string string nil nil :start position))
549     (declare (ignore data))
550     (subseq string position end))
551     string))
552    
553     (defun source-file-position (filename write-date form-path character-offset)
554     (let ((source (get-source-code filename write-date))
555     (*readtable* (guess-readtable-for-filename filename)))
556 trittweiler 1.192 (with-debootstrapping
557     (if form-path
558     (source-path-string-position form-path source)
559     (or character-offset 0)))))
560 jsnellman 1.172
561 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
562     (let ((source (get-source-code filename write-date)))
563     (with-input-from-string (s source)
564     (read-snippet s position))))
565    
566 jsnellman 1.151 (defun function-source-location (function &optional name)
567     (declare (type function function))
568     (let ((location (sb-introspect:find-definition-source function)))
569     (make-definition-source-location location :function name)))
570    
571     (defun safe-function-source-location (fun name)
572     (if *debug-definition-finding*
573     (function-source-location fun name)
574     (handler-case (function-source-location fun name)
575     (error (e)
576     (list :error (format nil "Error: ~A" e))))))
577 heller 1.105
578 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
579 dbarlow 1.1 "Return a plist describing SYMBOL.
580     Return NIL if the symbol is unbound."
581     (let ((result '()))
582 heller 1.133 (flet ((doc (kind)
583     (or (documentation symbol kind) :not-documented))
584     (maybe-push (property value)
585     (when value
586     (setf result (list* property value result)))))
587 dbarlow 1.1 (maybe-push
588     :variable (multiple-value-bind (kind recorded-p)
589     (sb-int:info :variable :kind symbol)
590     (declare (ignore kind))
591     (if (or (boundp symbol) recorded-p)
592     (doc 'variable))))
593 heller 1.133 (when (fboundp symbol)
594     (maybe-push
595     (cond ((macro-function symbol) :macro)
596     ((special-operator-p symbol) :special-operator)
597     ((typep (fdefinition symbol) 'generic-function)
598     :generic-function)
599     (t :function))
600     (doc 'function)))
601 dbarlow 1.1 (maybe-push
602     :setf (if (or (sb-int:info :setf :inverse symbol)
603     (sb-int:info :setf :expander symbol))
604     (doc 'setf)))
605     (maybe-push
606     :type (if (sb-int:info :type :kind symbol)
607     (doc 'type)))
608 lgorrie 1.24 result)))
609 dbarlow 1.1
610 heller 1.74 (defimplementation describe-definition (symbol type)
611 lgorrie 1.54 (case type
612     (:variable
613 heller 1.74 (describe symbol))
614     (:function
615     (describe (symbol-function symbol)))
616 lgorrie 1.54 (:setf
617 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
618     (sb-int:info :setf :expander symbol))))
619 lgorrie 1.54 (:class
620 heller 1.74 (describe (find-class symbol)))
621 lgorrie 1.54 (:type
622 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
623 jsnellman 1.172
624     #+#.(swank-backend::sbcl-with-xref-p)
625     (progn
626     (defmacro defxref (name)
627     `(defimplementation ,name (what)
628     (sanitize-xrefs
629     (mapcar #'source-location-for-xref-data
630     (,(find-symbol (symbol-name name) "SB-INTROSPECT")
631     what)))))
632     (defxref who-calls)
633     (defxref who-binds)
634     (defxref who-sets)
635     (defxref who-references)
636     (defxref who-macroexpands))
637    
638     (defun source-location-for-xref-data (xref-data)
639     (let ((name (car xref-data))
640     (source-location (cdr xref-data)))
641     (list name
642     (handler-case (make-definition-source-location source-location
643     'function
644     name)
645     (error (e)
646     (list :error (format nil "Error: ~A" e)))))))
647 dbarlow 1.1
648 heller 1.97 (defimplementation list-callers (symbol)
649     (let ((fn (fdefinition symbol)))
650 heller 1.168 (sanitize-xrefs
651     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
652 heller 1.97
653     (defimplementation list-callees (symbol)
654     (let ((fn (fdefinition symbol)))
655 heller 1.168 (sanitize-xrefs
656     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
657 heller 1.97
658 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
659 heller 1.168 (remove-duplicates
660     (remove-if (lambda (f)
661     (member f (ignored-xref-function-names)))
662 jsnellman 1.172 (loop for entry in xrefs
663     for name = (car entry)
664     collect (if (and (consp name)
665     (member (car name)
666     '(sb-pcl::fast-method
667     sb-pcl::slow-method
668     sb-pcl::method)))
669     (cons (cons 'defmethod (cdr name))
670     (cdr entry))
671     entry))
672 heller 1.168 :key #'car)
673     :test (lambda (a b)
674     (and (eq (first a) (first b))
675     (equal (second a) (second b))))))
676    
677     (defun ignored-xref-function-names ()
678     #-#.(swank-backend::sbcl-with-new-stepper-p)
679     '(nil sb-c::step-form sb-c::step-values)
680     #+#.(swank-backend::sbcl-with-new-stepper-p)
681     '(nil))
682 jsnellman 1.166
683 lgorrie 1.122 (defun function-dspec (fn)
684     "Describe where the function FN was defined.
685     Return a list of the form (NAME LOCATION)."
686     (let ((name (sb-kernel:%fun-name fn)))
687     (list name (safe-function-source-location fn name))))
688    
689 dbarlow 1.4 ;;; macroexpansion
690 dbarlow 1.1
691 lgorrie 1.54 (defimplementation macroexpand-all (form)
692 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
693     (sb-walker:walk-form form)))
694 lgorrie 1.25
695 dbarlow 1.1
696     ;;; Debugging
697    
698     (defvar *sldb-stack-top*)
699    
700 heller 1.148 (defimplementation install-debugger-globally (function)
701 heller 1.152 (setq sb-ext:*invoke-debugger-hook* function))
702 heller 1.148
703 jsnellman 1.162 (defimplementation condition-extras (condition)
704 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
705     ((typep condition 'sb-impl::step-form-condition)
706     `((:show-frame-source 0)))
707     ((typep condition 'sb-int:reference-condition)
708     (let ((refs (sb-int:reference-condition-references condition)))
709     (if refs
710     `((:references ,(externalize-reference refs))))))))
711    
712     (defun externalize-reference (ref)
713     (etypecase ref
714     (null nil)
715     (cons (cons (externalize-reference (car ref))
716     (externalize-reference (cdr ref))))
717     ((or string number) ref)
718     (symbol
719     (cond ((eq (symbol-package ref) (symbol-package :test))
720     ref)
721     (t (symbol-name ref))))))
722 jsnellman 1.162
723 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
724 heller 1.58 (declare (type function debugger-loop-fn))
725 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
726 heller 1.71 (sb-debug:*stack-top-hint* nil))
727 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
728 dbarlow 1.1 (lambda (condition)
729 lgorrie 1.25 (signal (make-condition
730     'sldb-condition
731     :original-condition condition)))))
732     (funcall debugger-loop-fn))))
733 dbarlow 1.1
734 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
735     (progn
736     (defimplementation activate-stepping (frame)
737     (declare (ignore frame))
738     (sb-impl::enable-stepping))
739     (defimplementation sldb-stepper-condition-p (condition)
740     (typep condition 'sb-ext:step-form-condition))
741     (defimplementation sldb-step-into ()
742     (invoke-restart 'sb-ext:step-into))
743     (defimplementation sldb-step-next ()
744     (invoke-restart 'sb-ext:step-next))
745     (defimplementation sldb-step-out ()
746     (invoke-restart 'sb-ext:step-out)))
747    
748 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
749 jsnellman 1.162 (let ((sb-ext:*invoke-debugger-hook* hook)
750     #+#.(swank-backend::sbcl-with-new-stepper-p)
751     (sb-ext:*stepper-hook*
752     (lambda (condition)
753 jsnellman 1.164 (typecase condition
754     (sb-ext:step-form-condition
755     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
756     (sb-impl::invoke-debugger condition)))))))
757     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
758     (sb-ext:step-condition #'sb-impl::invoke-stepper))
759 jsnellman 1.163 (funcall fun))))
760 heller 1.118
761 dbarlow 1.1 (defun nth-frame (index)
762     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
763     (i index (1- i)))
764     ((zerop i) frame)))
765    
766 heller 1.74 (defimplementation compute-backtrace (start end)
767 dbarlow 1.1 "Return a list of frames starting with frame number START and
768     continuing to frame number END or, if END is nil, the last frame on the
769     stack."
770     (let ((end (or end most-positive-fixnum)))
771 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
772     for i from start below end
773     while f
774 heller 1.74 collect f)))
775 dbarlow 1.1
776 heller 1.74 (defimplementation print-frame (frame stream)
777 nsiivola 1.134 (sb-debug::print-frame-call frame stream))
778 dbarlow 1.1
779 heller 1.124 ;;;; Code-location -> source-location translation
780    
781 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
782     ;;; the source-path for a code-location. If the code was compiled
783     ;;; with C-c C-c, we have to search the position in the source string.
784     ;;; If there's no debug-block info, we return the (less precise)
785     ;;; source-location of the corresponding function.
786    
787 nsiivola 1.134 (defun code-location-source-location (code-location)
788     (let* ((dsource (sb-di:code-location-debug-source code-location))
789     (plist (sb-c::debug-source-plist dsource)))
790     (if (getf plist :emacs-buffer)
791     (emacs-buffer-source-location code-location plist)
792     (ecase (sb-di:debug-source-from dsource)
793     (:file (file-source-location code-location))
794     (:lisp (lisp-source-location code-location))))))
795    
796     ;;; FIXME: The naming policy of source-location functions is a bit
797     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
798     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
799     ;;; which returns the source location for a _code-location_.
800 jsnellman 1.158 ;;;
801 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
802 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
803     ;;; least the names should indicate the main entry point vs. helper
804     ;;; status.
805 heller 1.124
806 nsiivola 1.134 (defun file-source-location (code-location)
807     (if (code-location-has-debug-block-info-p code-location)
808     (source-file-source-location code-location)
809     (fallback-source-location code-location)))
810    
811     (defun fallback-source-location (code-location)
812     (let ((fun (code-location-debug-fun-fun code-location)))
813     (cond (fun (function-source-location fun))
814 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
815 nsiivola 1.134
816 heller 1.124 (defun lisp-source-location (code-location)
817 jsnellman 1.158 (let ((source (prin1-to-string
818 nsiivola 1.134 (sb-debug::code-location-source-form code-location 100))))
819 heller 1.124 (make-location `(:source-form ,source) '(:position 0))))
820    
821 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
822     (if (code-location-has-debug-block-info-p code-location)
823 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
824     &allow-other-keys)
825     plist
826 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
827     (snipped (with-input-from-string (s emacs-string)
828     (read-snippet s pos))))
829 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
830     `(:position ,(+ emacs-position pos))
831 nsiivola 1.134 `(:snippet ,snipped))))
832     (fallback-source-location code-location)))
833    
834 heller 1.124 (defun source-file-source-location (code-location)
835     (let* ((code-date (code-location-debug-source-created code-location))
836     (filename (code-location-debug-source-name code-location))
837 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
838 heller 1.126 (source-code (get-source-code filename code-date)))
839 jsnellman 1.186 (with-debootstrapping
840     (with-input-from-string (s source-code)
841     (let* ((pos (stream-source-position code-location s))
842     (snippet (read-snippet s pos)))
843     (make-location `(:file ,filename)
844     `(:position ,(1+ pos))
845     `(:snippet ,snippet)))))))
846 heller 1.124
847     (defun code-location-debug-source-name (code-location)
848 jsnellman 1.186 (namestring (truename (sb-c::debug-source-name
849     (sb-di::code-location-debug-source code-location)))))
850 heller 1.124
851     (defun code-location-debug-source-created (code-location)
852 jsnellman 1.158 (sb-c::debug-source-created
853 heller 1.124 (sb-di::code-location-debug-source code-location)))
854    
855     (defun code-location-debug-fun-fun (code-location)
856     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
857    
858     (defun code-location-has-debug-block-info-p (code-location)
859 jsnellman 1.158 (handler-case
860 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
861     t)
862     (sb-di:no-debug-blocks () nil)))
863    
864     (defun stream-source-position (code-location stream)
865     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
866 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
867 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
868     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
869     (let* ((path-table (sb-di::form-number-translations tlf 0))
870 heller 1.128 (path (cond ((<= (length path-table) form-number)
871 heller 1.129 (warn "inconsistent form-number-translations")
872 heller 1.128 (list 0))
873     (t
874     (reverse (cdr (aref path-table form-number)))))))
875     (source-path-source-position path tlf pos-map)))))
876    
877     (defun string-source-position (code-location string)
878     (with-input-from-string (s string)
879     (stream-source-position code-location s)))
880 dbarlow 1.1
881 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
882 lgorrie 1.121
883 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
884 heller 1.126 (if *debug-definition-finding*
885     (code-location-source-location code-location)
886     (handler-case (code-location-source-location code-location)
887     (error (c) (list :error (format nil "~A" c))))))
888 jsnellman 1.158
889 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
890 jsnellman 1.158 (safe-source-location-for-emacs
891 heller 1.22 (sb-di:frame-code-location (nth-frame index))))
892 dbarlow 1.1
893 heller 1.92 (defun frame-debug-vars (frame)
894     "Return a vector of debug-variables in frame."
895     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
896    
897     (defun debug-var-value (var frame location)
898     (ecase (sb-di:debug-var-validity var location)
899     (:valid (sb-di:debug-var-value var frame))
900     ((:invalid :unknown) ':<not-available>)))
901    
902 lgorrie 1.54 (defimplementation frame-locals (index)
903 dbarlow 1.1 (let* ((frame (nth-frame index))
904 heller 1.92 (loc (sb-di:frame-code-location frame))
905     (vars (frame-debug-vars frame)))
906     (loop for v across vars collect
907     (list :name (sb-di:debug-var-symbol v)
908     :id (sb-di:debug-var-id v)
909     :value (debug-var-value v frame loc)))))
910    
911     (defimplementation frame-var-value (frame var)
912     (let* ((frame (nth-frame frame))
913     (dvar (aref (frame-debug-vars frame) var)))
914     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
915 dbarlow 1.1
916 lgorrie 1.54 (defimplementation frame-catch-tags (index)
917 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
918 lgorrie 1.50
919 heller 1.56 (defimplementation eval-in-frame (form index)
920     (let ((frame (nth-frame index)))
921 heller 1.58 (funcall (the function
922 jsnellman 1.158 (sb-di:preprocess-for-eval form
923 heller 1.58 (sb-di:frame-code-location frame)))
924 heller 1.56 frame)))
925    
926 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
927     (progn
928     (defimplementation return-from-frame (index form)
929     (let* ((frame (nth-frame index)))
930     (cond ((sb-debug:frame-has-debug-tag-p frame)
931     (let ((values (multiple-value-list (eval-in-frame form index))))
932     (sb-debug:unwind-to-frame-and-call frame
933     (lambda ()
934     (values-list values)))))
935     (t (format nil "Cannot return from frame: ~S" frame)))))
936    
937     (defimplementation restart-frame (index)
938     (let* ((frame (nth-frame index)))
939     (cond ((sb-debug:frame-has-debug-tag-p frame)
940     (let* ((call-list (sb-debug::frame-call-as-list frame))
941     (fun (fdefinition (car call-list)))
942     (thunk (lambda ()
943     ;; Ensure that the thunk gets tail-call-optimized
944     (declare (optimize (debug 1)))
945     (apply fun (cdr call-list)))))
946     (sb-debug:unwind-to-frame-and-call frame thunk)))
947     (t (format nil "Cannot restart frame: ~S" frame))))))
948 heller 1.152
949     ;; FIXME: this implementation doesn't unwind the stack before
950     ;; re-invoking the function, but it's better than no implementation at
951     ;; all.
952 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
953     (progn
954     (defun sb-debug-catch-tag-p (tag)
955     (and (symbolp tag)
956     (not (symbol-package tag))
957     (string= tag :sb-debug-catch-tag)))
958    
959     (defimplementation return-from-frame (index form)
960     (let* ((frame (nth-frame index))
961     (probe (assoc-if #'sb-debug-catch-tag-p
962     (sb-di::frame-catches frame))))
963     (cond (probe (throw (car probe) (eval-in-frame form index)))
964     (t (format nil "Cannot return from frame: ~S" frame)))))
965    
966     (defimplementation restart-frame (index)
967     (let ((frame (nth-frame index)))
968     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
969 jsnellman 1.158
970 lgorrie 1.87 ;;;;; reference-conditions
971    
972     (defimplementation format-sldb-condition (condition)
973     (let ((sb-int:*print-condition-references* nil))
974     (princ-to-string condition)))
975    
976 heller 1.57
977     ;;;; Profiling
978    
979     (defimplementation profile (fname)
980     (when fname (eval `(sb-profile:profile ,fname))))
981    
982     (defimplementation unprofile (fname)
983     (when fname (eval `(sb-profile:unprofile ,fname))))
984    
985     (defimplementation unprofile-all ()
986     (sb-profile:unprofile)
987     "All functions unprofiled.")
988    
989     (defimplementation profile-report ()
990     (sb-profile:report))
991    
992     (defimplementation profile-reset ()
993     (sb-profile:reset)
994     "Reset profiling counters.")
995    
996     (defimplementation profiled-functions ()
997     (sb-profile:profile))
998    
999 heller 1.116 (defimplementation profile-package (package callers methods)
1000     (declare (ignore callers methods))
1001     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1002    
1003 heller 1.57
1004 heller 1.64 ;;;; Inspector
1005 heller 1.63
1006 heller 1.190 (defmethod emacs-inspect ((o t))
1007 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1008 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1009 heller 1.64 (t
1010 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1011 heller 1.191 (list* (format nil "~a~%" text)
1012     (if label
1013     (loop for (l . v) in parts
1014     append (label-value-line l v))
1015     (loop for value in parts for i from 0
1016     append (label-value-line i value))))))))
1017 heller 1.64
1018 heller 1.190 (defmethod emacs-inspect ((o function))
1019 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1020     (cond ((= header sb-vm:simple-fun-header-widetag)
1021 heller 1.126 (label-value-line*
1022     (:name (sb-kernel:%simple-fun-name o))
1023     (:arglist (sb-kernel:%simple-fun-arglist o))
1024     (:self (sb-kernel:%simple-fun-self o))
1025     (:next (sb-kernel:%simple-fun-next o))
1026     (:type (sb-kernel:%simple-fun-type o))
1027 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1028 heller 1.64 ((= header sb-vm:closure-header-widetag)
1029 jsnellman 1.158 (append
1030 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1031     `("Closed over values:" (:newline))
1032     (loop for i below (1- (sb-kernel:get-closure-length o))
1033 jsnellman 1.158 append (label-value-line
1034 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1035 heller 1.64 (t (call-next-method o)))))
1036    
1037 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1038 jsnellman 1.158 (append
1039     (label-value-line*
1040 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1041     (:entry-points (sb-kernel:%code-entry-points o))
1042     (:debug-info (sb-kernel:%code-debug-info o))
1043 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1044 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1045     `("Constants:" (:newline))
1046 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1047 mbaringer 1.102 below (sb-kernel:get-header-data o)
1048 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1049     `("Code:" (:newline)
1050     , (with-output-to-string (s)
1051     (cond ((sb-kernel:%code-debug-info o)
1052     (sb-disassem:disassemble-code-component o :stream s))
1053     (t
1054 jsnellman 1.158 (sb-disassem:disassemble-memory
1055     (sb-disassem::align
1056 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1057     sb-vm:lowtag-mask)
1058 heller 1.126 (* sb-vm:code-constants-offset
1059     sb-vm:n-word-bytes))
1060 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1061     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1062 heller 1.191 :stream s)))))))
1063 mbaringer 1.102
1064 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1065 mbaringer 1.167 (label-value-line*
1066 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1067 mbaringer 1.167
1068 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1069 heller 1.126 (label-value-line*
1070     (:name (sb-kernel:fdefn-name o))
1071 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1072 mbaringer 1.102
1073 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1074 jsnellman 1.158 (append
1075 heller 1.191 (call-next-method)
1076 heller 1.126 (label-value-line*
1077     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1078     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1079 heller 1.191 )))
1080 heller 1.90
1081 heller 1.63
1082 lgorrie 1.50 ;;;; Multiprocessing
1083    
1084 crhodes 1.136 #+(and sb-thread
1085     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1086     (progn
1087     (defvar *thread-id-counter* 0)
1088 jsnellman 1.158
1089 crhodes 1.136 (defvar *thread-id-counter-lock*
1090     (sb-thread:make-mutex :name "thread id counter lock"))
1091    
1092     (defun next-thread-id ()
1093     (sb-thread:with-mutex (*thread-id-counter-lock*)
1094     (incf *thread-id-counter*)))
1095 jsnellman 1.158
1096 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1097    
1098     ;; This should be a thread -> id map but as weak keys are not
1099     ;; supported it is id -> map instead.
1100     (defvar *thread-id-map-lock*
1101     (sb-thread:make-mutex :name "thread id map lock"))
1102 jsnellman 1.158
1103 crhodes 1.136 (defimplementation spawn (fn &key name)
1104     (sb-thread:make-thread fn :name name))
1105    
1106     (defimplementation thread-id (thread)
1107 heller 1.160 (block thread-id
1108     (sb-thread:with-mutex (*thread-id-map-lock*)
1109     (loop for id being the hash-key in *thread-id-map*
1110     using (hash-value thread-pointer)
1111     do
1112     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1113     (cond ((null maybe-thread)
1114     ;; the value is gc'd, remove it manually
1115     (remhash id *thread-id-map*))
1116     ((eq thread maybe-thread)
1117     (return-from thread-id id)))))
1118     ;; lazy numbering
1119     (let ((id (next-thread-id)))
1120     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1121     id))))
1122 crhodes 1.136
1123     (defimplementation find-thread (id)
1124     (sb-thread:with-mutex (*thread-id-map-lock*)
1125     (let ((thread-pointer (gethash id *thread-id-map*)))
1126     (if thread-pointer
1127     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1128     (if maybe-thread
1129     maybe-thread
1130     ;; the value is gc'd, remove it manually
1131     (progn
1132     (remhash id *thread-id-map*)
1133     nil)))
1134     nil))))
1135 jsnellman 1.158
1136 crhodes 1.136 (defimplementation thread-name (thread)
1137     ;; sometimes the name is not a string (e.g. NIL)
1138     (princ-to-string (sb-thread:thread-name thread)))
1139    
1140     (defimplementation thread-status (thread)
1141     (if (sb-thread:thread-alive-p thread)
1142     "RUNNING"
1143     "STOPPED"))
1144    
1145     (defimplementation make-lock (&key name)
1146     (sb-thread:make-mutex :name name))
1147    
1148     (defimplementation call-with-lock-held (lock function)
1149     (declare (type function function))
1150     (sb-thread:with-mutex (lock) (funcall function)))
1151    
1152 nsiivola 1.154 (defimplementation make-recursive-lock (&key name)
1153     (sb-thread:make-mutex :name name))
1154    
1155     (defimplementation call-with-recursive-lock-held (lock function)
1156     (declare (type function function))
1157     (sb-thread:with-recursive-lock (lock) (funcall function)))
1158    
1159 crhodes 1.136 (defimplementation current-thread ()
1160     sb-thread:*current-thread*)
1161    
1162     (defimplementation all-threads ()
1163     (sb-thread:list-all-threads))
1164 jsnellman 1.158
1165 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1166     (sb-thread:interrupt-thread thread fn))
1167    
1168     (defimplementation kill-thread (thread)
1169     (sb-thread:terminate-thread thread))
1170    
1171     (defimplementation thread-alive-p (thread)
1172     (sb-thread:thread-alive-p thread))
1173    
1174     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1175     (defvar *mailboxes* (list))
1176     (declaim (type list *mailboxes*))
1177    
1178 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1179 crhodes 1.136 thread
1180     (mutex (sb-thread:make-mutex))
1181     (waitqueue (sb-thread:make-waitqueue))
1182     (queue '() :type list))
1183    
1184     (defun mailbox (thread)
1185     "Return THREAD's mailbox."
1186     (sb-thread:with-mutex (*mailbox-lock*)
1187     (or (find thread *mailboxes* :key #'mailbox.thread)
1188     (let ((mb (make-mailbox :thread thread)))
1189     (push mb *mailboxes*)
1190     mb))))
1191    
1192     (defimplementation send (thread message)
1193     (let* ((mbox (mailbox thread))
1194     (mutex (mailbox.mutex mbox)))
1195     (sb-thread:with-mutex (mutex)
1196     (setf (mailbox.queue mbox)
1197     (nconc (mailbox.queue mbox) (list message)))
1198     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1199    
1200     (defimplementation receive ()
1201     (let* ((mbox (mailbox (current-thread)))
1202     (mutex (mailbox.mutex mbox)))
1203     (sb-thread:with-mutex (mutex)
1204     (loop
1205     (let ((q (mailbox.queue mbox)))
1206     (cond (q (return (pop (mailbox.queue mbox))))
1207     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1208     mutex))))))))
1209    
1210    
1211 mbaringer 1.178 ;; Auto-flush streams
1212 lgorrie 1.50
1213 mbaringer 1.178 (defvar *auto-flush-interval* 0.15
1214     "How often to flush interactive streams. This valu is passed
1215     directly to cl:sleep.")
1216    
1217     (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
1218 jsnellman 1.158
1219 heller 1.147 (defvar *auto-flush-thread* nil)
1220 heller 1.59
1221 mbaringer 1.178 (defvar *auto-flush-streams* '())
1222    
1223 heller 1.147 (defimplementation make-stream-interactive (stream)
1224 mbaringer 1.178 (call-with-recursive-lock-held
1225     *auto-flush-lock*
1226     (lambda ()
1227     (pushnew stream *auto-flush-streams*)
1228     (unless *auto-flush-thread*
1229     (setq *auto-flush-thread*
1230     (sb-thread:make-thread #'flush-streams
1231     :name "auto-flush-thread"))))))
1232 heller 1.147
1233     (defun flush-streams ()
1234     (loop
1235 mbaringer 1.178 (call-with-recursive-lock-held
1236     *auto-flush-lock*
1237     (lambda ()
1238     (setq *auto-flush-streams*
1239     (remove-if (lambda (x)
1240     (not (and (open-stream-p x)
1241     (output-stream-p x))))
1242     *auto-flush-streams*))
1243     (mapc #'finish-output *auto-flush-streams*)))
1244     (sleep *auto-flush-interval*)))
1245 heller 1.59
1246     )
1247 heller 1.126
1248     (defimplementation quit-lisp ()
1249     #+sb-thread
1250     (dolist (thread (remove (current-thread) (all-threads)))
1251 jsnellman 1.158 (ignore-errors (sb-thread:interrupt-thread
1252 heller 1.133 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1253 heller 1.126 (sb-ext:quit))
1254 heller 1.133
1255 mbaringer 1.117
1256 heller 1.118
1257 mbaringer 1.117 ;;Trace implementations
1258     ;;In SBCL, we have:
1259     ;; (trace <name>)
1260 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1261 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1262     ;; <name> can be a normal name or a (setf name)
1263    
1264 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1265 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1266     (eval `(untrace ,fspec))
1267     (format nil "~S is now untraced." fspec))
1268     (t
1269     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1270     (format nil "~S is now traced." fspec))))
1271    
1272     (defun process-fspec (fspec)
1273     (cond ((consp fspec)
1274     (ecase (first fspec)
1275     ((:defun :defgeneric) (second fspec))
1276     ((:defmethod) `(method ,@(rest fspec)))
1277     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1278     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1279     (t
1280     fspec)))
1281    
1282 heller 1.119 (defimplementation toggle-trace (spec)
1283     (ecase (car spec)
1284 jsnellman 1.158 ((setf)
1285 heller 1.119 (toggle-trace-aux spec))
1286     ((:defmethod)
1287     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1288     ((:defgeneric)
1289     (toggle-trace-aux (second spec) :methods t))
1290     ((:call)
1291     (destructuring-bind (caller callee) (cdr spec)
1292     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1293 mkoeppe 1.142
1294     ;;; Weak datastructures
1295    
1296 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1297     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1298     (apply #'make-hash-table :weakness :key args)
1299     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1300     (apply #'make-hash-table args))
1301 mkoeppe 1.142
1302 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1303 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1304     (apply #'make-hash-table :weakness :value args)
1305     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1306     (apply #'make-hash-table args))
1307 alendvai 1.173
1308     (defimplementation hash-table-weakness (hashtable)
1309     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1310     (sb-ext:hash-table-weakness hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5