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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.235 - (hide annotations)
Thu Feb 26 23:41:41 2009 UTC (5 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.234: +16 -8 lines
	C-c C-c on (defun foo () ,bar) did not result in a compiler note
	overlay on SBCL.

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

  ViewVC Help
Powered by ViewVC 1.1.5