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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.284 - (hide annotations)
Thu Jun 16 08:28:45 2011 UTC (2 years, 10 months ago) by nsiivola
Branch: MAIN
Changes since 1.283: +9 -2 lines
sbcl: compiling from buffer tmpfile directory can be a symlink

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

  ViewVC Help
Powered by ViewVC 1.1.5