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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.253 - (hide annotations)
Mon Oct 19 23:23:45 2009 UTC (4 years, 6 months ago) by sboukarev
Branch: MAIN
Changes since 1.252: +3 -37 lines
* swank-sbcl.lisp (thread-description): Remove it and supporting code,
because it didn't really work.

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

  ViewVC Help
Powered by ViewVC 1.1.5