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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5