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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.236 - (hide annotations)
Sat Mar 7 10:14:42 2009 UTC (5 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.235: +24 -11 lines
	* swank-sbcl.lisp (compiling-from-buffer-p),
	(compiling-from-file-p)
	(compiling-from-generated-code-p): New helpers; extracted from
	LOCATE-COMPILER-NOTE.
	(locate-compiler-note): Use them.
	(compiler-note-location): Use them, too, to handle reader-errors
	when compiling from file. This completes 2009-02-27.

	Reported by Christian Lynbech.
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 trittweiler 1.236 (let* ((stream (stream-error-stream condition))
412     (file (pathname stream)))
413     (unless (open-stream-p stream)
414     (bailout))
415     (if (compiling-from-buffer-p file)
416     (make-location (list :buffer *buffer-name*)
417     (list :offset *buffer-offset*
418     (file-position stream)))
419     (progn
420     (assert (compiling-from-file-p file))
421     (make-location (list :file (namestring file))
422     (list :position (file-position stream)))))))
423 trittweiler 1.235 (t (bailout)))))
424 heller 1.124
425 trittweiler 1.236 (defun compiling-from-buffer-p (filename)
426     (and (not (eq filename :lisp)) *buffer-name*))
427    
428     (defun compiling-from-file-p (filename)
429     (and (pathnamep filename) (null *buffer-name*)))
430    
431     (defun compiling-from-generated-code-p (filename source)
432     (and (eq filename :lisp) (stringp source)))
433    
434 heller 1.127 (defun locate-compiler-note (file source-path source)
435 trittweiler 1.236 (cond ((compiling-from-buffer-p file)
436 heller 1.219 (make-location (list :buffer *buffer-name*)
437     (list :offset *buffer-offset*
438     (source-path-string-position
439     source-path *buffer-substring*))))
440 trittweiler 1.236 ((compiling-from-file-p file)
441 heller 1.124 (make-location (list :file (namestring file))
442 heller 1.219 (list :position (1+ (source-path-file-position
443     source-path file)))))
444 trittweiler 1.236 ((compiling-from-generated-code-p file source)
445 heller 1.127 (make-location (list :source-form source)
446     (list :position 1)))
447 dbarlow 1.42 (t
448 mbaringer 1.165 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
449 dbarlow 1.42
450 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
451 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
452     When Emacs presents the message it already has the source popped up
453     and the source form highlighted. This makes much of the information in
454     the error-context redundant."
455 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
456     (princ-to-string condition)))
457 heller 1.66
458     (defun long-compiler-message-for-emacs (condition error-context)
459     "Describe a compiler error for Emacs including context information."
460 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
461 heller 1.66 (multiple-value-bind (enclosing source)
462     (if error-context
463     (values (sb-c::compiler-error-context-enclosing-source error-context)
464     (sb-c::compiler-error-context-source error-context)))
465 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
466     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
467     enclosing source condition))))
468 dbarlow 1.1
469 heller 1.124 (defun compiler-source-path (context)
470 dbarlow 1.1 "Return the source-path for the current compiler error.
471     Returns NIL if this cannot be determined by examining internal
472     compiler state."
473     (cond ((sb-c::node-p context)
474     (reverse
475     (sb-c::source-path-original-source
476     (sb-c::node-source-path context))))
477     ((sb-c::compiler-error-context-p context)
478     (reverse
479     (sb-c::compiler-error-context-original-source-path context)))))
480    
481 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
482 heller 1.58 (declare (type function function))
483 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
484     (sb-c:compiler-error #'handle-notification-condition)
485 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
486     (warning #'handle-notification-condition))
487     (funcall function)))
488 lgorrie 1.24
489 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
490     "Handle a condition that caused the file compiler to terminate."
491     (handle-notification-condition
492     (sb-int:encapsulated-condition condition)))
493    
494 heller 1.91 (defvar *trap-load-time-warnings* nil)
495    
496 heller 1.232 (defimplementation swank-compile-file (input-file output-file
497     load-p external-format)
498 heller 1.171 (handler-case
499 heller 1.226 (multiple-value-bind (output-file warnings-p failure-p)
500 heller 1.224 (with-compilation-hooks ()
501 heller 1.232 (compile-file input-file :output-file output-file
502     :external-format external-format))
503 heller 1.224 (values output-file warnings-p
504     (or failure-p
505     (when load-p
506     ;; Cache the latest source file for definition-finding.
507 heller 1.232 (source-cache-get input-file
508     (file-write-date input-file))
509 heller 1.224 (not (load output-file))))))
510 heller 1.171 (sb-c:fatal-compiler-error () nil)))
511 lgorrie 1.24
512 heller 1.124 ;;;; compile-string
513    
514 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
515     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
516     ;;; which the previous approach using
517     ;;; (compile nil `(lambda () ,(read-from-string string)))
518     ;;; did not provide.
519    
520     (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
521     (dest (* sb-alien:c-string)))
522    
523     (defun temp-file-name ()
524     "Return a temporary file name to compile strings into."
525     (concatenate 'string (tmpnam nil) ".lisp"))
526    
527 trittweiler 1.228 (defun get-compiler-policy (default-policy)
528     (declare (ignorable default-policy))
529 trittweiler 1.233 #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
530 trittweiler 1.228 (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))
531     :key #'car))
532    
533     (defun set-compiler-policy (policy)
534     (declare (ignorable policy))
535 trittweiler 1.233 #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
536 trittweiler 1.228 (loop for (qual . value) in policy
537     do (sb-ext:restrict-compiler-policy qual value)))
538    
539 heller 1.231 (defimplementation swank-compile-string (string &key buffer position filename
540     policy)
541 heller 1.156 (let ((*buffer-name* buffer)
542     (*buffer-offset* position)
543     (*buffer-substring* string)
544 heller 1.231 (temp-file-name (temp-file-name))
545 trittweiler 1.228 (saved-policy (get-compiler-policy '((debug . 0) (speed . 0)))))
546     (when policy
547     (set-compiler-policy policy))
548 trittweiler 1.200 (flet ((load-it (filename)
549     (when filename (load filename)))
550     (compile-it (cont)
551 heller 1.139 (with-compilation-hooks ()
552 heller 1.156 (with-compilation-unit
553     (:source-plist (list :emacs-buffer buffer
554 heller 1.231 :emacs-filename filename
555 heller 1.156 :emacs-string string
556     :emacs-position position))
557 heller 1.231 (funcall cont (compile-file temp-file-name))))))
558     (with-open-file (s temp-file-name :direction :output :if-exists :error)
559 heller 1.156 (write-string string s))
560     (unwind-protect
561     (if *trap-load-time-warnings*
562 trittweiler 1.200 (compile-it #'load-it)
563     (load-it (compile-it #'identity)))
564 heller 1.156 (ignore-errors
565 trittweiler 1.228 (set-compiler-policy saved-policy)
566 heller 1.231 (delete-file temp-file-name)
567     (delete-file (compile-file-pathname temp-file-name)))))))
568 dbarlow 1.1
569     ;;;; Definitions
570    
571     (defvar *debug-definition-finding* nil
572     "When true don't handle errors while looking for definitions.
573     This is useful when debugging the definition-finding code.")
574    
575 jsnellman 1.149 (defparameter *definition-types*
576     '(:variable defvar
577     :constant defconstant
578     :type deftype
579     :symbol-macro define-symbol-macro
580     :macro defmacro
581     :compiler-macro define-compiler-macro
582     :function defun
583     :generic-function defgeneric
584     :method defmethod
585     :setf-expander define-setf-expander
586     :structure defstruct
587 jsnellman 1.159 :condition define-condition
588 jsnellman 1.149 :class defclass
589     :method-combination define-method-combination
590     :package defpackage
591     :transform :deftransform
592     :optimizer :defoptimizer
593     :vop :define-vop
594     :source-transform :define-source-transform)
595     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
596    
597 trittweiler 1.234 (defun definition-specifier (type name)
598     "Return a pretty specifier for NAME representing a definition of type TYPE."
599     (if (and (symbolp name)
600     (eq type :function)
601     (sb-int:info :function :ir1-convert name))
602     :def-ir1-translator
603     (getf *definition-types* type)))
604    
605    
606 jsnellman 1.149 (defimplementation find-definitions (name)
607     (loop for type in *definition-types* by #'cddr
608     for locations = (sb-introspect:find-definition-sources-by-name
609     name type)
610     append (loop for source-location in locations collect
611     (make-source-location-specification type name
612     source-location))))
613    
614 trittweiler 1.193 (defimplementation find-source-location (obj)
615     (flet ((general-type-of (obj)
616     (typecase obj
617     (method :method)
618     (generic-function :generic-function)
619     (function :function)
620     (structure-class :structure-class)
621     (class :class)
622     (method-combination :method-combination)
623 trittweiler 1.200 (package :package)
624     (condition :condition)
625 trittweiler 1.193 (structure-object :structure-object)
626     (standard-object :standard-object)
627     (t :thing)))
628     (to-string (obj)
629     (typecase obj
630 trittweiler 1.200 (package (princ-to-string obj)) ; Packages are possibly named entities.
631 trittweiler 1.193 ((or structure-object standard-object condition)
632     (with-output-to-string (s)
633     (print-unreadable-object (obj s :type t :identity t))))
634 trittweiler 1.200 (t (princ-to-string obj)))))
635 trittweiler 1.193 (handler-case
636     (make-definition-source-location
637     (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
638     (error (e)
639     (list :error (format nil "Error: ~A" e))))))
640    
641    
642 jsnellman 1.149 (defun make-source-location-specification (type name source-location)
643 trittweiler 1.234 (list (make-dspec type name source-location)
644 jsnellman 1.149 (if *debug-definition-finding*
645     (make-definition-source-location source-location type name)
646 nsiivola 1.176 (handler-case
647     (make-definition-source-location source-location type name)
648 jsnellman 1.149 (error (e)
649 nsiivola 1.176 (list :error (format nil "Error: ~A" e)))))))
650 jsnellman 1.149
651 trittweiler 1.234 (defun make-dspec (type name source-location)
652     (list* (definition-specifier type name)
653     name
654     (sb-introspect::definition-source-description source-location)))
655    
656 jsnellman 1.149 (defun make-definition-source-location (definition-source type name)
657     (with-struct (sb-introspect::definition-source-
658     pathname form-path character-offset plist
659     file-write-date)
660     definition-source
661 nsiivola 1.176 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
662 jsnellman 1.149 emacs-string &allow-other-keys)
663     plist
664     (cond
665     (emacs-buffer
666 nsiivola 1.176 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
667     (pos (if form-path
668 jsnellman 1.172 (with-debootstrapping
669     (source-path-string-position form-path emacs-string))
670     character-offset))
671     (snippet (string-path-snippet emacs-string form-path pos)))
672 jsnellman 1.149 (make-location `(:buffer ,emacs-buffer)
673 heller 1.219 `(:offset ,emacs-position ,pos)
674 jsnellman 1.172 `(:snippet ,snippet))))
675 jsnellman 1.149 ((not pathname)
676 trittweiler 1.192 `(:error ,(format nil "Source definition of ~A ~A not found"
677 jsnellman 1.149 (string-downcase type) name)))
678     (t
679     (let* ((namestring (namestring (translate-logical-pathname pathname)))
680 jsnellman 1.172 (pos (source-file-position namestring file-write-date form-path
681     character-offset))
682     (snippet (source-hint-snippet namestring file-write-date pos)))
683 jsnellman 1.149 (make-location `(:file ,namestring)
684 trittweiler 1.192 ;; /file positions/ in Common Lisp start
685     ;; from 0, in Emacs they start from 1.
686 trittweiler 1.220 `(:position ,(1+ pos))
687 jsnellman 1.149 `(:snippet ,snippet))))))))
688    
689 jsnellman 1.172 (defun string-path-snippet (string form-path position)
690     (if form-path
691     ;; If we have a form-path, use it to derive a more accurate
692     ;; snippet, so that we can point to the individual form rather
693     ;; than just the toplevel form.
694     (multiple-value-bind (data end)
695     (let ((*read-suppress* t))
696     (read-from-string string nil nil :start position))
697     (declare (ignore data))
698     (subseq string position end))
699     string))
700    
701     (defun source-file-position (filename write-date form-path character-offset)
702     (let ((source (get-source-code filename write-date))
703     (*readtable* (guess-readtable-for-filename filename)))
704 trittweiler 1.192 (with-debootstrapping
705     (if form-path
706     (source-path-string-position form-path source)
707     (or character-offset 0)))))
708 jsnellman 1.172
709 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
710     (let ((source (get-source-code filename write-date)))
711     (with-input-from-string (s source)
712     (read-snippet s position))))
713    
714 jsnellman 1.151 (defun function-source-location (function &optional name)
715     (declare (type function function))
716     (let ((location (sb-introspect:find-definition-source function)))
717     (make-definition-source-location location :function name)))
718    
719     (defun safe-function-source-location (fun name)
720     (if *debug-definition-finding*
721     (function-source-location fun name)
722     (handler-case (function-source-location fun name)
723     (error (e)
724     (list :error (format nil "Error: ~A" e))))))
725 heller 1.105
726 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
727 dbarlow 1.1 "Return a plist describing SYMBOL.
728     Return NIL if the symbol is unbound."
729     (let ((result '()))
730 heller 1.133 (flet ((doc (kind)
731     (or (documentation symbol kind) :not-documented))
732     (maybe-push (property value)
733     (when value
734     (setf result (list* property value result)))))
735 dbarlow 1.1 (maybe-push
736     :variable (multiple-value-bind (kind recorded-p)
737     (sb-int:info :variable :kind symbol)
738     (declare (ignore kind))
739     (if (or (boundp symbol) recorded-p)
740     (doc 'variable))))
741 heller 1.133 (when (fboundp symbol)
742     (maybe-push
743     (cond ((macro-function symbol) :macro)
744     ((special-operator-p symbol) :special-operator)
745     ((typep (fdefinition symbol) 'generic-function)
746     :generic-function)
747     (t :function))
748     (doc 'function)))
749 dbarlow 1.1 (maybe-push
750     :setf (if (or (sb-int:info :setf :inverse symbol)
751     (sb-int:info :setf :expander symbol))
752     (doc 'setf)))
753     (maybe-push
754     :type (if (sb-int:info :type :kind symbol)
755     (doc 'type)))
756 lgorrie 1.24 result)))
757 dbarlow 1.1
758 heller 1.74 (defimplementation describe-definition (symbol type)
759 lgorrie 1.54 (case type
760     (:variable
761 heller 1.74 (describe symbol))
762     (:function
763     (describe (symbol-function symbol)))
764 lgorrie 1.54 (:setf
765 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
766     (sb-int:info :setf :expander symbol))))
767 lgorrie 1.54 (:class
768 heller 1.74 (describe (find-class symbol)))
769 lgorrie 1.54 (:type
770 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
771 jsnellman 1.172
772     #+#.(swank-backend::sbcl-with-xref-p)
773     (progn
774     (defmacro defxref (name)
775     `(defimplementation ,name (what)
776     (sanitize-xrefs
777     (mapcar #'source-location-for-xref-data
778     (,(find-symbol (symbol-name name) "SB-INTROSPECT")
779     what)))))
780     (defxref who-calls)
781     (defxref who-binds)
782     (defxref who-sets)
783     (defxref who-references)
784 trittweiler 1.222 (defxref who-macroexpands)
785 trittweiler 1.233 #+#.(swank-backend::with-symbol 'who-specializes 'sb-introspect)
786 trittweiler 1.222 (defxref who-specializes))
787 jsnellman 1.172
788     (defun source-location-for-xref-data (xref-data)
789     (let ((name (car xref-data))
790     (source-location (cdr xref-data)))
791     (list name
792     (handler-case (make-definition-source-location source-location
793     'function
794     name)
795     (error (e)
796     (list :error (format nil "Error: ~A" e)))))))
797 dbarlow 1.1
798 heller 1.97 (defimplementation list-callers (symbol)
799     (let ((fn (fdefinition symbol)))
800 heller 1.168 (sanitize-xrefs
801     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
802 heller 1.97
803     (defimplementation list-callees (symbol)
804     (let ((fn (fdefinition symbol)))
805 heller 1.168 (sanitize-xrefs
806     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
807 heller 1.97
808 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
809 heller 1.168 (remove-duplicates
810     (remove-if (lambda (f)
811     (member f (ignored-xref-function-names)))
812 jsnellman 1.172 (loop for entry in xrefs
813     for name = (car entry)
814     collect (if (and (consp name)
815     (member (car name)
816     '(sb-pcl::fast-method
817     sb-pcl::slow-method
818     sb-pcl::method)))
819     (cons (cons 'defmethod (cdr name))
820     (cdr entry))
821     entry))
822 heller 1.168 :key #'car)
823     :test (lambda (a b)
824     (and (eq (first a) (first b))
825     (equal (second a) (second b))))))
826    
827     (defun ignored-xref-function-names ()
828     #-#.(swank-backend::sbcl-with-new-stepper-p)
829     '(nil sb-c::step-form sb-c::step-values)
830     #+#.(swank-backend::sbcl-with-new-stepper-p)
831     '(nil))
832 jsnellman 1.166
833 lgorrie 1.122 (defun function-dspec (fn)
834     "Describe where the function FN was defined.
835     Return a list of the form (NAME LOCATION)."
836     (let ((name (sb-kernel:%fun-name fn)))
837     (list name (safe-function-source-location fn name))))
838    
839 dbarlow 1.4 ;;; macroexpansion
840 dbarlow 1.1
841 lgorrie 1.54 (defimplementation macroexpand-all (form)
842 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
843     (sb-walker:walk-form form)))
844 lgorrie 1.25
845 dbarlow 1.1
846     ;;; Debugging
847    
848     (defvar *sldb-stack-top*)
849    
850 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
851     #'(lambda (condition old-hook)
852     ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
853     ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
854 trittweiler 1.200 ;; run when it was established locally by a user (i.e. changed meanwhile.)
855 trittweiler 1.194 (if *debugger-hook*
856     (funcall *debugger-hook* condition old-hook)
857     (funcall hook condition old-hook))))
858    
859 heller 1.148 (defimplementation install-debugger-globally (function)
860 trittweiler 1.194 (setq *debugger-hook* function)
861     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
862 heller 1.148
863 jsnellman 1.162 (defimplementation condition-extras (condition)
864 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
865     ((typep condition 'sb-impl::step-form-condition)
866     `((:show-frame-source 0)))
867     ((typep condition 'sb-int:reference-condition)
868     (let ((refs (sb-int:reference-condition-references condition)))
869     (if refs
870     `((:references ,(externalize-reference refs))))))))
871    
872     (defun externalize-reference (ref)
873     (etypecase ref
874     (null nil)
875     (cons (cons (externalize-reference (car ref))
876     (externalize-reference (cdr ref))))
877     ((or string number) ref)
878     (symbol
879     (cond ((eq (symbol-package ref) (symbol-package :test))
880     ref)
881     (t (symbol-name ref))))))
882 jsnellman 1.162
883 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
884 heller 1.58 (declare (type function debugger-loop-fn))
885 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
886 trittweiler 1.199 (sb-debug:*stack-top-hint* nil))
887 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
888 dbarlow 1.1 (lambda (condition)
889 lgorrie 1.25 (signal (make-condition
890     'sldb-condition
891     :original-condition condition)))))
892     (funcall debugger-loop-fn))))
893 dbarlow 1.1
894 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
895     (progn
896     (defimplementation activate-stepping (frame)
897     (declare (ignore frame))
898     (sb-impl::enable-stepping))
899     (defimplementation sldb-stepper-condition-p (condition)
900     (typep condition 'sb-ext:step-form-condition))
901     (defimplementation sldb-step-into ()
902     (invoke-restart 'sb-ext:step-into))
903     (defimplementation sldb-step-next ()
904     (invoke-restart 'sb-ext:step-next))
905     (defimplementation sldb-step-out ()
906     (invoke-restart 'sb-ext:step-out)))
907    
908 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
909 trittweiler 1.194 (let ((*debugger-hook* hook)
910     (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
911 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
912     (sb-ext:*stepper-hook*
913     (lambda (condition)
914 jsnellman 1.164 (typecase condition
915     (sb-ext:step-form-condition
916     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
917     (sb-impl::invoke-debugger condition)))))))
918     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
919     (sb-ext:step-condition #'sb-impl::invoke-stepper))
920 jsnellman 1.163 (funcall fun))))
921 heller 1.118
922 dbarlow 1.1 (defun nth-frame (index)
923     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
924     (i index (1- i)))
925     ((zerop i) frame)))
926    
927 heller 1.74 (defimplementation compute-backtrace (start end)
928 dbarlow 1.1 "Return a list of frames starting with frame number START and
929     continuing to frame number END or, if END is nil, the last frame on the
930     stack."
931     (let ((end (or end most-positive-fixnum)))
932 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
933     for i from start below end
934 heller 1.225 while f collect f)))
935 trittweiler 1.218
936 heller 1.225 (defimplementation print-frame (frame stream)
937     (sb-debug::print-frame-call frame stream))
938 trittweiler 1.218
939 heller 1.225 (defimplementation frame-restartable-p (frame)
940 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
941 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
942 dbarlow 1.1
943 heller 1.124 ;;;; Code-location -> source-location translation
944    
945 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
946     ;;; the source-path for a code-location. If the code was compiled
947     ;;; with C-c C-c, we have to search the position in the source string.
948     ;;; If there's no debug-block info, we return the (less precise)
949     ;;; source-location of the corresponding function.
950    
951 nsiivola 1.134 (defun code-location-source-location (code-location)
952     (let* ((dsource (sb-di:code-location-debug-source code-location))
953     (plist (sb-c::debug-source-plist dsource)))
954     (if (getf plist :emacs-buffer)
955     (emacs-buffer-source-location code-location plist)
956 trittweiler 1.233 #+#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
957 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
958     (:file (file-source-location code-location))
959 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
960 trittweiler 1.233 #-#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
961 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
962     (file-source-location code-location)
963     (lisp-source-location code-location)))))
964 nsiivola 1.134
965     ;;; FIXME: The naming policy of source-location functions is a bit
966     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
967     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
968     ;;; which returns the source location for a _code-location_.
969 jsnellman 1.158 ;;;
970 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
971 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
972     ;;; least the names should indicate the main entry point vs. helper
973     ;;; status.
974 heller 1.124
975 nsiivola 1.134 (defun file-source-location (code-location)
976     (if (code-location-has-debug-block-info-p code-location)
977     (source-file-source-location code-location)
978     (fallback-source-location code-location)))
979    
980     (defun fallback-source-location (code-location)
981     (let ((fun (code-location-debug-fun-fun code-location)))
982     (cond (fun (function-source-location fun))
983 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
984 nsiivola 1.134
985 heller 1.124 (defun lisp-source-location (code-location)
986 jsnellman 1.158 (let ((source (prin1-to-string
987 nsiivola 1.134 (sb-debug::code-location-source-form code-location 100))))
988 heller 1.219 (make-location `(:source-form ,source) '(:position 1))))
989 heller 1.124
990 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
991     (if (code-location-has-debug-block-info-p code-location)
992 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
993     &allow-other-keys)
994     plist
995 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
996     (snipped (with-input-from-string (s emacs-string)
997     (read-snippet s pos))))
998 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
999 heller 1.219 `(:offset ,emacs-position ,pos)
1000 nsiivola 1.134 `(:snippet ,snipped))))
1001     (fallback-source-location code-location)))
1002    
1003 heller 1.124 (defun source-file-source-location (code-location)
1004     (let* ((code-date (code-location-debug-source-created code-location))
1005     (filename (code-location-debug-source-name code-location))
1006 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1007 heller 1.126 (source-code (get-source-code filename code-date)))
1008 jsnellman 1.186 (with-debootstrapping
1009     (with-input-from-string (s source-code)
1010     (let* ((pos (stream-source-position code-location s))
1011     (snippet (read-snippet s pos)))
1012     (make-location `(:file ,filename)
1013 heller 1.219 `(:position ,pos)
1014 jsnellman 1.186 `(:snippet ,snippet)))))))
1015 heller 1.124
1016     (defun code-location-debug-source-name (code-location)
1017 trittweiler 1.233 (namestring (truename (#+#.(swank-backend::with-symbol
1018 trittweiler 1.197 'debug-source-name 'sb-di)
1019     sb-c::debug-source-name
1020 trittweiler 1.233 #-#.(swank-backend::with-symbol
1021 trittweiler 1.197 'debug-source-name 'sb-di)
1022     sb-c::debug-source-namestring
1023 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1024 heller 1.124
1025     (defun code-location-debug-source-created (code-location)
1026 jsnellman 1.158 (sb-c::debug-source-created
1027 heller 1.124 (sb-di::code-location-debug-source code-location)))
1028    
1029     (defun code-location-debug-fun-fun (code-location)
1030     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1031    
1032     (defun code-location-has-debug-block-info-p (code-location)
1033 jsnellman 1.158 (handler-case
1034 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1035     t)
1036     (sb-di:no-debug-blocks () nil)))
1037    
1038     (defun stream-source-position (code-location stream)
1039     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1040 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1041 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1042     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1043     (let* ((path-table (sb-di::form-number-translations tlf 0))
1044 heller 1.128 (path (cond ((<= (length path-table) form-number)
1045 heller 1.129 (warn "inconsistent form-number-translations")
1046 heller 1.128 (list 0))
1047     (t
1048     (reverse (cdr (aref path-table form-number)))))))
1049     (source-path-source-position path tlf pos-map)))))
1050    
1051     (defun string-source-position (code-location string)
1052     (with-input-from-string (s string)
1053     (stream-source-position code-location s)))
1054 dbarlow 1.1
1055 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1056 lgorrie 1.121
1057 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
1058 heller 1.126 (if *debug-definition-finding*
1059     (code-location-source-location code-location)
1060     (handler-case (code-location-source-location code-location)
1061     (error (c) (list :error (format nil "~A" c))))))
1062 jsnellman 1.158
1063 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
1064 jsnellman 1.158 (safe-source-location-for-emacs
1065 heller 1.22 (sb-di:frame-code-location (nth-frame index))))
1066 dbarlow 1.1
1067 heller 1.92 (defun frame-debug-vars (frame)
1068     "Return a vector of debug-variables in frame."
1069     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1070    
1071     (defun debug-var-value (var frame location)
1072     (ecase (sb-di:debug-var-validity var location)
1073     (:valid (sb-di:debug-var-value var frame))
1074     ((:invalid :unknown) ':<not-available>)))
1075    
1076 lgorrie 1.54 (defimplementation frame-locals (index)
1077 dbarlow 1.1 (let* ((frame (nth-frame index))
1078 heller 1.92 (loc (sb-di:frame-code-location frame))
1079     (vars (frame-debug-vars frame)))
1080     (loop for v across vars collect
1081     (list :name (sb-di:debug-var-symbol v)
1082     :id (sb-di:debug-var-id v)
1083     :value (debug-var-value v frame loc)))))
1084    
1085     (defimplementation frame-var-value (frame var)
1086     (let* ((frame (nth-frame frame))
1087     (dvar (aref (frame-debug-vars frame) var)))
1088     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
1089 dbarlow 1.1
1090 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1091 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1092 lgorrie 1.50
1093 heller 1.56 (defimplementation eval-in-frame (form index)
1094     (let ((frame (nth-frame index)))
1095 heller 1.58 (funcall (the function
1096 jsnellman 1.158 (sb-di:preprocess-for-eval form
1097 heller 1.58 (sb-di:frame-code-location frame)))
1098 heller 1.56 frame)))
1099    
1100 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1101     (progn
1102     (defimplementation return-from-frame (index form)
1103     (let* ((frame (nth-frame index)))
1104     (cond ((sb-debug:frame-has-debug-tag-p frame)
1105     (let ((values (multiple-value-list (eval-in-frame form index))))
1106     (sb-debug:unwind-to-frame-and-call frame
1107     (lambda ()
1108     (values-list values)))))
1109     (t (format nil "Cannot return from frame: ~S" frame)))))
1110    
1111     (defimplementation restart-frame (index)
1112     (let* ((frame (nth-frame index)))
1113     (cond ((sb-debug:frame-has-debug-tag-p frame)
1114     (let* ((call-list (sb-debug::frame-call-as-list frame))
1115     (fun (fdefinition (car call-list)))
1116     (thunk (lambda ()
1117     ;; Ensure that the thunk gets tail-call-optimized
1118     (declare (optimize (debug 1)))
1119     (apply fun (cdr call-list)))))
1120     (sb-debug:unwind-to-frame-and-call frame thunk)))
1121     (t (format nil "Cannot restart frame: ~S" frame))))))
1122 heller 1.152
1123     ;; FIXME: this implementation doesn't unwind the stack before
1124     ;; re-invoking the function, but it's better than no implementation at
1125     ;; all.
1126 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1127     (progn
1128     (defun sb-debug-catch-tag-p (tag)
1129     (and (symbolp tag)
1130     (not (symbol-package tag))
1131     (string= tag :sb-debug-catch-tag)))
1132    
1133     (defimplementation return-from-frame (index form)
1134     (let* ((frame (nth-frame index))
1135     (probe (assoc-if #'sb-debug-catch-tag-p
1136     (sb-di::frame-catches frame))))
1137     (cond (probe (throw (car probe) (eval-in-frame form index)))
1138     (t (format nil "Cannot return from frame: ~S" frame)))))
1139    
1140     (defimplementation restart-frame (index)
1141     (let ((frame (nth-frame index)))
1142     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1143 jsnellman 1.158
1144 lgorrie 1.87 ;;;;; reference-conditions
1145    
1146     (defimplementation format-sldb-condition (condition)
1147     (let ((sb-int:*print-condition-references* nil))
1148     (princ-to-string condition)))
1149    
1150 heller 1.57
1151     ;;;; Profiling
1152    
1153     (defimplementation profile (fname)
1154     (when fname (eval `(sb-profile:profile ,fname))))
1155    
1156     (defimplementation unprofile (fname)
1157     (when fname (eval `(sb-profile:unprofile ,fname))))
1158    
1159     (defimplementation unprofile-all ()
1160     (sb-profile:unprofile)
1161     "All functions unprofiled.")
1162    
1163     (defimplementation profile-report ()
1164     (sb-profile:report))
1165    
1166     (defimplementation profile-reset ()
1167     (sb-profile:reset)
1168     "Reset profiling counters.")
1169    
1170     (defimplementation profiled-functions ()
1171     (sb-profile:profile))
1172    
1173 heller 1.116 (defimplementation profile-package (package callers methods)
1174     (declare (ignore callers methods))
1175     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1176    
1177 heller 1.57
1178 heller 1.64 ;;;; Inspector
1179 heller 1.63
1180 heller 1.190 (defmethod emacs-inspect ((o t))
1181 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1182 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1183 heller 1.64 (t
1184 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1185 heller 1.191 (list* (format nil "~a~%" text)
1186     (if label
1187     (loop for (l . v) in parts
1188     append (label-value-line l v))
1189     (loop for value in parts for i from 0
1190     append (label-value-line i value))))))))
1191 heller 1.64
1192 heller 1.190 (defmethod emacs-inspect ((o function))
1193 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1194     (cond ((= header sb-vm:simple-fun-header-widetag)
1195 heller 1.126 (label-value-line*
1196     (:name (sb-kernel:%simple-fun-name o))
1197     (:arglist (sb-kernel:%simple-fun-arglist o))
1198     (:self (sb-kernel:%simple-fun-self o))
1199     (:next (sb-kernel:%simple-fun-next o))
1200     (:type (sb-kernel:%simple-fun-type o))
1201 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1202 heller 1.64 ((= header sb-vm:closure-header-widetag)
1203 jsnellman 1.158 (append
1204 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1205     `("Closed over values:" (:newline))
1206     (loop for i below (1- (sb-kernel:get-closure-length o))
1207 jsnellman 1.158 append (label-value-line
1208 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1209 heller 1.64 (t (call-next-method o)))))
1210    
1211 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1212 jsnellman 1.158 (append
1213     (label-value-line*
1214 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1215     (:entry-points (sb-kernel:%code-entry-points o))
1216     (:debug-info (sb-kernel:%code-debug-info o))
1217 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1218 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1219     `("Constants:" (:newline))
1220 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1221 mbaringer 1.102 below (sb-kernel:get-header-data o)
1222 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1223     `("Code:" (:newline)
1224     , (with-output-to-string (s)
1225     (cond ((sb-kernel:%code-debug-info o)
1226     (sb-disassem:disassemble-code-component o :stream s))
1227     (t
1228 jsnellman 1.158 (sb-disassem:disassemble-memory
1229     (sb-disassem::align
1230 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1231     sb-vm:lowtag-mask)
1232 heller 1.126 (* sb-vm:code-constants-offset
1233     sb-vm:n-word-bytes))
1234 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1235     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1236 heller 1.191 :stream s)))))))
1237 mbaringer 1.102
1238 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1239 mbaringer 1.167 (label-value-line*
1240 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1241 mbaringer 1.167
1242 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1243 heller 1.126 (label-value-line*
1244     (:name (sb-kernel:fdefn-name o))
1245 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1246 mbaringer 1.102
1247 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1248 jsnellman 1.158 (append
1249 heller 1.191 (call-next-method)
1250 heller 1.126 (label-value-line*
1251     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1252     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1253 heller 1.191 )))
1254 heller 1.90
1255 heller 1.63
1256 lgorrie 1.50 ;;;; Multiprocessing
1257    
1258 crhodes 1.136 #+(and sb-thread
1259     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1260     (progn
1261     (defvar *thread-id-counter* 0)
1262 jsnellman 1.158
1263 crhodes 1.136 (defvar *thread-id-counter-lock*
1264     (sb-thread:make-mutex :name "thread id counter lock"))
1265    
1266     (defun next-thread-id ()
1267     (sb-thread:with-mutex (*thread-id-counter-lock*)
1268     (incf *thread-id-counter*)))
1269 jsnellman 1.158
1270 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1271    
1272     ;; This should be a thread -> id map but as weak keys are not
1273     ;; supported it is id -> map instead.
1274     (defvar *thread-id-map-lock*
1275     (sb-thread:make-mutex :name "thread id map lock"))
1276 jsnellman 1.158
1277 crhodes 1.136 (defimplementation spawn (fn &key name)
1278     (sb-thread:make-thread fn :name name))
1279    
1280     (defimplementation thread-id (thread)
1281 heller 1.160 (block thread-id
1282     (sb-thread:with-mutex (*thread-id-map-lock*)
1283     (loop for id being the hash-key in *thread-id-map*
1284     using (hash-value thread-pointer)
1285     do
1286     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1287     (cond ((null maybe-thread)
1288     ;; the value is gc'd, remove it manually
1289     (remhash id *thread-id-map*))
1290     ((eq thread maybe-thread)
1291     (return-from thread-id id)))))
1292     ;; lazy numbering
1293     (let ((id (next-thread-id)))
1294     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1295     id))))
1296 crhodes 1.136
1297     (defimplementation find-thread (id)
1298     (sb-thread:with-mutex (*thread-id-map-lock*)
1299     (let ((thread-pointer (gethash id *thread-id-map*)))
1300     (if thread-pointer
1301     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1302     (if maybe-thread
1303     maybe-thread
1304     ;; the value is gc'd, remove it manually
1305     (progn
1306     (remhash id *thread-id-map*)
1307     nil)))
1308     nil))))
1309 jsnellman 1.158
1310 crhodes 1.136 (defimplementation thread-name (thread)
1311     ;; sometimes the name is not a string (e.g. NIL)
1312     (princ-to-string (sb-thread:thread-name thread)))
1313    
1314     (defimplementation thread-status (thread)
1315     (if (sb-thread:thread-alive-p thread)
1316     "RUNNING"
1317     "STOPPED"))
1318 trittweiler 1.198 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1319     (progn
1320     (defparameter *thread-description-map*
1321     (make-weak-key-hash-table))
1322    
1323     (defvar *thread-descr-map-lock*
1324     (sb-thread:make-mutex :name "thread description map lock"))
1325    
1326     (defimplementation thread-description (thread)
1327     (sb-thread:with-mutex (*thread-descr-map-lock*)
1328 heller 1.208 (or (gethash thread *thread-description-map*)
1329     (short-backtrace thread 6 10))))
1330 trittweiler 1.198
1331     (defimplementation set-thread-description (thread description)
1332     (sb-thread:with-mutex (*thread-descr-map-lock*)
1333 heller 1.208 (setf (gethash thread *thread-description-map*) description)))
1334    
1335     (defun short-backtrace (thread start count)
1336     (let ((self (current-thread))
1337     (tag (get-internal-real-time)))
1338     (sb-thread:interrupt-thread
1339     thread
1340     (lambda ()
1341     (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count))))
1342     (send self (cons tag frames)))))
1343     (handler-case
1344     (sb-ext:with-timeout 0.1
1345     (let ((frames (cdr (receive-if (lambda (msg)
1346     (eq (car msg) tag)))))
1347     (*print-pretty* nil))
1348     (format nil "~{~a~^ <- ~}" (mapcar #'car frames))))
1349     (sb-ext:timeout () ""))))
1350    
1351     )
1352    
1353 crhodes 1.136 (defimplementation make-lock (&key name)
1354     (sb-thread:make-mutex :name name))
1355    
1356     (defimplementation call-with-lock-held (lock function)
1357     (declare (type function function))
1358 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1359    
1360 crhodes 1.136 (defimplementation current-thread ()
1361     sb-thread:*current-thread*)
1362    
1363     (defimplementation all-threads ()
1364     (sb-thread:list-all-threads))
1365 jsnellman 1.158
1366 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1367     (sb-thread:interrupt-thread thread fn))
1368    
1369     (defimplementation kill-thread (thread)
1370     (sb-thread:terminate-thread thread))
1371    
1372     (defimplementation thread-alive-p (thread)
1373     (sb-thread:thread-alive-p thread))
1374    
1375     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1376     (defvar *mailboxes* (list))
1377     (declaim (type list *mailboxes*))
1378    
1379 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1380 crhodes 1.136 thread
1381     (mutex (sb-thread:make-mutex))
1382     (waitqueue (sb-thread:make-waitqueue))
1383     (queue '() :type list))
1384    
1385     (defun mailbox (thread)
1386     "Return THREAD's mailbox."
1387     (sb-thread:with-mutex (*mailbox-lock*)
1388     (or (find thread *mailboxes* :key #'mailbox.thread)
1389     (let ((mb (make-mailbox :thread thread)))
1390     (push mb *mailboxes*)
1391     mb))))
1392    
1393     (defimplementation send (thread message)
1394     (let* ((mbox (mailbox thread))
1395     (mutex (mailbox.mutex mbox)))
1396     (sb-thread:with-mutex (mutex)
1397     (setf (mailbox.queue mbox)
1398     (nconc (mailbox.queue mbox) (list message)))
1399     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1400    
1401 heller 1.212 (defimplementation receive-if (test &optional timeout)
1402 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1403     (mutex (mailbox.mutex mbox)))
1404 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1405 heller 1.207 (loop
1406     (check-slime-interrupts)
1407 heller 1.209 (sb-thread:with-mutex (mutex)
1408 heller 1.202 (let* ((q (mailbox.queue mbox))
1409     (tail (member-if test q)))
1410 heller 1.207 (when tail
1411     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1412     (return (car tail))))
1413 heller 1.212 (when (eq timeout t) (return (values nil t)))
1414 heller 1.217 ;; FIXME: with-timeout doesn't work properly on Darwin
1415     #+linux
1416 heller 1.207 (handler-case (sb-ext:with-timeout 0.2
1417     (sb-thread:condition-wait (mailbox.waitqueue mbox)
1418     mutex))
1419 heller 1.217 (sb-ext:timeout ()))
1420     #-linux
1421     (sb-thread:condition-wait (mailbox.waitqueue mbox)
1422     mutex)))))
1423 heller 1.59 )
1424 heller 1.126
1425     (defimplementation quit-lisp ()
1426     #+sb-thread
1427     (dolist (thread (remove (current-thread) (all-threads)))
1428 jsnellman 1.158 (ignore-errors (sb-thread:interrupt-thread
1429 heller 1.133 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1430 heller 1.126 (sb-ext:quit))
1431 heller 1.133
1432 mbaringer 1.117
1433 heller 1.118
1434 mbaringer 1.117 ;;Trace implementations
1435     ;;In SBCL, we have:
1436     ;; (trace <name>)
1437 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1438 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1439     ;; <name> can be a normal name or a (setf name)
1440    
1441 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1442 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1443     (eval `(untrace ,fspec))
1444     (format nil "~S is now untraced." fspec))
1445     (t
1446     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1447     (format nil "~S is now traced." fspec))))
1448    
1449     (defun process-fspec (fspec)
1450     (cond ((consp fspec)
1451     (ecase (first fspec)
1452     ((:defun :defgeneric) (second fspec))
1453     ((:defmethod) `(method ,@(rest fspec)))
1454     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1455     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1456     (t
1457     fspec)))
1458    
1459 heller 1.119 (defimplementation toggle-trace (spec)
1460     (ecase (car spec)
1461 jsnellman 1.158 ((setf)
1462 heller 1.119 (toggle-trace-aux spec))
1463     ((:defmethod)
1464     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1465     ((:defgeneric)
1466     (toggle-trace-aux (second spec) :methods t))
1467     ((:call)
1468     (destructuring-bind (caller callee) (cdr spec)
1469     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1470 mkoeppe 1.142
1471     ;;; Weak datastructures
1472    
1473 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1474     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1475     (apply #'make-hash-table :weakness :key args)
1476     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1477     (apply #'make-hash-table args))
1478 mkoeppe 1.142
1479 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1480 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1481     (apply #'make-hash-table :weakness :value args)
1482     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1483     (apply #'make-hash-table args))
1484 alendvai 1.173
1485     (defimplementation hash-table-weakness (hashtable)
1486     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1487     (sb-ext:hash-table-weakness hashtable))
1488 heller 1.214
1489     #-win32
1490     (defimplementation save-image (filename &optional restart-function)
1491     (let ((pid (sb-posix:fork)))
1492     (cond ((= pid 0)
1493     (let ((args `(,filename
1494     ,@(if restart-function
1495     `((:toplevel ,restart-function))))))
1496     (apply #'sb-ext:save-lisp-and-die args)))
1497     (t
1498     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1499     (assert (= pid rpid))
1500     (assert (and (sb-posix:wifexited status)
1501 trittweiler 1.234 (zerop (sb-posix:wexitstatus status)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5