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

Diff of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.73.2.1 by heller, Tue Mar 9 08:57:25 2004 UTC revision 1.328 by sboukarev, Sat Feb 2 10:11:16 2013 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;;;; -*- indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank-sbcl.lisp --- SLIME backend for SBCL.  ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4  ;;;  ;;;
5  ;;; Created 2003, Daniel Barlow <dan@metacircles.com>  ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6  ;;;  ;;;
7  ;;; This code has been placed in the Public Domain.  All warranties are  ;;; This code has been placed in the Public Domain.  All warranties are
8  ;;; disclaimed.  ;;; disclaimed.
9    
10  ;;; This is a Slime backend for SBCL.  Requires SBCL 0.8.5 or later  ;;; Requires the SB-INTROSPECT contrib.
 ;;; for the SB-INTROSPECT contrib  
   
 ;;; Cursory testing has found that the following appear to work  
 ;;;  
 ;;; * Symbol completion.  
 ;;; * Evaluation of forms with C-M-x  
 ;;; * Apropos  
 ;;; * Compilation of defuns with C-c C-c  
 ;;; * File compilation with C-c C-k, apparently including error parsing  
 ;;; * Disassembling the symbol at point with C-c M-d  
 ;;; * Describing symbol at point with C-c C-d  
 ;;; * Macroexpanding with C-c RET  
 ;;; * find-definition, using sb-introspect  
 ;;; * Basic debugger stuff: restarts, backtrace, toggle details  
 ;;; * Can now interrupt a busy sbcl with C-c C-g  
 ;;; * Most of the tests  
 ;;;  
 ;;; Things that aren't done/don't work yet:  
 ;;;  
 ;;; * Cross-referencing (nor is it likely, absent XREF port to SBCL)  
 ;;; * testsuite can't find LOOP, reports bogus failure on some arglist lookups  
 ;;; * eval-in-frame  
 ;;; * A slime command to load an asdf system.  Note that this might involve  
 ;;;    compiling/loading files that Emacs has no buffers for  
 ;;; * Dealing with multiple threads  
11    
12  ;;; Administrivia  ;;; Administrivia
13    
14    (in-package :swank-backend)
15    
16  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
17    (require 'sb-bsd-sockets)    (require 'sb-bsd-sockets)
18    (require 'sb-introspect)    (require 'sb-introspect)
19    (require 'sb-posix)    (require 'sb-posix)
20    )    (require 'sb-cltl2)
21      (import-from :sb-gray *gray-stream-symbols* :swank-backend))
22    
23  (declaim (optimize (debug 3)))  (declaim (optimize (debug 2)
24  (in-package :swank-backend)                     (sb-c::insert-step-conditions 0)
25                       (sb-c::insert-debug-catch 0)))
26    
27    ;;; backwards compability tests
28    
29    (eval-when (:compile-toplevel :load-toplevel :execute)
30      ;; Generate a form suitable for testing for stepper support (0.9.17)
31      ;; with #+.
32      (defun sbcl-with-new-stepper-p ()
33        (with-symbol 'enable-stepping 'sb-impl))
34      ;; Ditto for weak hash-tables
35      (defun sbcl-with-weak-hash-tables ()
36        (with-symbol 'hash-table-weakness 'sb-ext))
37      ;; And for xref support (1.0.1)
38      (defun sbcl-with-xref-p ()
39        (with-symbol 'who-calls 'sb-introspect))
40      ;; ... for restart-frame support (1.0.2)
41      (defun sbcl-with-restart-frame ()
42        (with-symbol 'frame-has-debug-tag-p 'sb-debug)))
43    
44    ;;; swank-mop
45    
46  (import  (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
47   '(sb-gray:fundamental-character-output-stream  
48     sb-gray:stream-write-char  (defun swank-mop:slot-definition-documentation (slot)
49     sb-gray:stream-line-length    (sb-pcl::documentation slot t))
50     sb-gray:stream-force-output  
51     sb-gray:fundamental-character-input-stream  ;;; Connection info
52     sb-gray:stream-read-char  
53     sb-gray:stream-listen  (defimplementation lisp-implementation-type-name ()
54     sb-gray:stream-unread-char    "sbcl")
55     sb-gray:stream-clear-input  
56     sb-gray:stream-line-column  ;; Declare return type explicitly to shut up STYLE-WARNINGS about
57     sb-gray:stream-line-length))  ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
58    (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
59    (defimplementation getpid ()
60      (sb-posix:getpid))
61    
62    ;;; UTF8
63    
64    (defimplementation string-to-utf8 (string)
65      (sb-ext:string-to-octets string :external-format :utf8))
66    
67    (defimplementation utf8-to-string (octets)
68      (sb-ext:octets-to-string octets :external-format :utf8))
69    
70  ;;; TCP Server  ;;; TCP Server
71    
72  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
73    :sigio)    (cond
74        ;; fixme: when SBCL/win32 gains better select() support, remove
75        ;; this.
76        ((member :sb-thread *features*) :spawn)
77        ((member :win32 *features*) nil)
78        (t :fd-handler)))
79    
80  (defun resolve-hostname (name)  (defun resolve-hostname (name)
81    (car (sb-bsd-sockets:host-ent-addresses    (car (sb-bsd-sockets:host-ent-addresses
82          (sb-bsd-sockets:get-host-by-name name))))          (sb-bsd-sockets:get-host-by-name name))))
83    
84  (defimplementation create-socket (host port)  (defimplementation create-socket (host port &key backlog)
85    (let ((socket (make-instance 'sb-bsd-sockets:inet-socket    (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
86                                 :type :stream                                 :type :stream
87                                 :protocol :tcp)))                                 :protocol :tcp)))
88      (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)      (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
89      (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)      (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
90      (sb-bsd-sockets:socket-listen socket 5)      (sb-bsd-sockets:socket-listen socket (or backlog 5))
91      socket))      socket))
92    
93  (defimplementation local-port (socket)  (defimplementation local-port (socket)
94    (nth-value 1 (sb-bsd-sockets:socket-name socket)))    (nth-value 1 (sb-bsd-sockets:socket-name socket)))
95    
96  (defimplementation close-socket (socket)  (defimplementation close-socket (socket)
97      (sb-sys:invalidate-descriptor (socket-fd socket))
98    (sb-bsd-sockets:socket-close socket))    (sb-bsd-sockets:socket-close socket))
99    
100  (defimplementation accept-connection (socket)  (defimplementation accept-connection (socket &key
101    (make-socket-io-stream (accept socket)))                                        external-format
102                                          buffering timeout)
103      (declare (ignore timeout))
104      (make-socket-io-stream (accept socket) external-format
105                             (ecase buffering
106                               ((t :full) :full)
107                               ((nil :none) :none)
108                               ((:line) :line))))
109    
110    #-win32
111    (defimplementation install-sigint-handler (function)
112      (sb-sys:enable-interrupt sb-unix:sigint
113                               (lambda (&rest args)
114                                 (declare (ignore args))
115                                 (sb-sys:invoke-interruption
116                                  (lambda ()
117                                    (sb-sys:with-interrupts
118                                      (funcall function)))))))
119    
120  (defvar *sigio-handlers* '()  (defvar *sigio-handlers* '()
121    "List of (key . fn) pairs to be called on SIGIO.")    "List of (key . fn) pairs to be called on SIGIO.")
# Line 95  Line 127 
127          *sigio-handlers*))          *sigio-handlers*))
128    
129  (defun set-sigio-handler ()  (defun set-sigio-handler ()
130    (sb-sys:enable-interrupt sb-unix:SIGIO (lambda (signal code scp)    (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
131                                             (sigio-handler signal code scp))))                                             (sigio-handler signal code scp))))
132    
   
   
 ;;;; XXX remove fcntl kludge when SBCL with sb-posix:fcntl is more  
 ;;;; widely available.  
 (defconstant +o_async+ 8192)  
 (defconstant +f_setown+ 8)  
 (defconstant +f_setfl+ 4)  
   
 (unless (find-symbol (string :fcntl) :sb-posix)  
   (warn "No binding for fctnl(2) in sb-posix.  
 Please upgrade to SBCL 0.8.7.36 or later."))  
   
133  (defun enable-sigio-on-fd (fd)  (defun enable-sigio-on-fd (fd)
134    (cond ((fboundp (find-symbol (string :fcntl) :sb-posix))    (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
135           (funcall    (sb-posix::fcntl fd sb-posix::f-setown (getpid))
136            (eval    (values))
            (read-from-string  
             "(lambda (fd)  
              (sb-posix:fcntl fd sb-posix::f-setfl sb-posix::o-async)  
              (sb-posix:fcntl fd sb-posix::f-setown (sb-unix:unix-getpid)))"))  
           fd))  
         (t  
          (unless (sb-int:featurep :linux)  
            (warn "~  
 You aren't running Linux. The values of +o_async+ etc are probably bogus."))  
          (let ((fcntl (sb-alien:extern-alien  
                        "fcntl"  
                        (function sb-alien:int sb-alien:int  
                                  sb-alien:int sb-alien:int))))  
            ;; XXX error checking  
            (sb-alien:alien-funcall fcntl fd +f_setfl+ +o_async+)  
            (sb-alien:alien-funcall fcntl fd +f_setown+  
                                    (sb-unix:unix-getpid))))))  
137    
138  (defimplementation add-sigio-handler (socket fn)  (defimplementation add-sigio-handler (socket fn)
139    (set-sigio-handler)    (set-sigio-handler)
140    (let ((fd (socket-fd socket)))    (let ((fd (socket-fd socket)))
     (format *debug-io* "Adding sigio handler: ~S ~%" fd)  
141      (enable-sigio-on-fd fd)      (enable-sigio-on-fd fd)
142      (push (cons fd fn) *sigio-handlers*)))      (push (cons fd fn) *sigio-handlers*)))
143    
 #+(or)  
 (defimplementation add-sigio-handler (socket fn)  
   (set-sigio-handler)  
   (let ((fd (socket-fd socket)))  
     (format *debug-io* "Adding sigio handler: ~S ~%" fd)  
     (sb-posix:fcntl fd sb-posix::f-setfl sb-posix::o-async)  
     (sb-posix:fcntl fd sb-posix::f-setown (sb-unix:unix-getpid))  
     (push (cons fd fn) *sigio-handlers*)))  
   
144  (defimplementation remove-sigio-handlers (socket)  (defimplementation remove-sigio-handlers (socket)
145    (let ((fd (socket-fd socket)))    (let ((fd (socket-fd socket)))
146      (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))      (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
147      (sb-sys:invalidate-descriptor fd))      (sb-sys:invalidate-descriptor fd))
148    (close socket))    (close socket))
149    
150  (defimplementation add-fd-handler (socket fn)  (defimplementation add-fd-handler (socket fun)
151    (declare (type function fn))    (let ((fd (socket-fd socket))
152    (let ((fd (socket-fd socket)))          (handler nil))
153      (format *debug-io* "; Adding fd handler: ~S ~%" fd)      (labels ((add ()
154      (sb-sys:add-fd-handler fd :input (lambda (_)                 (setq handler (sb-sys:add-fd-handler fd :input #'run)))
155                                         _               (run (fd)
156                                         (funcall fn)))))                 (sb-sys:remove-fd-handler handler) ; prevent recursion
157                   (unwind-protect
158                        (funcall fun)
159                     (when (sb-unix:unix-fstat fd) ; still open?
160                       (add)))))
161          (add))))
162    
163  (defimplementation remove-fd-handlers (socket)  (defimplementation remove-fd-handlers (socket)
164    (sb-sys:invalidate-descriptor (socket-fd socket)))    (sb-sys:invalidate-descriptor (socket-fd socket)))
165    
166  (defun socket-fd (socket)  (defimplementation socket-fd (socket)
167    (etypecase socket    (etypecase socket
168      (fixnum socket)      (fixnum socket)
169      (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))      (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
170      (file-stream (sb-sys:fd-stream-fd socket))))      (file-stream (sb-sys:fd-stream-fd socket))))
171    
172  (defun make-socket-io-stream (socket)  (defimplementation command-line-args ()
173    (sb-bsd-sockets:socket-make-stream socket    sb-ext:*posix-argv*)
174                                       :output t  
175                                       :input t  (defimplementation dup (fd)
176                                       :element-type 'base-char))    (sb-posix:dup fd))
177    
178    (defvar *wait-for-input-called*)
179    
180    (defimplementation wait-for-input (streams &optional timeout)
181      (assert (member timeout '(nil t)))
182      (when (boundp '*wait-for-input-called*)
183        (setq *wait-for-input-called* t))
184      (let ((*wait-for-input-called* nil))
185        (loop
186          (let ((ready (remove-if-not #'input-ready-p streams)))
187            (when ready (return ready)))
188          (when (check-slime-interrupts)
189            (return :interrupt))
190          (when *wait-for-input-called*
191            (return :interrupt))
192          (when timeout
193            (return nil))
194          (sleep 0.1))))
195    
196    (defun fd-stream-input-buffer-empty-p (stream)
197      (let ((buffer (sb-impl::fd-stream-ibuf stream)))
198        (or (not buffer)
199            (= (sb-impl::buffer-head buffer)
200               (sb-impl::buffer-tail buffer)))))
201    
202    #-win32
203    (defun input-ready-p (stream)
204      (or (not (fd-stream-input-buffer-empty-p stream))
205          #+#.(swank-backend:with-symbol 'fd-stream-fd-type 'sb-impl)
206          (eq :regular (sb-impl::fd-stream-fd-type stream))
207          (not (sb-impl::sysread-may-block-p stream))))
208    
209    #+win32
210    (progn
211      (defun input-ready-p (stream)
212        (or (not (fd-stream-input-buffer-empty-p stream))
213            (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
214    
215      (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
216          sb-win32:handle)
217    
218      (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
219          sb-alien:int
220        (event sb-win32:handle))
221    
222      (defconstant +fd-read+ #.(ash 1 0))
223      (defconstant +fd-close+ #.(ash 1 5))
224    
225      (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
226          sb-alien:int
227        (fd sb-alien:int)
228        (handle sb-win32:handle)
229        (mask sb-alien:long))
230    
231      (sb-alien:load-shared-object "kernel32.dll")
232      (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
233                                      wait-for-single-object-ex)
234          sb-alien:int
235        (event sb-win32:handle)
236        (milliseconds sb-alien:long)
237        (alertable sb-alien:int))
238    
239      ;; see SB-WIN32:HANDLE-LISTEN
240      (defun handle-listen (handle)
241        (sb-alien:with-alien ((avail sb-win32:dword)
242                              (buf (array char #.sb-win32::input-record-size)))
243          (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
244                                                   (sb-alien:alien-sap
245                                                    (sb-alien:addr avail))
246                                                   nil))
247            (return-from handle-listen (plusp avail)))
248    
249          (unless (zerop (sb-win32:peek-console-input handle
250                                                      (sb-alien:alien-sap buf)
251                                                      sb-win32::input-record-size
252                                                      (sb-alien:alien-sap
253                                                       (sb-alien:addr avail))))
254            (return-from handle-listen (plusp avail))))
255    
256        (let ((event (wsa-create-event)))
257          (wsa-event-select handle event (logior +fd-read+ +fd-close+))
258          (let ((val (wait-for-single-object-ex event 0 0)))
259            (wsa-close-event event)
260            (unless (= val -1)
261              (return-from handle-listen (zerop val)))))
262    
263        nil)
264    
265      )
266    
267    (defvar *external-format-to-coding-system*
268      '((:iso-8859-1
269         "latin-1" "latin-1-unix" "iso-latin-1-unix"
270         "iso-8859-1" "iso-8859-1-unix")
271        (:utf-8 "utf-8" "utf-8-unix")
272        (:euc-jp "euc-jp" "euc-jp-unix")
273        (:us-ascii "us-ascii" "us-ascii-unix")))
274    
275    ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
276    ;; 2008-08-22.
277    (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
278    
279    (defimplementation filename-to-pathname (filename)
280      (sb-ext:parse-native-namestring filename *physical-pathname-host*))
281    
282    (defimplementation find-external-format (coding-system)
283      (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
284                      *external-format-to-coding-system*)))
285    
286    (defun make-socket-io-stream (socket external-format buffering)
287      (let ((args `(,@()
288                    :output t
289                    :input t
290                    :element-type ,(if external-format
291                                       'character
292                                       '(unsigned-byte 8))
293                    :buffering ,buffering
294                    ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
295                             `(:external-format ,external-format))
296                            (t '()))
297                    :serve-events ,(eq :fd-handler
298                                       (swank-value '*communication-style* t))
299                      ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
300                      ;; argument.
301                    :allow-other-keys t)))
302      (apply #'sb-bsd-sockets:socket-make-stream socket args)))
303    
304  (defun accept (socket)  (defun accept (socket)
305    "Like socket-accept, but retry on EAGAIN."    "Like socket-accept, but retry on EAGAIN."
# Line 183  You aren't running Linux. The values of Line 307  You aren't running Linux. The values of
307              (return (sb-bsd-sockets:socket-accept socket))              (return (sb-bsd-sockets:socket-accept socket))
308            (sb-bsd-sockets:interrupted-error ()))))            (sb-bsd-sockets:interrupted-error ()))))
309    
310  (defmethod call-without-interrupts (fn)  
311    (declare (type function fn))  ;;;; Support for SBCL syntax
   (sb-sys:without-interrupts (funcall fn)))  
312    
313  (defmethod getpid ()  ;;; SBCL's source code is riddled with #! reader macros.  Also symbols
314    (sb-unix:unix-getpid))  ;;; containing `!' have special meaning.  We have to work long and
315    ;;; hard to be able to read the source.  To deal with #! reader
316    ;;; macros, we use a special readtable.  The special symbols are
317    ;;; converted by a condition handler.
318    
319    (defun feature-in-list-p (feature list)
320      (etypecase feature
321        (symbol (member feature list :test #'eq))
322        (cons (flet ((subfeature-in-list-p (subfeature)
323                       (feature-in-list-p subfeature list)))
324                (ecase (first feature)
325                  (:or  (some  #'subfeature-in-list-p (rest feature)))
326                  (:and (every #'subfeature-in-list-p (rest feature)))
327                  (:not (destructuring-bind (e) (cdr feature)
328                          (not (subfeature-in-list-p e)))))))))
329    
330    (defun shebang-reader (stream sub-character infix-parameter)
331      (declare (ignore sub-character))
332      (when infix-parameter
333        (error "illegal read syntax: #~D!" infix-parameter))
334      (let ((next-char (read-char stream)))
335        (unless (find next-char "+-")
336          (error "illegal read syntax: #!~C" next-char))
337        ;; When test is not satisfied
338        ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
339        ;; would become "unless test is satisfied"..
340        (when (let* ((*package* (find-package "KEYWORD"))
341                     (*read-suppress* nil)
342                     (not-p (char= next-char #\-))
343                     (feature (read stream)))
344                (if (feature-in-list-p feature *features*)
345                    not-p
346                    (not not-p)))
347          ;; Read (and discard) a form from input.
348          (let ((*read-suppress* t))
349            (read stream t nil t))))
350     (values))
351    
352    (defvar *shebang-readtable*
353      (let ((*readtable* (copy-readtable nil)))
354        (set-dispatch-macro-character #\# #\!
355                                      (lambda (s c n) (shebang-reader s c n))
356                                      *readtable*)
357        *readtable*))
358    
359    (defun shebang-readtable ()
360      *shebang-readtable*)
361    
362    (defun sbcl-package-p (package)
363      (let ((name (package-name package)))
364        (eql (mismatch "SB-" name) 3)))
365    
366    (defun sbcl-source-file-p (filename)
367      (when filename
368        (loop for (nil pattern) in (logical-pathname-translations "SYS")
369              thereis (pathname-match-p filename pattern))))
370    
371    (defun guess-readtable-for-filename (filename)
372      (if (sbcl-source-file-p filename)
373          (shebang-readtable)
374          *readtable*))
375    
376    (defvar *debootstrap-packages* t)
377    
378    (defun call-with-debootstrapping (fun)
379      (handler-bind ((sb-int:bootstrap-package-not-found
380                      #'sb-int:debootstrap-package))
381        (funcall fun)))
382    
383    (defmacro with-debootstrapping (&body body)
384      `(call-with-debootstrapping (lambda () ,@body)))
385    
386    (defimplementation call-with-syntax-hooks (fn)
387      (cond ((and *debootstrap-packages*
388                  (sbcl-package-p *package*))
389             (with-debootstrapping (funcall fn)))
390            (t
391             (funcall fn))))
392    
393  (defimplementation lisp-implementation-type-name ()  (defimplementation default-readtable-alist ()
394    "sbcl")    (let ((readtable (shebang-readtable)))
395        (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
396              collect (cons (package-name p) readtable))))
397    
398  ;;; Utilities  ;;; Utilities
399    
400  (defvar *swank-debugger-stack-frame*)  (defun swank-value (name &optional errorp)
401      ;; Easy way to refer to symbol values in SWANK, which doesn't yet exist when
402      ;; this is file is loaded.
403      (let ((symbol (find-symbol (string name) :swank)))
404        (if (and symbol (or errorp (boundp symbol)))
405            (symbol-value symbol)
406            (when errorp
407              (error "~S does not exist in SWANK." name)))))
408    
409    #+#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
410    (defimplementation arglist (fname)
411      (sb-introspect:function-lambda-list fname))
412    
413    #-#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
414  (defimplementation arglist (fname)  (defimplementation arglist (fname)
415    (sb-introspect:function-arglist fname))    (sb-introspect:function-arglist fname))
416    
417    (defimplementation function-name (f)
418      (check-type f function)
419      (sb-impl::%fun-name f))
420    
421    (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
422      (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
423        (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
424          (if flags
425              ;; Symbols aren't printed with package qualifiers, but the
426              ;; FLAGS would have to be fully qualified when used inside a
427              ;; declaration. So we strip those as long as there's no
428              ;; better way. (FIXME)
429              `(&any ,@(remove-if-not
430                        #'(lambda (qualifier)
431                            (find-symbol (symbol-name (first qualifier)) :cl))
432                        flags :key #'ensure-list))
433              (call-next-method)))))
434    
435    #+#.(swank-backend:with-symbol 'deftype-lambda-list 'sb-introspect)
436    (defmethod type-specifier-arglist :around (typespec-operator)
437      (multiple-value-bind (arglist foundp)
438          (sb-introspect:deftype-lambda-list typespec-operator)
439        (if foundp arglist (call-next-method))))
440    
441    (defimplementation type-specifier-p (symbol)
442      (or (sb-ext:valid-type-specifier-p symbol)
443          (not (eq (type-specifier-arglist symbol) :not-available))))
444    
445  (defvar *buffer-name* nil)  (defvar *buffer-name* nil)
446    (defvar *buffer-tmpfile* nil)
447  (defvar *buffer-offset*)  (defvar *buffer-offset*)
448  (defvar *buffer-substring* nil)  (defvar *buffer-substring* nil)
449    
# Line 213  This traps all compiler conditions at a Line 456  This traps all compiler conditions at a
456  C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to  C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
457  craft our own error messages, which can omit a lot of redundant  craft our own error messages, which can omit a lot of redundant
458  information."  information."
459    (let ((context (sb-c::find-error-context nil)))    (unless (or (eq condition *previous-compiler-condition*))
460      (unless (eq condition *previous-compiler-condition*)      ;; First resignal warnings, so that outer handlers -- which may choose to
461        (setq *previous-compiler-condition* condition)      ;; muffle this -- get a chance to run.
462        (signal-compiler-condition condition context))))      (when (typep condition 'warning)
463          (signal condition))
464        (setq *previous-compiler-condition* condition)
465        (signal-compiler-condition (real-condition condition)
466                                   (sb-c::find-error-context nil))))
467    
468  (defun signal-compiler-condition (condition context)  (defun signal-compiler-condition (condition context)
469    (signal (make-condition    (signal 'compiler-condition
470             'compiler-condition            :original-condition condition
471             :original-condition condition            :severity (etypecase condition
472             :severity (etypecase condition                        (sb-ext:compiler-note :note)
473                         (sb-c:compiler-error  :error)                        (sb-c:compiler-error  :error)
474                         (sb-ext:compiler-note :note)                        (reader-error         :read-error)
475                         (style-warning        :style-warning)                        (error                :error)
476                         (warning              :warning))                        #+#.(swank-backend:with-symbol redefinition-warning
477             :short-message (brief-compiler-message-for-emacs condition)                              sb-kernel)
478             :message (long-compiler-message-for-emacs condition context)                        (sb-kernel:redefinition-warning
479             :location (compiler-note-location context))))                         :redefinition)
480                          (style-warning        :style-warning)
481                          (warning              :warning))
482              :references (condition-references condition)
483  (defun compiler-note-location (context)            :message (brief-compiler-message-for-emacs condition)
484    (cond (context            :source-context (compiler-error-context context)
485           (resolve-note-location            :location (compiler-note-location condition context)))
486            *buffer-name*  
487            (sb-c::compiler-error-context-file-name context)  (defun real-condition (condition)
488            (sb-c::compiler-error-context-file-position context)    "Return the encapsulated condition or CONDITION itself."
489            (current-compiler-error-source-path context)    (typecase condition
490            (sb-c::compiler-error-context-original-source  context)))      (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
491        (t condition)))
492    
493    (defun condition-references (condition)
494      (if (typep condition 'sb-int:reference-condition)
495          (externalize-reference
496           (sb-int:reference-condition-references condition))))
497    
498    (defun compiler-note-location (condition context)
499      (flet ((bailout ()
500               (return-from compiler-note-location
501                 (make-error-location "No error location available"))))
502        (cond (context
503               (locate-compiler-note
504                (sb-c::compiler-error-context-file-name context)
505                (compiler-source-path context)
506                (sb-c::compiler-error-context-original-source context)))
507              ((typep condition 'reader-error)
508               (let* ((stream (stream-error-stream condition))
509                      (file   (pathname stream)))
510                 (unless (open-stream-p stream)
511                   (bailout))
512                 (if (compiling-from-buffer-p file)
513                     ;; The stream position for e.g. "comma not inside
514                     ;; backquote" is at the character following the
515                     ;; comma, :offset is 0-based, hence the 1-.
516                     (make-location (list :buffer *buffer-name*)
517                                    (list :offset *buffer-offset*
518                                          (1- (file-position stream))))
519                     (progn
520                       (assert (compiling-from-file-p file))
521                       ;; No 1- because :position is 1-based.
522                       (make-location (list :file (namestring file))
523                                      (list :position (file-position stream)))))))
524              (t (bailout)))))
525    
526    (defun compiling-from-buffer-p (filename)
527      (and *buffer-name*
528           ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
529           ;; in LOCATE-COMPILER-NOTE, and allows handling nested
530           ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
531           ;;
532           ;; PROBE-FILE to handle tempfile directory being a symlink.
533           (pathnamep filename)
534           (let ((true1 (probe-file filename))
535                 (true2 (probe-file *buffer-tmpfile*)))
536             (and true1 (equal true1 true2)))))
537    
538    (defun compiling-from-file-p (filename)
539      (and (pathnamep filename)
540           (or (null *buffer-name*)
541               (null *buffer-tmpfile*)
542               (let ((true1 (probe-file filename))
543                     (true2 (probe-file *buffer-tmpfile*)))
544                 (not (and true1 (equal true1 true2)))))))
545    
546    (defun compiling-from-generated-code-p (filename source)
547      (and (eq filename :lisp) (stringp source)))
548    
549    (defun locate-compiler-note (file source-path source)
550      (cond ((compiling-from-buffer-p file)
551             (make-location (list :buffer *buffer-name*)
552                            (list :offset  *buffer-offset*
553                                  (source-path-string-position
554                                   source-path *buffer-substring*))))
555            ((compiling-from-file-p file)
556             (make-location (list :file (namestring file))
557                            (list :position (1+ (source-path-file-position
558                                                 source-path file)))))
559            ((compiling-from-generated-code-p file source)
560             (make-location (list :source-form source)
561                            (list :position 1)))
562          (t          (t
563           (resolve-note-location *buffer-name* nil nil nil nil))))           (error "unhandled case in compiler note ~S ~S ~S"
564                    file source-path source))))
 (defgeneric resolve-note-location (buffer file-name file-position  
                                           source-path source))  
   
 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)  
   (make-location  
    `(:file ,(namestring (truename f)))  
    `(:position ,(1+ (source-path-file-position path f)))))  
   
 (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)  
   (make-location  
    `(:buffer ,b)  
    `(:position ,(+ *buffer-offset*  
                    (source-path-string-position path *buffer-substring*)))))  
   
 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))  
   (make-location  
    `(:source-form ,source)  
    `(:position 1)))  
   
 (defmethod resolve-note-location (buffer  
                                   (file (eql nil))  
                                   (pos (eql nil))  
                                   (path (eql nil))  
                                   (source (eql nil)))  
   (cond (buffer  
          (make-location (list :buffer buffer)  
                         (list :position *buffer-offset*)))  
         (*compile-file-truename*  
          (make-location (list :file (namestring *compile-file-truename*))  
                         (list :position 0)))  
         (t  
          (list :error "No error location available"))))  
565    
566  (defun brief-compiler-message-for-emacs (condition)  (defun brief-compiler-message-for-emacs (condition)
567    "Briefly describe a compiler error for Emacs.    "Briefly describe a compiler error for Emacs.
568  When Emacs presents the message it already has the source popped up  When Emacs presents the message it already has the source popped up
569  and the source form highlighted. This makes much of the information in  and the source form highlighted. This makes much of the information in
570  the error-context redundant."  the error-context redundant."
571    (princ-to-string condition))    (let ((sb-int:*print-condition-references* nil))
572        (princ-to-string condition)))
573    
574  (defun long-compiler-message-for-emacs (condition error-context)  (defun compiler-error-context (error-context)
575    "Describe a compiler error for Emacs including context information."    "Describe a compiler error for Emacs including context information."
576    (declare (type (or sb-c::compiler-error-context null) error-context))    (declare (type (or sb-c::compiler-error-context null) error-context))
577    (multiple-value-bind (enclosing source)    (multiple-value-bind (enclosing source)
578        (if error-context        (if error-context
579            (values (sb-c::compiler-error-context-enclosing-source error-context)            (values (sb-c::compiler-error-context-enclosing-source error-context)
580                    (sb-c::compiler-error-context-source error-context)))                    (sb-c::compiler-error-context-source error-context)))
581      (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"      (and (or enclosing source)
582              enclosing source condition)))           (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
583                     enclosing source))))
584    
585  (defun current-compiler-error-source-path (context)  (defun compiler-source-path (context)
586    "Return the source-path for the current compiler error.    "Return the source-path for the current compiler error.
587  Returns NIL if this cannot be determined by examining internal  Returns NIL if this cannot be determined by examining internal
588  compiler state."  compiler state."
# Line 308  compiler state." Line 596  compiler state."
596    
597  (defimplementation call-with-compilation-hooks (function)  (defimplementation call-with-compilation-hooks (function)
598    (declare (type function function))    (declare (type function function))
599    (handler-bind ((sb-c:compiler-error  #'handle-notification-condition)    (handler-bind
600                   (sb-ext:compiler-note #'handle-notification-condition)        ;; N.B. Even though these handlers are called HANDLE-FOO they
601                   (style-warning        #'handle-notification-condition)        ;; actually decline, i.e. the signalling of the original
602                   (warning              #'handle-notification-condition))        ;; condition continues upward.
603          ((sb-c:fatal-compiler-error #'handle-notification-condition)
604           (sb-c:compiler-error       #'handle-notification-condition)
605           (sb-ext:compiler-note      #'handle-notification-condition)
606           (error                     #'handle-notification-condition)
607           (warning                   #'handle-notification-condition))
608      (funcall function)))      (funcall function)))
609    
610  (defimplementation swank-compile-file (filename load-p)  
611    (with-compilation-hooks ()  (defvar *trap-load-time-warnings* t)
612      (let ((fasl-file (compile-file filename)))  
613        (when (and load-p fasl-file)  (defun compiler-policy (qualities)
614          (load fasl-file)))))    "Return compiler policy qualities present in the QUALITIES alist.
615    QUALITIES is an alist with (quality . value)"
616  (defimplementation swank-compile-system (system-name)    #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
617    (with-compilation-hooks ()    (loop with policy = (sb-ext:restrict-compiler-policy)
618      (asdf:operate 'asdf:load-op system-name)))          for (quality) in qualities
619            collect (cons quality
620  (defimplementation swank-compile-string (string &key buffer position)                        (or (cdr (assoc quality policy))
621    (with-compilation-hooks ()                            0))))
622      (let ((*buffer-name* buffer)  
623            (*buffer-offset* position)  (defun (setf compiler-policy) (policy)
624            (*buffer-substring* string))    (declare (ignorable policy))
625        (funcall (compile nil (read-from-string    #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
626                               (format nil "(CL:LAMBDA () ~A)" string)))))))    (loop for (qual . value) in policy
627            do (sb-ext:restrict-compiler-policy qual value)))
628    
629    (defmacro with-compiler-policy (policy &body body)
630      (let ((current-policy (gensym)))
631        `(let ((,current-policy (compiler-policy ,policy)))
632           (setf (compiler-policy) ,policy)
633           (unwind-protect (progn ,@body)
634             (setf (compiler-policy) ,current-policy)))))
635    
636    (defimplementation swank-compile-file (input-file output-file
637                                           load-p external-format
638                                           &key policy)
639      (multiple-value-bind (output-file warnings-p failure-p)
640          (with-compiler-policy policy
641            (with-compilation-hooks ()
642              (compile-file input-file :output-file output-file
643                            :external-format external-format)))
644        (values output-file warnings-p
645                (or failure-p
646                    (when load-p
647                      ;; Cache the latest source file for definition-finding.
648                      (source-cache-get input-file
649                                        (file-write-date input-file))
650                      (not (load output-file)))))))
651    
652    ;;;; compile-string
653    
654    ;;; We copy the string to a temporary file in order to get adequate
655    ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
656    ;;; which the previous approach using
657    ;;;     (compile nil `(lambda () ,(read-from-string string)))
658    ;;; did not provide.
659    
660    (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
661    
662    (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
663        sb-alien:c-string
664      (dir sb-alien:c-string)
665      (prefix sb-alien:c-string))
666    
667    )
668    
669    (defun temp-file-name ()
670      "Return a temporary file name to compile strings into."
671      (tempnam nil nil))
672    
673    (defimplementation swank-compile-string (string &key buffer position filename
674                                             policy)
675      (let ((*buffer-name* buffer)
676            (*buffer-offset* position)
677            (*buffer-substring* string)
678            (*buffer-tmpfile* (temp-file-name)))
679        (flet ((load-it (filename)
680                 (when filename (load filename)))
681               (compile-it (cont)
682                 (with-compilation-hooks ()
683                   (with-compilation-unit
684                       (:source-plist (list :emacs-buffer buffer
685                                            :emacs-filename filename
686                                            :emacs-string string
687                                            :emacs-position position)
688                        :source-namestring filename
689                        :allow-other-keys t)
690                     (multiple-value-bind (output-file warningsp failurep)
691                         (compile-file *buffer-tmpfile* :external-format :utf-8)
692                       (declare (ignore warningsp))
693                       (unless failurep
694                         (funcall cont output-file)))))))
695          (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
696                             :external-format :utf-8)
697            (write-string string s))
698          (unwind-protect
699               (with-compiler-policy policy
700                (if *trap-load-time-warnings*
701                    (compile-it #'load-it)
702                    (load-it (compile-it #'identity))))
703            (ignore-errors
704              (delete-file *buffer-tmpfile*)
705              (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
706    
707  ;;;; Definitions  ;;;; Definitions
708    
709  (defvar *debug-definition-finding* nil  (defparameter *definition-types*
710    "When true don't handle errors while looking for definitions.    '(:variable defvar
711  This is useful when debugging the definition-finding code.")      :constant defconstant
712        :type deftype
713        :symbol-macro define-symbol-macro
714        :macro defmacro
715        :compiler-macro define-compiler-macro
716        :function defun
717        :generic-function defgeneric
718        :method defmethod
719        :setf-expander define-setf-expander
720        :structure defstruct
721        :condition define-condition
722        :class defclass
723        :method-combination define-method-combination
724        :package defpackage
725        :transform :deftransform
726        :optimizer :defoptimizer
727        :vop :define-vop
728        :source-transform :define-source-transform)
729      "Map SB-INTROSPECT definition type names to Slime-friendly forms")
730    
731    (defun definition-specifier (type name)
732      "Return a pretty specifier for NAME representing a definition of type TYPE."
733      (if (and (symbolp name)
734               (eq type :function)
735               (sb-int:info :function :ir1-convert name))
736          :def-ir1-translator
737          (getf *definition-types* type)))
738    
739    (defun make-dspec (type name source-location)
740      (let ((spec (definition-specifier type name))
741            (desc (sb-introspect::definition-source-description source-location)))
742        (if (eq :define-vop spec)
743            ;; The first part of the VOP description is the name of the template
744            ;; -- which is actually good information and often long. So elide the
745            ;; original name in favor of making the interesting bit more visible.
746            ;;
747            ;; The second part of the VOP description is the associated
748            ;; compiler note, or NIL -- which is quite uninteresting and
749            ;; confuses the eye when reading the actual name which usually
750            ;; has a worthwhile postfix. So drop the note.
751            (list spec (car desc))
752            (list* spec name desc))))
753    
754    (defimplementation find-definitions (name)
755      (loop for type in *definition-types* by #'cddr
756            for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
757            append (loop for defsrc in defsrcs collect
758                         (list (make-dspec type name defsrc)
759                               (converting-errors-to-error-location
760                                 (definition-source-for-emacs defsrc
761                                     type name))))))
762    
763    (defimplementation find-source-location (obj)
764      (flet ((general-type-of (obj)
765               (typecase obj
766                 (method             :method)
767                 (generic-function   :generic-function)
768                 (function           :function)
769                 (structure-class    :structure-class)
770                 (class              :class)
771                 (method-combination :method-combination)
772                 (package            :package)
773                 (condition          :condition)
774                 (structure-object   :structure-object)
775                 (standard-object    :standard-object)
776                 (t                  :thing)))
777             (to-string (obj)
778               (typecase obj
779                 ;; Packages are possibly named entities.
780                 (package (princ-to-string obj))
781                 ((or structure-object standard-object condition)
782                  (with-output-to-string (s)
783                    (print-unreadable-object (obj s :type t :identity t))))
784                 (t (princ-to-string obj)))))
785        (converting-errors-to-error-location
786          (let ((defsrc (sb-introspect:find-definition-source obj)))
787            (definition-source-for-emacs defsrc
788                                         (general-type-of obj)
789                                         (to-string obj))))))
790    
791    (defmacro with-definition-source ((&rest names) obj &body body)
792      "Like with-slots but works only for structs."
793      (flet ((reader (slot)
794               ;; Use read-from-string instead of intern so that
795               ;; conc-name can be a string such as ext:struct- and not
796               ;; cause errors and not force interning ext::struct-
797               (read-from-string
798                (concatenate 'string "sb-introspect:definition-source-"
799                             (string slot)))))
800        (let ((tmp (gensym "OO-")))
801          ` (let ((,tmp ,obj))
802              (symbol-macrolet
803                  ,(loop for name in names collect
804                         (typecase name
805                           (symbol `(,name (,(reader name) ,tmp)))
806                           (cons `(,(first name) (,(reader (second name)) ,tmp)))
807                           (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
808                ,@body)))))
809    
810    (defun categorize-definition-source (definition-source)
811      (with-definition-source (pathname form-path character-offset plist)
812        definition-source
813        (let ((file-p (and pathname (probe-file pathname)
814                           (or form-path character-offset))))
815          (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
816                ((getf plist :emacs-buffer) :buffer)
817                (file-p :file)
818                (pathname :file-without-position)
819                (t :invalid)))))
820    
821    (defun definition-source-buffer-location (definition-source)
822      (with-definition-source (form-path character-offset plist) definition-source
823        (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
824                                  emacs-string &allow-other-keys)
825            plist
826          (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
827            (multiple-value-bind (start end)
828                (if form-path
829                    (with-debootstrapping
830                      (source-path-string-position form-path
831                                                   emacs-string))
832                    (values character-offset
833                            most-positive-fixnum))
834              (make-location
835               `(:buffer ,emacs-buffer)
836               `(:offset ,emacs-position ,start)
837               `(:snippet
838                 ,(subseq emacs-string
839                          start
840                          (min end (+ start *source-snippet-size*))))))))))
841    
842    (defun definition-source-file-location (definition-source)
843      (with-definition-source (pathname form-path character-offset plist
844                                        file-write-date) definition-source
845        (let* ((namestring (namestring (translate-logical-pathname pathname)))
846               (pos (if form-path
847                        (source-file-position namestring file-write-date
848                                              form-path)
849                        character-offset))
850               (snippet (source-hint-snippet namestring file-write-date pos)))
851          (make-location `(:file ,namestring)
852                         ;; /file positions/ in Common Lisp start from
853                         ;; 0, buffer positions in Emacs start from 1.
854                         `(:position ,(1+ pos))
855                         `(:snippet ,snippet)))))
856    
857    (defun definition-source-buffer-and-file-location (definition-source)
858      (let ((buffer (definition-source-buffer-location definition-source))
859            (file (definition-source-file-location definition-source)))
860        (make-location (list :buffer-and-file
861                             (cadr (location-buffer buffer))
862                             (cadr (location-buffer file)))
863                       (location-position buffer)
864                       (location-hints buffer))))
865    
866    (defun definition-source-for-emacs (definition-source type name)
867      (with-definition-source (pathname form-path character-offset plist
868                                        file-write-date)
869          definition-source
870        (ecase (categorize-definition-source definition-source)
871          (:buffer-and-file
872           (definition-source-buffer-and-file-location definition-source))
873          (:buffer
874           (definition-source-buffer-location definition-source))
875          (:file
876           (definition-source-file-location definition-source))
877          (:file-without-position
878           (make-location `(:file ,(namestring
879                                    (translate-logical-pathname pathname)))
880                          '(:position 1)
881                          (when (eql type :function)
882                            `(:snippet ,(format nil "(defun ~a "
883                                                (symbol-name name))))))
884          (:invalid
885           (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
886                   meaningful information."
887                  type name)))))
888    
889    (defun source-file-position (filename write-date form-path)
890      (let ((source (get-source-code filename write-date))
891            (*readtable* (guess-readtable-for-filename filename)))
892        (with-debootstrapping
893          (source-path-string-position form-path source))))
894    
895  ;;; FIXME we don't handle the compiled-interactively case yet.  That  (defun source-hint-snippet (filename write-date position)
896  ;;; should have NIL :filename & :position, and non-NIL :source-form    (read-snippet-from-string (get-source-code filename write-date) position))
 (defun function-source-location (function &optional name)  
   "Try to find the canonical source location of FUNCTION."  
   (let* ((def (sb-introspect:find-definition-source function))  
          (pathname (sb-introspect:definition-source-pathname def))  
          (path (sb-introspect:definition-source-form-path def))  
          (position (sb-introspect:definition-source-character-offset def)))  
     (unless pathname  
       (return-from function-source-location  
         (list :error (format nil "No filename for: ~S" function))))  
     (multiple-value-bind (truename condition)  
         (ignore-errors (truename pathname))  
       (when condition  
         (return-from function-source-location  
           (list :error (format nil "~A" condition))))  
       (make-location  
        (list :file (namestring truename))  
        ;; source-paths depend on the file having been compiled with  
        ;; lotsa debugging.  If not present, return the function name  
        ;; for emacs to attempt to find with a regex  
        (cond (path (list :source-path path position))  
              (t (list :function-name  
                       (or (and name (string name))  
                           (string (sb-kernel:%fun-name function))))))))))  
   
 (defun safe-function-source-location (fun name)  
   (if *debug-definition-finding*  
       (function-source-location fun name)  
       (handler-case (function-source-location fun name)  
         (error (e)  
           (list (list :error (format nil "Error: ~A" e)))))))  
   
 (defun method-definitions (gf)  
   (let ((methods (sb-mop:generic-function-methods gf))  
         (name (sb-mop:generic-function-name gf)))  
     (loop for method in methods  
           collect (list `(method ,name ,(mapcar  
                                          #'sb-mop:class-name  
                                          (sb-mop:method-specializers method)))  
                         (safe-function-source-location method name)))))  
   
 (defun function-definitions (symbol)  
   (flet ((loc (fun name) (safe-function-source-location fun name)))  
     (cond ((macro-function symbol)  
            (list (list `(macro ,symbol) (loc (macro-function symbol) symbol))))  
           ((fboundp symbol)  
            (let ((fun (symbol-function symbol)))  
              (cond ((typep fun 'sb-mop:generic-function)  
                     (cons (list `(generic ,symbol) (loc fun symbol))  
                           (method-definitions fun)))  
                    (t  
                     (list (list symbol (loc fun symbol))))))))))  
897    
898  (defimplementation find-definitions (symbol)  (defun function-source-location (function &optional name)
899    (function-definitions symbol))    (declare (type function function))
900      (definition-source-for-emacs (sb-introspect:find-definition-source function)
901                                   :function
902                                   (or name (function-name function))))
903    
904  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
905    "Return a plist describing SYMBOL.    "Return a plist describing SYMBOL.
906  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
907    (let ((result '()))    (let ((result '()))
908      (labels ((doc (kind)      (flet ((doc (kind)
909                 (or (documentation symbol kind) :not-documented))               (or (documentation symbol kind) :not-documented))
910               (maybe-push (property value)             (maybe-push (property value)
911                 (when value               (when value
912                   (setf result (list* property value result)))))                 (setf result (list* property value result)))))
913        (maybe-push        (maybe-push
914         :variable (multiple-value-bind (kind recorded-p)         :variable (multiple-value-bind (kind recorded-p)
915                       (sb-int:info :variable :kind symbol)                       (sb-int:info :variable :kind symbol)
916                     (declare (ignore kind))                     (declare (ignore kind))
917                     (if (or (boundp symbol) recorded-p)                     (if (or (boundp symbol) recorded-p)
918                         (doc 'variable))))                         (doc 'variable))))
919        (maybe-push        (when (fboundp symbol)
920         :function (if (fboundp symbol)          (maybe-push
921                       (doc 'function)))           (cond ((macro-function symbol)     :macro)
922                   ((special-operator-p symbol) :special-operator)
923                   ((typep (fdefinition symbol) 'generic-function)
924                    :generic-function)
925                   (t :function))
926             (doc 'function)))
927        (maybe-push        (maybe-push
928         :setf (if (or (sb-int:info :setf :inverse symbol)         :setf (if (or (sb-int:info :setf :inverse symbol)
929                       (sb-int:info :setf :expander symbol))                       (sb-int:info :setf :expander symbol))
# Line 435  Return NIL if the symbol is unbound." Line 946  Return NIL if the symbol is unbound."
946       (describe (find-class symbol)))       (describe (find-class symbol)))
947      (:type      (:type
948       (describe (sb-kernel:values-specifier-type symbol)))))       (describe (sb-kernel:values-specifier-type symbol)))))
949    
950    #+#.(swank-backend::sbcl-with-xref-p)
951    (progn
952      (defmacro defxref (name &optional fn-name)
953        `(defimplementation ,name (what)
954           (sanitize-xrefs
955            (mapcar #'source-location-for-xref-data
956                    (,(find-symbol (symbol-name (if fn-name
957                                                    fn-name
958                                                    name))
959                                   "SB-INTROSPECT")
960                      what)))))
961      (defxref who-calls)
962      (defxref who-binds)
963      (defxref who-sets)
964      (defxref who-references)
965      (defxref who-macroexpands)
966      #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
967      (defxref who-specializes who-specializes-directly))
968    
969    (defun source-location-for-xref-data (xref-data)
970      (destructuring-bind (name . defsrc) xref-data
971        (list name (converting-errors-to-error-location
972                     (definition-source-for-emacs defsrc 'function name)))))
973    
974    (defimplementation list-callers (symbol)
975      (let ((fn (fdefinition symbol)))
976        (sanitize-xrefs
977         (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
978    
979    (defimplementation list-callees (symbol)
980      (let ((fn (fdefinition symbol)))
981        (sanitize-xrefs
982         (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
983    
984    (defun sanitize-xrefs (xrefs)
985      (remove-duplicates
986       (remove-if (lambda (f)
987                    (member f (ignored-xref-function-names)))
988                  (loop for entry in xrefs
989                        for name = (car entry)
990                        collect (if (and (consp name)
991                                         (member (car name)
992                                                 '(sb-pcl::fast-method
993                                                   sb-pcl::slow-method
994                                                   sb-pcl::method)))
995                                    (cons (cons 'defmethod (cdr name))
996                                          (cdr entry))
997                                    entry))
998                  :key #'car)
999       :test (lambda (a b)
1000               (and (eq (first a) (first b))
1001                    (equal (second a) (second b))))))
1002    
1003    (defun ignored-xref-function-names ()
1004      #-#.(swank-backend::sbcl-with-new-stepper-p)
1005      '(nil sb-c::step-form sb-c::step-values)
1006      #+#.(swank-backend::sbcl-with-new-stepper-p)
1007      '(nil))
1008    
1009    (defun function-dspec (fn)
1010      "Describe where the function FN was defined.
1011    Return a list of the form (NAME LOCATION)."
1012      (let ((name (function-name fn)))
1013        (list name (converting-errors-to-error-location
1014                     (function-source-location fn name)))))
1015    
1016  ;;; macroexpansion  ;;; macroexpansion
1017    
# Line 445  Return NIL if the symbol is unbound." Line 1022  Return NIL if the symbol is unbound."
1022    
1023  ;;; Debugging  ;;; Debugging
1024    
1025    ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1026    ;;; than just a hook into BREAK. In particular, it'll make
1027    ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1028    ;;; than the native debugger. That should probably be considered a
1029    ;;; feature.
1030    
1031    (defun make-invoke-debugger-hook (hook)
1032      (when hook
1033        #'(sb-int:named-lambda swank-invoke-debugger-hook
1034              (condition old-hook)
1035            (if *debugger-hook*
1036                nil         ; decline, *DEBUGGER-HOOK* will be tried next.
1037                (funcall hook condition old-hook)))))
1038    
1039    (defun set-break-hook (hook)
1040      (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1041    
1042    (defun call-with-break-hook (hook continuation)
1043      (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1044        (funcall continuation)))
1045    
1046    (defimplementation install-debugger-globally (function)
1047      (setq *debugger-hook* function)
1048      (set-break-hook function))
1049    
1050    (defimplementation condition-extras (condition)
1051      (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1052            ((typep condition 'sb-impl::step-form-condition)
1053             `((:show-frame-source 0)))
1054            ((typep condition 'sb-int:reference-condition)
1055             (let ((refs (sb-int:reference-condition-references condition)))
1056               (if refs
1057                   `((:references ,(externalize-reference refs))))))))
1058    
1059    (defun externalize-reference (ref)
1060      (etypecase ref
1061        (null nil)
1062        (cons (cons (externalize-reference (car ref))
1063                    (externalize-reference (cdr ref))))
1064        ((or string number) ref)
1065        (symbol
1066         (cond ((eq (symbol-package ref) (symbol-package :test))
1067                ref)
1068               (t (symbol-name ref))))))
1069    
1070  (defvar *sldb-stack-top*)  (defvar *sldb-stack-top*)
1071    
1072  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
1073    (declare (type function debugger-loop-fn))    (declare (type function debugger-loop-fn))
1074    (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))    (let ((*sldb-stack-top*
1075           (sb-debug:*stack-top-hint* nil))            (if (and (not *debug-swank-backend*)
1076      (handler-bind ((sb-di:debug-condition                     sb-debug:*stack-top-hint*)
1077                      (lambda (condition)                #+#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1078                        (signal (make-condition                (sb-debug::resolve-stack-top-hint)
1079                                 'sldb-condition                #-#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1080                                 :original-condition condition)))))                sb-debug:*stack-top-hint*
1081                  (sb-di:top-frame)))
1082            (sb-debug:*stack-top-hint* nil))
1083        (handler-bind ((sb-di:debug-condition
1084                         (lambda (condition)
1085                           (signal 'sldb-condition
1086                                   :original-condition condition))))
1087        (funcall debugger-loop-fn))))        (funcall debugger-loop-fn))))
1088    
1089    #+#.(swank-backend::sbcl-with-new-stepper-p)
1090    (progn
1091      (defimplementation activate-stepping (frame)
1092        (declare (ignore frame))
1093        (sb-impl::enable-stepping))
1094      (defimplementation sldb-stepper-condition-p (condition)
1095        (typep condition 'sb-ext:step-form-condition))
1096      (defimplementation sldb-step-into ()
1097        (invoke-restart 'sb-ext:step-into))
1098      (defimplementation sldb-step-next ()
1099        (invoke-restart 'sb-ext:step-next))
1100      (defimplementation sldb-step-out ()
1101        (invoke-restart 'sb-ext:step-out)))
1102    
1103    (defimplementation call-with-debugger-hook (hook fun)
1104      (let ((*debugger-hook* hook)
1105            #+#.(swank-backend::sbcl-with-new-stepper-p)
1106            (sb-ext:*stepper-hook*
1107             (lambda (condition)
1108               (typecase condition
1109                 (sb-ext:step-form-condition
1110                  (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1111                    (sb-impl::invoke-debugger condition)))))))
1112        (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1113                       (sb-ext:step-condition #'sb-impl::invoke-stepper))
1114          (call-with-break-hook hook fun))))
1115    
1116  (defun nth-frame (index)  (defun nth-frame (index)
1117    (do ((frame *sldb-stack-top* (sb-di:frame-down frame))    (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1118         (i index (1- i)))         (i index (1- i)))
# Line 470  stack." Line 1125  stack."
1125    (let ((end (or end most-positive-fixnum)))    (let ((end (or end most-positive-fixnum)))
1126      (loop for f = (nth-frame start) then (sb-di:frame-down f)      (loop for f = (nth-frame start) then (sb-di:frame-down f)
1127            for i from start below end            for i from start below end
1128            while f            while f collect f)))
           collect f)))  
1129    
1130  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
1131    (let ((*standard-output* stream))    (sb-debug::print-frame-call frame stream))
     (sb-debug::print-frame-call frame :verbosity 1 :number nil)))  
1132    
1133  (defun code-location-source-path (code-location)  (defimplementation frame-restartable-p (frame)
1134    (let* ((location (sb-debug::maybe-block-start-location code-location))    #+#.(swank-backend::sbcl-with-restart-frame)
1135           (form-num (sb-di:code-location-form-number location)))    (not (null (sb-debug:frame-has-debug-tag-p frame))))
1136      (let ((translations (sb-debug::get-toplevel-form location)))  
1137        (unless (< form-num (length translations))  (defimplementation frame-call (frame-number)
1138          (error "Source path no longer exists."))    (multiple-value-bind (name args)
1139        (reverse (cdr (svref translations form-num))))))        (sb-debug::frame-call (nth-frame frame-number))
1140        (with-output-to-string (stream)
1141  (defun code-location-file-position (code-location)        (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1142    (let* ((debug-source (sb-di:code-location-debug-source code-location))          (let ((*print-length* nil)
1143           (filename (sb-di:debug-source-name debug-source))                (*print-level* nil))
1144           (path (code-location-source-path code-location)))            (prin1 (sb-debug::ensure-printable-object name) stream))
1145      (source-path-file-position path filename)))          (let ((args (sb-debug::ensure-printable-object args)))
1146              (if (listp args)
1147                  (format stream "~{ ~_~S~}" args)
1148                  (format stream " ~S" args)))))))
1149    
1150    ;;;; Code-location -> source-location translation
1151    
1152    ;;; If debug-block info is avaibale, we determine the file position of
1153    ;;; the source-path for a code-location.  If the code was compiled
1154    ;;; with C-c C-c, we have to search the position in the source string.
1155    ;;; If there's no debug-block info, we return the (less precise)
1156    ;;; source-location of the corresponding function.
1157    
1158    (defun code-location-source-location (code-location)
1159      (let* ((dsource (sb-di:code-location-debug-source code-location))
1160             (plist (sb-c::debug-source-plist dsource)))
1161        (if (getf plist :emacs-buffer)
1162            (emacs-buffer-source-location code-location plist)
1163            #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1164            (ecase (sb-di:debug-source-from dsource)
1165              (:file (file-source-location code-location))
1166              (:lisp (lisp-source-location code-location)))
1167            #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1168            (if (sb-di:debug-source-namestring dsource)
1169                (file-source-location code-location)
1170                (lisp-source-location code-location)))))
1171    
1172    ;;; FIXME: The naming policy of source-location functions is a bit
1173    ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1174    ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1175    ;;; which returns the source location for a _code-location_.
1176    ;;;
1177    ;;; Maybe these should be named code-location-file-source-location,
1178    ;;; etc, turned into generic functions, or something. In the very
1179    ;;; least the names should indicate the main entry point vs. helper
1180    ;;; status.
1181    
1182    (defun file-source-location (code-location)
1183      (if (code-location-has-debug-block-info-p code-location)
1184          (source-file-source-location code-location)
1185          (fallback-source-location code-location)))
1186    
1187    (defun fallback-source-location (code-location)
1188      (let ((fun (code-location-debug-fun-fun code-location)))
1189        (cond (fun (function-source-location fun))
1190              (t (error "Cannot find source location for: ~A " code-location)))))
1191    
1192    (defun lisp-source-location (code-location)
1193      (let ((source (prin1-to-string
1194                     (sb-debug::code-location-source-form code-location 100)))
1195            (condition (swank-value '*swank-debugger-condition*)))
1196        (if (and (typep condition 'sb-impl::step-form-condition)
1197                 (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1198                         :test #'char-equal)
1199                 (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1200            ;; The initial form is utterly uninteresting -- and almost
1201            ;; certainly right there in the REPL.
1202            (make-error-location "Stepping...")
1203            (make-location `(:source-form ,source) '(:position 1)))))
1204    
1205    (defun emacs-buffer-source-location (code-location plist)
1206      (if (code-location-has-debug-block-info-p code-location)
1207          (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1208                                    &allow-other-keys)
1209              plist
1210            (let* ((pos (string-source-position code-location emacs-string))
1211                   (snipped (read-snippet-from-string emacs-string pos)))
1212              (make-location `(:buffer ,emacs-buffer)
1213                             `(:offset ,emacs-position ,pos)
1214                             `(:snippet ,snipped))))
1215          (fallback-source-location code-location)))
1216    
1217    (defun source-file-source-location (code-location)
1218      (let* ((code-date (code-location-debug-source-created code-location))
1219             (filename (code-location-debug-source-name code-location))
1220             (*readtable* (guess-readtable-for-filename filename))
1221             (source-code (get-source-code filename code-date)))
1222        (with-debootstrapping
1223          (with-input-from-string (s source-code)
1224            (let* ((pos (stream-source-position code-location s))
1225                   (snippet (read-snippet s pos)))
1226              (make-location `(:file ,filename)
1227                             `(:position ,pos)
1228                             `(:snippet ,snippet)))))))
1229    
1230    (defun code-location-debug-source-name (code-location)
1231      (namestring (truename (#+#.(swank-backend:with-symbol
1232                                  'debug-source-name 'sb-di)
1233                                 sb-c::debug-source-name
1234                                 #-#.(swank-backend:with-symbol
1235                                      'debug-source-name 'sb-di)
1236                                 sb-c::debug-source-namestring
1237                             (sb-di::code-location-debug-source code-location)))))
1238    
1239    (defun code-location-debug-source-created (code-location)
1240      (sb-c::debug-source-created
1241       (sb-di::code-location-debug-source code-location)))
1242    
1243    (defun code-location-debug-fun-fun (code-location)
1244      (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1245    
1246    (defun code-location-has-debug-block-info-p (code-location)
1247      (handler-case
1248          (progn (sb-di:code-location-debug-block code-location)
1249                 t)
1250        (sb-di:no-debug-blocks  () nil)))
1251    
1252    (defun stream-source-position (code-location stream)
1253      (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1254             (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1255             (form-number (sb-di::code-location-form-number cloc)))
1256        (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1257          (let* ((path-table (sb-di::form-number-translations tlf 0))
1258                 (path (cond ((<= (length path-table) form-number)
1259                              (warn "inconsistent form-number-translations")
1260                              (list 0))
1261                             (t
1262                              (reverse (cdr (aref path-table form-number)))))))
1263            (source-path-source-position path tlf pos-map)))))
1264    
1265    (defun string-source-position (code-location string)
1266      (with-input-from-string (s string)
1267        (stream-source-position code-location s)))
1268    
1269  ;;; source-path-file-position and friends are in swank-source-path-parser  ;;; source-path-file-position and friends are in swank-source-path-parser
1270    
1271  (defun debug-source-info-from-emacs-buffer-p (debug-source)  (defimplementation frame-source-location (index)
1272    (let ((info (sb-c::debug-source-info debug-source)))    (converting-errors-to-error-location
1273      (and info      (code-location-source-location
1274           (consp info)       (sb-di:frame-code-location (nth-frame index)))))
1275           (eq :emacs-buffer (car info)))))  
1276    (defvar *keep-non-valid-locals* nil)
1277  (defun source-location-for-emacs (code-location)  
1278    (let* ((debug-source (sb-di:code-location-debug-source code-location))  (defun frame-debug-vars (frame)
1279           (from (sb-di:debug-source-from debug-source))    "Return a vector of debug-variables in frame."
1280           (name (sb-di:debug-source-name debug-source)))    (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
1281      (ecase from      (cond (*keep-non-valid-locals* all-vars)
1282        (:file            (t (let ((loc (sb-di:frame-code-location frame)))
1283         (let ((source-path (ignore-errors                 (remove-if (lambda (var)
1284                              (code-location-source-path code-location))))                              (ecase (sb-di:debug-var-validity var loc)
1285           (cond (source-path                                (:valid nil)
1286                  ;; XXX: code-location-source-path reads the source !!                                ((:invalid :unknown) t)))
1287                  (let ((position (code-location-file-position code-location)))                            all-vars))))))
1288                    (make-location  
1289                     (list :file (namestring (truename name)))  (defun debug-var-value (var frame location)
1290                     (list :source-path source-path position))))    (ecase (sb-di:debug-var-validity var location)
1291                 (t      (:valid (sb-di:debug-var-value var frame))
1292                  (let* ((dfn (sb-di:code-location-debug-fun code-location))      ((:invalid :unknown) ':<not-available>)))
1293                         (fn (sb-di:debug-fun-fun dfn)))  
1294                    (unless fn  (defun debug-var-info (var)
1295                      (error "Cannot find source location for: ~A "    ;; Introduced by SBCL 1.0.49.76.
1296                             code-location))    (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1297                    (function-source-location      (when (and s (fboundp s))
1298                     fn (sb-di:debug-fun-name dfn)))))))        (funcall s var))))
   
       (:lisp  
        (make-location  
         (list :source-form (with-output-to-string (*standard-output*)  
                              (sb-debug::print-code-location-source-form  
                               code-location 100)))  
         (list :position 0))))))  
   
 (defun safe-source-location-for-emacs (code-location)  
   (handler-case (source-location-for-emacs code-location)  
     (error (c) (list :error (format nil "~A" c)))))  
   
 (defimplementation frame-source-location-for-emacs (index)  
   (safe-source-location-for-emacs  
    (sb-di:frame-code-location (nth-frame index))))  
1299    
1300  (defimplementation frame-locals (index)  (defimplementation frame-locals (index)
1301    (let* ((frame (nth-frame index))    (let* ((frame (nth-frame index))
1302           (location (sb-di:frame-code-location frame))           (loc (sb-di:frame-code-location frame))
1303           (debug-function (sb-di:frame-debug-fun frame))           (vars (frame-debug-vars frame))
1304           (debug-variables (sb-di::debug-fun-debug-vars debug-function)))           ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1305      (declare (type (or null simple-vector) debug-variables))           ;; specially.
1306      (loop for v across debug-variables           (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1307            collect (list           (more-context nil)
1308                     :name (sb-di:debug-var-symbol v)           (more-count nil)
1309                     :id (sb-di:debug-var-id v)           (more-id 0))
1310                     :value (if (eq (sb-di:debug-var-validity v location)      (when vars
1311                                    :valid)        (let ((locals
1312                                (sb-di:debug-var-value v frame)                (loop for v across vars
1313                                '#:<not-available>)))))                      do (when (eq (sb-di:debug-var-symbol v) more-name)
1314                             (incf more-id))
1315                           (case (debug-var-info v)
1316                             (:more-context
1317                              (setf more-context (debug-var-value v frame loc)))
1318                             (:more-count
1319                              (setf more-count (debug-var-value v frame loc))))
1320                        collect
1321                           (list :name (sb-di:debug-var-symbol v)
1322                                 :id (sb-di:debug-var-id v)
1323                                 :value (debug-var-value v frame loc)))))
1324            (when (and more-context more-count)
1325              (setf locals (append locals
1326                                   (list
1327                                    (list :name more-name
1328                                          :id more-id
1329                                          :value (multiple-value-list
1330                                                  (sb-c:%more-arg-values
1331                                                   more-context
1332                                                   0 more-count)))))))
1333            locals))))
1334    
1335    (defimplementation frame-var-value (frame var)
1336      (let* ((frame (nth-frame frame))
1337             (vars (frame-debug-vars frame))
1338             (loc (sb-di:frame-code-location frame))
1339             (dvar (if (= var (length vars))
1340                       ;; If VAR is out of bounds, it must be the fake var
1341                       ;; we made up for &MORE.
1342                       (let* ((context-var (find :more-context vars
1343                                                 :key #'debug-var-info))
1344                              (more-context (debug-var-value context-var frame
1345                                                             loc))
1346                              (count-var (find :more-count vars
1347                                               :key #'debug-var-info))
1348                              (more-count (debug-var-value count-var frame loc)))
1349                         (return-from frame-var-value
1350                           (multiple-value-list (sb-c:%more-arg-values
1351                                                 more-context
1352                                                 0 more-count))))
1353                       (aref vars var))))
1354        (debug-var-value dvar frame loc)))
1355    
1356  (defimplementation frame-catch-tags (index)  (defimplementation frame-catch-tags (index)
1357    (mapcar #'car (sb-di:frame-catches (nth-frame index))))    (mapcar #'car (sb-di:frame-catches (nth-frame index))))
# Line 558  stack." Line 1359  stack."
1359  (defimplementation eval-in-frame (form index)  (defimplementation eval-in-frame (form index)
1360    (let ((frame (nth-frame index)))    (let ((frame (nth-frame index)))
1361      (funcall (the function      (funcall (the function
1362                 (sb-di:preprocess-for-eval form                 (sb-di:preprocess-for-eval form
1363                                            (sb-di:frame-code-location frame)))                                            (sb-di:frame-code-location frame)))
1364               frame)))               frame)))
1365    
1366  (defun sb-debug-catch-tag-p (tag)  (defimplementation frame-package (frame-number)
1367    (and (symbolp tag)    (let* ((frame (nth-frame frame-number))
1368         (not (symbol-package tag))           (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
1369         (string= tag :sb-debug-catch-tag)))      (when fun
1370          (let ((name (function-name fun)))
1371            (typecase name
1372              (null nil)
1373              (symbol (symbol-package name))
1374              ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
1375    
1376    #+#.(swank-backend::sbcl-with-restart-frame)
1377    (progn
1378      (defimplementation return-from-frame (index form)
1379        (let* ((frame (nth-frame index)))
1380          (cond ((sb-debug:frame-has-debug-tag-p frame)
1381                 (let ((values (multiple-value-list (eval-in-frame form index))))
1382                   (sb-debug:unwind-to-frame-and-call frame
1383                                                       (lambda ()
1384                                                         (values-list values)))))
1385                (t (format nil "Cannot return from frame: ~S" frame)))))
1386    
1387      (defimplementation restart-frame (index)
1388        (let ((frame (nth-frame index)))
1389          (when (sb-debug:frame-has-debug-tag-p frame)
1390            (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1391              (multiple-value-bind (fun arglist)
1392                  (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1393                      (values (fdefinition fname) args)
1394                      (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1395                              (sb-debug::frame-args-as-list frame)))
1396                (when (functionp fun)
1397                  (sb-debug:unwind-to-frame-and-call
1398                   frame
1399                   (lambda ()
1400                     ;; Ensure TCO.
1401                     (declare (optimize (debug 0)))
1402                     (apply fun arglist)))))))
1403          (format nil "Cannot restart frame: ~S" frame))))
1404    
1405    ;; FIXME: this implementation doesn't unwind the stack before
1406    ;; re-invoking the function, but it's better than no implementation at
1407    ;; all.
1408    #-#.(swank-backend::sbcl-with-restart-frame)
1409    (progn
1410      (defun sb-debug-catch-tag-p (tag)
1411        (and (symbolp tag)
1412             (not (symbol-package tag))
1413             (string= tag :sb-debug-catch-tag)))
1414    
1415      (defimplementation return-from-frame (index form)
1416        (let* ((frame (nth-frame index))
1417               (probe (assoc-if #'sb-debug-catch-tag-p
1418                                (sb-di::frame-catches frame))))
1419          (cond (probe (throw (car probe) (eval-in-frame form index)))
1420                (t (format nil "Cannot return from frame: ~S" frame)))))
1421    
1422      (defimplementation restart-frame (index)
1423        (let ((frame (nth-frame index)))
1424          (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1425    
1426    ;;;;; reference-conditions
1427    
1428    (defimplementation format-sldb-condition (condition)
1429      (let ((sb-int:*print-condition-references* nil))
1430        (princ-to-string condition)))
1431    
 (defimplementation return-from-frame (index form)  
   (let* ((frame (nth-frame index))  
          (probe (assoc-if #'sb-debug-catch-tag-p  
                           (sb-di::frame-catches frame))))  
     (cond (probe (throw (car probe) (eval-in-frame form index)))  
           (t (format nil "Cannot return from frame: ~S" frame)))))  
   
1432    
1433  ;;;; Profiling  ;;;; Profiling
1434    
# Line 597  stack." Line 1452  stack."
1452  (defimplementation profiled-functions ()  (defimplementation profiled-functions ()
1453    (sb-profile:profile))    (sb-profile:profile))
1454    
1455    (defimplementation profile-package (package callers methods)
1456      (declare (ignore callers methods))
1457      (eval `(sb-profile:profile ,(package-name (find-package package)))))
1458    
1459    
1460  ;;;; Inspector  ;;;; Inspector
1461    
1462  (defmethod inspected-parts (o)  (defmethod emacs-inspect ((o t))
1463    (cond ((sb-di::indirect-value-cell-p o)    (cond ((sb-di::indirect-value-cell-p o)
1464           (inspected-parts-of-value-cell o))           (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1465          (t          (t
1466           (multiple-value-bind (text labeledp parts)           (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1467               (sb-impl::inspected-parts o)             (list* (string-right-trim '(#\Newline) text)
1468             (let ((parts (if labeledp                    '(:newline)
1469                              (loop for (label . value) in parts                    (if label
1470                                    collect (cons (string label) value))                        (loop for (l . v) in parts
1471                              (loop for value in parts                              append (label-value-line l v))
1472                                    for i from 0                        (loop for value in parts
1473                                    collect (cons (format nil "~D" i) value)))))                              for i from 0
1474               (values text parts))))))                              append (label-value-line i value))))))))
   
 (defun inspected-parts-of-value-cell (o)  
   (values (format nil "~A~% is a value cell." o)  
           (list (cons "Value" (sb-kernel:value-cell-ref o)))))  
1475    
1476  (defmethod inspected-parts ((o function))  (defmethod emacs-inspect ((o function))
1477    (let ((header (sb-kernel:widetag-of o)))    (let ((header (sb-kernel:widetag-of o)))
1478      (cond ((= header sb-vm:simple-fun-header-widetag)      (cond ((= header sb-vm:simple-fun-header-widetag)
1479             (values                     (label-value-line*
1480              (format nil "~A~% is a simple-fun." o)                      (:name (sb-kernel:%simple-fun-name o))
1481              (list (cons "Self" (sb-kernel:%simple-fun-self o))                      (:arglist (sb-kernel:%simple-fun-arglist o))
1482                    (cons "Next" (sb-kernel:%simple-fun-next o))                      (:self (sb-kernel:%simple-fun-self o))
1483                    (cons "Name" (sb-kernel:%simple-fun-name o))                      (:next (sb-kernel:%simple-fun-next o))
1484                    (cons "Arglist" (sb-kernel:%simple-fun-arglist o))                      (:type (sb-kernel:%simple-fun-type o))
1485                    (cons "Type" (sb-kernel:%simple-fun-type o))                      (:code (sb-kernel:fun-code-header o))))
                   (cons "Code Object" (sb-kernel:fun-code-header o)))))  
1486            ((= header sb-vm:closure-header-widetag)            ((= header sb-vm:closure-header-widetag)
1487             (values (format nil "~A~% is a closure." o)                     (append
1488                     (list*                      (label-value-line :function (sb-kernel:%closure-fun o))
1489                      (cons "Function" (sb-kernel:%closure-fun o))                      `("Closed over values:" (:newline))
1490                      (loop for i from 0                      (loop for i below (1- (sb-kernel:get-closure-length o))
1491                            below (- (sb-kernel:get-closure-length o)                            append (label-value-line
1492                                     (1- sb-vm:closure-info-offset))                                    i (sb-kernel:%closure-index-ref o i)))))
                           collect (cons (format nil "~D" i)  
                                         (sb-kernel:%closure-index-ref o i))))))  
1493            (t (call-next-method o)))))            (t (call-next-method o)))))
1494    
1495  (defmethod inspected-parts ((o sb-kernel:code-component))  (defmethod emacs-inspect ((o sb-kernel:code-component))
1496    (values (format nil "~A~% is a code data-block." o)            (append
1497            `(("First entry point" . ,(sb-kernel:%code-entry-points o))             (label-value-line*
1498              ,@(loop for i from sb-vm:code-constants-offset              (:code-size (sb-kernel:%code-code-size o))
1499                      below (sb-kernel:get-header-data o)              (:entry-points (sb-kernel:%code-entry-points o))
1500                      collect (cons (format nil "Constant#~D" i)              (:debug-info (sb-kernel:%code-debug-info o))
1501                                    (sb-kernel:code-header-ref o i)))              (:trace-table-offset (sb-kernel:code-header-ref
1502              ("Debug info" . ,(sb-kernel:%code-debug-info o))                                    o sb-vm:code-trace-table-offset-slot)))
1503              ("Instructions"  . ,(sb-kernel:code-instructions o)))))             `("Constants:" (:newline))
1504               (loop for i from sb-vm:code-constants-offset
1505  (defmethod inspected-parts ((o sb-kernel:fdefn))                   below (sb-kernel:get-header-data o)
1506    (values (format nil "~A~% is a fdefn object." o)                   append (label-value-line i (sb-kernel:code-header-ref o i)))
1507            `(("Name" . ,(sb-kernel:fdefn-name o))             `("Code:" (:newline)
1508              ("Function" . ,(sb-kernel:fdefn-fun o)))))               , (with-output-to-string (s)
1509                     (cond ((sb-kernel:%code-debug-info o)
1510                            (sb-disassem:disassemble-code-component o :stream s))
1511  (defmethod inspected-parts ((o generic-function))                         (t
1512    (values (format nil "~A~% is a generic function." o)                          (sb-disassem:disassemble-memory
1513            (list                           (sb-disassem::align
1514             (cons "Method-Class" (sb-pcl:generic-function-method-class o))                            (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1515             (cons "Methods" (sb-pcl:generic-function-methods o))                                         sb-vm:lowtag-mask)
1516             (cons "Name" (sb-pcl:generic-function-name o))                               (* sb-vm:code-constants-offset
1517             (cons "Declarations" (sb-pcl:generic-function-declarations o))                                  sb-vm:n-word-bytes))
1518             (cons "Method-Combination"                            (ash 1 sb-vm:n-lowtag-bits))
1519                   (sb-pcl:generic-function-method-combination o))                           (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1520             (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))                           :stream s)))))))
1521             (cons "Precedence-Order"  
1522                   (sb-pcl:generic-function-argument-precedence-order o))  (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1523             (cons "Pretty-Arglist"            (label-value-line*
1524                   (sb-pcl::generic-function-pretty-arglist o))             (:value (sb-ext:weak-pointer-value o))))
1525             (cons "Initial-Methods"  
1526                   (sb-pcl::generic-function-initial-methods  o)))))  (defmethod emacs-inspect ((o sb-kernel:fdefn))
1527              (label-value-line*
1528               (:name (sb-kernel:fdefn-name o))
1529               (:function (sb-kernel:fdefn-fun o))))
1530    
1531    (defmethod emacs-inspect :around ((o generic-function))
1532                (append
1533                 (call-next-method)
1534                 (label-value-line*
1535                  (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1536                  (:initial-methods (sb-pcl::generic-function-initial-methods o))
1537                  )))
1538    
1539    
1540  ;;;; Multiprocessing  ;;;; Multiprocessing
1541    
1542  #+SB-THREAD  #+(and sb-thread
1543           #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1544  (progn  (progn
1545      (defvar *thread-id-counter* 0)
1546    
1547      (defvar *thread-id-counter-lock*
1548        (sb-thread:make-mutex :name "thread id counter lock"))
1549    
1550      (defun next-thread-id ()
1551        (sb-thread:with-mutex (*thread-id-counter-lock*)
1552          (incf *thread-id-counter*)))
1553    
1554      (defparameter *thread-id-map* (make-hash-table))
1555    
1556      ;; This should be a thread -> id map but as weak keys are not
1557      ;; supported it is id -> map instead.
1558      (defvar *thread-id-map-lock*
1559        (sb-thread:make-mutex :name "thread id map lock"))
1560    
1561    (defimplementation spawn (fn &key name)    (defimplementation spawn (fn &key name)
1562      (declare (ignore name))      (sb-thread:make-thread fn :name name))
     (sb-thread:make-thread fn))  
1563    
1564    (defimplementation startup-multiprocessing ()    (defimplementation thread-id (thread)
1565      (setq *swank-in-background* :spawn))      (block thread-id
1566          (sb-thread:with-mutex (*thread-id-map-lock*)
1567            (loop for id being the hash-key in *thread-id-map*
1568                  using (hash-value thread-pointer)
1569                  do
1570                  (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1571                    (cond ((null maybe-thread)
1572                           ;; the value is gc'd, remove it manually
1573                           (remhash id *thread-id-map*))
1574                          ((eq thread maybe-thread)
1575                           (return-from thread-id id)))))
1576            ;; lazy numbering
1577            (let ((id (next-thread-id)))
1578              (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1579              id))))
1580    
1581      (defimplementation find-thread (id)
1582        (sb-thread:with-mutex (*thread-id-map-lock*)
1583          (let ((thread-pointer (gethash id *thread-id-map*)))
1584            (if thread-pointer
1585                (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1586                  (if maybe-thread
1587                      maybe-thread
1588                      ;; the value is gc'd, remove it manually
1589                      (progn
1590                        (remhash id *thread-id-map*)
1591                        nil)))
1592                nil))))
1593    
1594    (defimplementation thread-name (thread)    (defimplementation thread-name (thread)
1595      (format nil "Thread ~D" thread))      ;; sometimes the name is not a string (e.g. NIL)
1596        (princ-to-string (sb-thread:thread-name thread)))
1597    
1598    (defimplementation thread-status (thread)    (defimplementation thread-status (thread)
1599      (declare (ignore thread))      (if (sb-thread:thread-alive-p thread)
1600      "???")          "Running"
1601            "Stopped"))
1602    
1603    (defimplementation make-lock (&key name)    (defimplementation make-lock (&key name)
1604      (sb-thread:make-mutex :name name))      (sb-thread:make-mutex :name name))
1605    
1606    (defimplementation call-with-lock-held (lock function)    (defimplementation call-with-lock-held (lock function)
1607      (declare (type function function))      (declare (type function function))
1608      (sb-thread:with-mutex (lock) (funcall function)))      (sb-thread:with-recursive-lock (lock) (funcall function)))
1609    
1610    (defimplementation current-thread ()    (defimplementation current-thread ()
1611      (sb-thread:current-thread-id))      sb-thread:*current-thread*)
1612    
1613    (defimplementation all-threads ()    (defimplementation all-threads ()
1614      (sb-thread::mapcar-threads      (sb-thread:list-all-threads))
1615       (lambda (sap)  
        (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes  
                                  sb-vm::thread-pid-slot)))))  
   
1616    (defimplementation interrupt-thread (thread fn)    (defimplementation interrupt-thread (thread fn)
1617      (sb-thread:interrupt-thread thread fn))      (sb-thread:interrupt-thread thread fn))
1618    
1619    (defimplementation kill-thread (thread)    (defimplementation kill-thread (thread)
1620      (sb-thread:terminate-thread thread))      (sb-thread:terminate-thread thread))
1621    
1622    ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)    (defimplementation thread-alive-p (thread)
1623        (sb-thread:thread-alive-p thread))
1624    
1625    (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))    (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1626    (defvar *mailboxes* (list))    (defvar *mailboxes* (list))
1627    (declaim (type list *mailboxes*))    (declaim (type list *mailboxes*))
1628    
1629    (defstruct (mailbox (:conc-name mailbox.))    (defstruct (mailbox (:conc-name mailbox.))
1630      thread      thread
1631      (mutex (sb-thread:make-mutex))      (mutex (sb-thread:make-mutex))
1632      (waitqueue  (sb-thread:make-waitqueue))      (waitqueue  (sb-thread:make-waitqueue))
# Line 742  stack." Line 1648  stack."
1648                (nconc (mailbox.queue mbox) (list message)))                (nconc (mailbox.queue mbox) (list message)))
1649          (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))          (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1650    
   (defimplementation receive ()  
     (let* ((mbox (mailbox (sb-thread:current-thread-id)))  
            (mutex (mailbox.mutex mbox)))  
       (sb-thread:with-mutex (mutex)  
         (loop  
          (let ((q (mailbox.queue mbox)))  
            (cond (q (return (pop (mailbox.queue mbox))))  
                  (t (sb-thread:condition-wait (mailbox.waitqueue mbox)  
                                               mutex))))))))  
1651    
1652      (defun condition-timed-wait (waitqueue mutex timeout)
1653        (macrolet ((foo ()
1654                     (cond ((member :sb-lutex *features*) ; Darwin
1655                            '(sb-thread:condition-wait waitqueue mutex))
1656                           (t
1657                            '(handler-case
1658                              (let ((*break-on-signals* nil))
1659                                (sb-sys:with-deadline (:seconds timeout
1660                                                                :override t)
1661                                  (sb-thread:condition-wait waitqueue mutex) t))
1662                              (sb-ext:timeout ()
1663                               nil))))))
1664          (foo)))
1665    
1666      (defimplementation receive-if (test &optional timeout)
1667        (let* ((mbox (mailbox (current-thread)))
1668               (mutex (mailbox.mutex mbox))
1669               (waitq (mailbox.waitqueue mbox)))
1670          (assert (or (not timeout) (eq timeout t)))
1671          (loop
1672           (check-slime-interrupts)
1673           (sb-thread:with-mutex (mutex)
1674             (let* ((q (mailbox.queue mbox))
1675                    (tail (member-if test q)))
1676               (when tail
1677                 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1678                 (return (car tail))))
1679             (when (eq timeout t) (return (values nil t)))
1680             (condition-timed-wait waitq mutex 0.2)))))
1681    
1682      (let ((alist '())
1683            (mutex (sb-thread:make-mutex :name "register-thread")))
1684    
1685        (defimplementation register-thread (name thread)
1686          (declare (type symbol name))
1687          (sb-thread:with-mutex (mutex)
1688            (etypecase thread
1689              (null
1690               (setf alist (delete name alist :key #'car)))
1691              (sb-thread:thread
1692               (let ((probe (assoc name alist)))
1693                 (cond (probe (setf (cdr probe) thread))
1694                       (t (setf alist (acons name thread alist))))))))
1695          nil)
1696    
1697        (defimplementation find-registered (name)
1698          (sb-thread:with-mutex (mutex)
1699            (cdr (assoc name alist)))))
1700    
1701      ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1702      ;; buffer write lock.
1703      ;;
1704      ;; Another alternative would be to grab the world-lock here, but that's less
1705      ;; future-proof, and could introduce other lock-ordering issues in the
1706      ;; future.
1707      ;;
1708      ;; In an ideal world we would just have an :AROUND method on
1709      ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1710      ;; file is loaded -- so first we need a dummy definition that will be
1711      ;; overridden by swank-gray.lisp.
1712      (defclass slime-output-stream (fundamental-character-output-stream)
1713        ())
1714      (defmethod stream-force-output :around ((stream slime-output-stream))
1715        (handler-case
1716            (sb-sys:with-deadline (:seconds 0.1)
1717              (call-next-method))
1718          (sb-sys:deadline-timeout ()
1719            nil)))
1720    )    )
1721    
1722    (defimplementation quit-lisp ()
1723      #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1724      (sb-ext:exit)
1725      #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1726      (progn
1727        #+sb-thread
1728        (dolist (thread (remove (current-thread) (all-threads)))
1729          (ignore-errors (sb-thread:terminate-thread thread)))
1730        (sb-ext:quit)))
1731    
1732    
1733    
1734    ;;Trace implementations
1735    ;;In SBCL, we have:
1736    ;; (trace <name>)
1737    ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1738    ;; (trace (method <name> <qualifier>? (<specializer>+)))
1739    ;; <name> can be a normal name or a (setf name)
1740    
1741    (defun toggle-trace-aux (fspec &rest args)
1742      (cond ((member fspec (eval '(trace)) :test #'equal)
1743             (eval `(untrace ,fspec))
1744             (format nil "~S is now untraced." fspec))
1745            (t
1746             (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1747             (format nil "~S is now traced." fspec))))
1748    
1749    (defun process-fspec (fspec)
1750      (cond ((consp fspec)
1751             (ecase (first fspec)
1752               ((:defun :defgeneric) (second fspec))
1753               ((:defmethod) `(method ,@(rest fspec)))
1754               ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1755               ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1756            (t
1757             fspec)))
1758    
1759    (defimplementation toggle-trace (spec)
1760      (ecase (car spec)
1761        ((setf)
1762         (toggle-trace-aux spec))
1763        ((:defmethod)
1764         (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1765        ((:defgeneric)
1766         (toggle-trace-aux (second spec) :methods t))
1767        ((:call)
1768         (destructuring-bind (caller callee) (cdr spec)
1769           (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1770    
1771    ;;; Weak datastructures
1772    
1773    (defimplementation make-weak-key-hash-table (&rest args)
1774      #+#.(swank-backend::sbcl-with-weak-hash-tables)
1775      (apply #'make-hash-table :weakness :key args)
1776      #-#.(swank-backend::sbcl-with-weak-hash-tables)
1777      (apply #'make-hash-table args))
1778    
1779    (defimplementation make-weak-value-hash-table (&rest args)
1780      #+#.(swank-backend::sbcl-with-weak-hash-tables)
1781      (apply #'make-hash-table :weakness :value args)
1782      #-#.(swank-backend::sbcl-with-weak-hash-tables)
1783      (apply #'make-hash-table args))
1784    
1785    (defimplementation hash-table-weakness (hashtable)
1786      #+#.(swank-backend::sbcl-with-weak-hash-tables)
1787      (sb-ext:hash-table-weakness hashtable))
1788    
1789    #-win32
1790    (defimplementation save-image (filename &optional restart-function)
1791      (flet ((restart-sbcl ()
1792               (sb-debug::enable-debugger)
1793               (setf sb-impl::*descriptor-handlers* nil)
1794               (funcall restart-function)))
1795        (let ((pid (sb-posix:fork)))
1796          (cond ((= pid 0)
1797                 (sb-debug::disable-debugger)
1798                 (apply #'sb-ext:save-lisp-and-die filename
1799                        (when restart-function
1800                          (list :toplevel #'restart-sbcl))))
1801                (t
1802                 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1803                   (assert (= pid rpid))
1804                   (assert (and (sb-posix:wifexited status)
1805                                (zerop (sb-posix:wexitstatus status))))))))))
1806    
1807    #+unix
1808    (progn
1809      (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1810        (program sb-alien:c-string)
1811        (argv (* sb-alien:c-string)))
1812    
1813      (defun execv (program args)
1814        "Replace current executable with another one."
1815        (let ((a-args (sb-alien:make-alien sb-alien:c-string
1816                                           (+ 1 (length args)))))
1817          (unwind-protect
1818               (progn
1819                 (loop for index from 0 by 1
1820                       and item in (append args '(nil))
1821                       do (setf (sb-alien:deref a-args index)
1822                                item))
1823                 (when (minusp
1824                        (sys-execv program a-args))
1825                   (error "execv(3) returned.")))
1826            (sb-alien:free-alien a-args))))
1827    
1828      (defun runtime-pathname ()
1829        #+#.(swank-backend:with-symbol
1830                '*runtime-pathname* 'sb-ext)
1831        sb-ext:*runtime-pathname*
1832        #-#.(swank-backend:with-symbol
1833                '*runtime-pathname* 'sb-ext)
1834        (car sb-ext:*posix-argv*))
1835    
1836      (defimplementation exec-image (image-file args)
1837        (loop with fd-arg =
1838              (loop for arg in args
1839                    and key = "" then arg
1840                    when (string-equal key "--swank-fd")
1841                    return (parse-integer arg))
1842              for my-fd from 3 to 1024
1843              when (/= my-fd fd-arg)
1844              do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1845        (let* ((self-string (pathname-to-filename (runtime-pathname))))
1846          (execv
1847           self-string
1848           (apply 'list self-string "--core" image-file args)))))
1849    
1850    (defimplementation make-fd-stream (fd external-format)
1851      (sb-sys:make-fd-stream fd :input t :output t
1852                             :element-type 'character
1853                             :buffering :full
1854                             :dual-channel-p t
1855                             :external-format external-format))
1856    
1857    #-win32
1858    (defimplementation background-save-image (filename &key restart-function
1859                                                       completion-function)
1860      (flet ((restart-sbcl ()
1861               (sb-debug::enable-debugger)
1862               (setf sb-impl::*descriptor-handlers* nil)
1863               (funcall restart-function)))
1864        (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1865          (let ((pid (sb-posix:fork)))
1866            (cond ((= pid 0)
1867                   (sb-posix:close pipe-in)
1868                   (sb-debug::disable-debugger)
1869                   (apply #'sb-ext:save-lisp-and-die filename
1870                          (when restart-function
1871                            (list :toplevel #'restart-sbcl))))
1872                  (t
1873                   (sb-posix:close pipe-out)
1874                   (sb-sys:add-fd-handler
1875                    pipe-in :input
1876                    (lambda (fd)
1877                      (sb-sys:invalidate-descriptor fd)
1878                      (sb-posix:close fd)
1879                      (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1880                        (assert (= pid rpid))
1881                        (assert (sb-posix:wifexited status))
1882                        (funcall completion-function
1883                                 (zerop (sb-posix:wexitstatus status))))))))))))
1884    
1885    (pushnew 'deinit-log-output sb-ext:*save-hooks*)

Legend:
Removed from v.1.73.2.1  
changed lines
  Added in v.1.328

  ViewVC Help
Powered by ViewVC 1.1.5