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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5