/[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.331 by heller, Sun Nov 17 07:59:04 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)  (defun compiler-policy (qualities)
611    (with-compilation-hooks ()    "Return compiler policy qualities present in the QUALITIES alist.
612      (let ((fasl-file (compile-file filename)))  QUALITIES is an alist with (quality . value)"
613        (when (and load-p fasl-file)    #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
614          (load fasl-file)))))    (loop with policy = (sb-ext:restrict-compiler-policy)
615            for (quality) in qualities
616  (defimplementation swank-compile-system (system-name)          collect (cons quality
617    (with-compilation-hooks ()                        (or (cdr (assoc quality policy))
618      (asdf:operate 'asdf:load-op system-name)))                            0))))
619    
620  (defimplementation swank-compile-string (string &key buffer position)  (defun (setf compiler-policy) (policy)
621    (with-compilation-hooks ()    (declare (ignorable policy))
622      (let ((*buffer-name* buffer)    #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
623            (*buffer-offset* position)    (loop for (qual . value) in policy
624            (*buffer-substring* string))          do (sb-ext:restrict-compiler-policy qual value)))
625        (funcall (compile nil (read-from-string  
626                               (format nil "(CL:LAMBDA () ~A)" string)))))))  (defmacro with-compiler-policy (policy &body body)
627      (let ((current-policy (gensym)))
628        `(let ((,current-policy (compiler-policy ,policy)))
629           (setf (compiler-policy) ,policy)
630           (unwind-protect (progn ,@body)
631             (setf (compiler-policy) ,current-policy)))))
632    
633    (defimplementation swank-compile-file (input-file output-file
634                                           load-p external-format
635                                           &key policy)
636      (multiple-value-bind (output-file warnings-p failure-p)
637          (with-compiler-policy policy
638            (with-compilation-hooks ()
639              (compile-file input-file :output-file output-file
640                            :external-format external-format)))
641        (values output-file warnings-p
642                (or failure-p
643                    (when load-p
644                      ;; Cache the latest source file for definition-finding.
645                      (source-cache-get input-file
646                                        (file-write-date input-file))
647                      (not (load output-file)))))))
648    
649    ;;;; compile-string
650    
651    ;;; We copy the string to a temporary file in order to get adequate
652    ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
653    ;;; which the previous approach using
654    ;;;     (compile nil `(lambda () ,(read-from-string string)))
655    ;;; did not provide.
656    
657    (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
658    
659    (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
660        sb-alien:c-string
661      (dir sb-alien:c-string)
662      (prefix sb-alien:c-string))
663    
664    )
665    
666    (defun temp-file-name ()
667      "Return a temporary file name to compile strings into."
668      (tempnam nil nil))
669    
670    (defvar *trap-load-time-warnings* t)
671    
672    (defimplementation swank-compile-string (string &key buffer position filename
673                                             policy)
674      (let ((*buffer-name* buffer)
675            (*buffer-offset* position)
676            (*buffer-substring* string)
677            (*buffer-tmpfile* (temp-file-name)))
678        (labels ((load-it (filename)
679                   (cond (*trap-load-time-warnings*
680                          (with-compilation-hooks () (load filename)))
681                         (t (load filename))))
682                 (cf ()
683                   (with-compiler-policy policy
684                     (with-compilation-unit
685                         (:source-plist (list :emacs-buffer buffer
686                                              :emacs-filename filename
687                                              :emacs-string string
688                                              :emacs-position position)
689                          :source-namestring filename
690                          :allow-other-keys t)
691                       (compile-file *buffer-tmpfile* :external-format :utf-8)))))
692          (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
693                             :external-format :utf-8)
694            (write-string string s))
695          (unwind-protect
696               (multiple-value-bind (output-file warningsp failurep)
697                   (with-compilation-hooks () (cf))
698                 (declare (ignore warningsp))
699                 (when output-file
700                   (load-it output-file))
701                 (not failurep))
702            (ignore-errors
703              (delete-file *buffer-tmpfile*)
704              (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
705    
706  ;;;; Definitions  ;;;; Definitions
707    
708  (defvar *debug-definition-finding* nil  (defparameter *definition-types*
709    "When true don't handle errors while looking for definitions.    '(:variable defvar
710  This is useful when debugging the definition-finding code.")      :constant defconstant
711        :type deftype
712        :symbol-macro define-symbol-macro
713        :macro defmacro
714        :compiler-macro define-compiler-macro
715        :function defun
716        :generic-function defgeneric
717        :method defmethod
718        :setf-expander define-setf-expander
719        :structure defstruct
720        :condition define-condition
721        :class defclass
722        :method-combination define-method-combination
723        :package defpackage
724        :transform :deftransform
725        :optimizer :defoptimizer
726        :vop :define-vop
727        :source-transform :define-source-transform)
728      "Map SB-INTROSPECT definition type names to Slime-friendly forms")
729    
730    (defun definition-specifier (type name)
731      "Return a pretty specifier for NAME representing a definition of type TYPE."
732      (if (and (symbolp name)
733               (eq type :function)
734               (sb-int:info :function :ir1-convert name))
735          :def-ir1-translator
736          (getf *definition-types* type)))
737    
738    (defun make-dspec (type name source-location)
739      (let ((spec (definition-specifier type name))
740            (desc (sb-introspect::definition-source-description source-location)))
741        (if (eq :define-vop spec)
742            ;; The first part of the VOP description is the name of the template
743            ;; -- which is actually good information and often long. So elide the
744            ;; original name in favor of making the interesting bit more visible.
745            ;;
746            ;; The second part of the VOP description is the associated
747            ;; compiler note, or NIL -- which is quite uninteresting and
748            ;; confuses the eye when reading the actual name which usually
749            ;; has a worthwhile postfix. So drop the note.
750            (list spec (car desc))
751            (list* spec name desc))))
752    
753    (defimplementation find-definitions (name)
754      (loop for type in *definition-types* by #'cddr
755            for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
756            append (loop for defsrc in defsrcs collect
757                         (list (make-dspec type name defsrc)
758                               (converting-errors-to-error-location
759                                 (definition-source-for-emacs defsrc
760                                     type name))))))
761    
762    (defimplementation find-source-location (obj)
763      (flet ((general-type-of (obj)
764               (typecase obj
765                 (method             :method)
766                 (generic-function   :generic-function)
767                 (function           :function)
768                 (structure-class    :structure-class)
769                 (class              :class)
770                 (method-combination :method-combination)
771                 (package            :package)
772                 (condition          :condition)
773                 (structure-object   :structure-object)
774                 (standard-object    :standard-object)
775                 (t                  :thing)))
776             (to-string (obj)
777               (typecase obj
778                 ;; Packages are possibly named entities.
779                 (package (princ-to-string obj))
780                 ((or structure-object standard-object condition)
781                  (with-output-to-string (s)
782                    (print-unreadable-object (obj s :type t :identity t))))
783                 (t (princ-to-string obj)))))
784        (converting-errors-to-error-location
785          (let ((defsrc (sb-introspect:find-definition-source obj)))
786            (definition-source-for-emacs defsrc
787                                         (general-type-of obj)
788                                         (to-string obj))))))
789    
790    (defmacro with-definition-source ((&rest names) obj &body body)
791      "Like with-slots but works only for structs."
792      (flet ((reader (slot)
793               ;; Use read-from-string instead of intern so that
794               ;; conc-name can be a string such as ext:struct- and not
795               ;; cause errors and not force interning ext::struct-
796               (read-from-string
797                (concatenate 'string "sb-introspect:definition-source-"
798                             (string slot)))))
799        (let ((tmp (gensym "OO-")))
800          ` (let ((,tmp ,obj))
801              (symbol-macrolet
802                  ,(loop for name in names collect
803                         (typecase name
804                           (symbol `(,name (,(reader name) ,tmp)))
805                           (cons `(,(first name) (,(reader (second name)) ,tmp)))
806                           (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
807                ,@body)))))
808    
809    (defun categorize-definition-source (definition-source)
810      (with-definition-source (pathname form-path character-offset plist)
811        definition-source
812        (let ((file-p (and pathname (probe-file pathname)
813                           (or form-path character-offset))))
814          (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
815                ((getf plist :emacs-buffer) :buffer)
816                (file-p :file)
817                (pathname :file-without-position)
818                (t :invalid)))))
819    
820    (defun definition-source-buffer-location (definition-source)
821      (with-definition-source (form-path character-offset plist) definition-source
822        (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
823                                  emacs-string &allow-other-keys)
824            plist
825          (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
826            (multiple-value-bind (start end)
827                (if form-path
828                    (with-debootstrapping
829                      (source-path-string-position form-path
830                                                   emacs-string))
831                    (values character-offset
832                            most-positive-fixnum))
833              (make-location
834               `(:buffer ,emacs-buffer)
835               `(:offset ,emacs-position ,start)
836               `(:snippet
837                 ,(subseq emacs-string
838                          start
839                          (min end (+ start *source-snippet-size*))))))))))
840    
841    (defun definition-source-file-location (definition-source)
842      (with-definition-source (pathname form-path character-offset plist
843                                        file-write-date) definition-source
844        (let* ((namestring (namestring (translate-logical-pathname pathname)))
845               (pos (if form-path
846                        (source-file-position namestring file-write-date
847                                              form-path)
848                        character-offset))
849               (snippet (source-hint-snippet namestring file-write-date pos)))
850          (make-location `(:file ,namestring)
851                         ;; /file positions/ in Common Lisp start from
852                         ;; 0, buffer positions in Emacs start from 1.
853                         `(:position ,(1+ pos))
854                         `(:snippet ,snippet)))))
855    
856    (defun definition-source-buffer-and-file-location (definition-source)
857      (let ((buffer (definition-source-buffer-location definition-source))
858            (file (definition-source-file-location definition-source)))
859        (make-location (list :buffer-and-file
860                             (cadr (location-buffer buffer))
861                             (cadr (location-buffer file)))
862                       (location-position buffer)
863                       (location-hints buffer))))
864    
865    (defun definition-source-for-emacs (definition-source type name)
866      (with-definition-source (pathname form-path character-offset plist
867                                        file-write-date)
868          definition-source
869        (ecase (categorize-definition-source definition-source)
870          (:buffer-and-file
871           (definition-source-buffer-and-file-location definition-source))
872          (:buffer
873           (definition-source-buffer-location definition-source))
874          (:file
875           (definition-source-file-location definition-source))
876          (:file-without-position
877           (make-location `(:file ,(namestring
878                                    (translate-logical-pathname pathname)))
879                          '(:position 1)
880                          (when (eql type :function)
881                            `(:snippet ,(format nil "(defun ~a "
882                                                (symbol-name name))))))
883          (:invalid
884           (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
885                   meaningful information."
886                  type name)))))
887    
888    (defun source-file-position (filename write-date form-path)
889      (let ((source (get-source-code filename write-date))
890            (*readtable* (guess-readtable-for-filename filename)))
891        (with-debootstrapping
892          (source-path-string-position form-path source))))
893    
894  ;;; FIXME we don't handle the compiled-interactively case yet.  That  (defun source-hint-snippet (filename write-date position)
895  ;;; 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))))))))))  
896    
897  (defimplementation find-definitions (symbol)  (defun function-source-location (function &optional name)
898    (function-definitions symbol))    (declare (type function function))
899      (definition-source-for-emacs (sb-introspect:find-definition-source function)
900                                   :function
901                                   (or name (function-name function))))
902    
903  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
904    "Return a plist describing SYMBOL.    "Return a plist describing SYMBOL.
905  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
906    (let ((result '()))    (let ((result '()))
907      (labels ((doc (kind)      (flet ((doc (kind)
908                 (or (documentation symbol kind) :not-documented))               (or (documentation symbol kind) :not-documented))
909               (maybe-push (property value)             (maybe-push (property value)
910                 (when value               (when value
911                   (setf result (list* property value result)))))                 (setf result (list* property value result)))))
912        (maybe-push        (maybe-push
913         :variable (multiple-value-bind (kind recorded-p)         :variable (multiple-value-bind (kind recorded-p)
914                       (sb-int:info :variable :kind symbol)                       (sb-int:info :variable :kind symbol)
915                     (declare (ignore kind))                     (declare (ignore kind))
916                     (if (or (boundp symbol) recorded-p)                     (if (or (boundp symbol) recorded-p)
917                         (doc 'variable))))                         (doc 'variable))))
918        (maybe-push        (when (fboundp symbol)
919         :function (if (fboundp symbol)          (maybe-push
920                       (doc 'function)))           (cond ((macro-function symbol)     :macro)
921                   ((special-operator-p symbol) :special-operator)
922                   ((typep (fdefinition symbol) 'generic-function)
923                    :generic-function)
924                   (t :function))
925             (doc 'function)))
926        (maybe-push        (maybe-push
927         :setf (if (or (sb-int:info :setf :inverse symbol)         :setf (if (or (sb-int:info :setf :inverse symbol)
928                       (sb-int:info :setf :expander symbol))                       (sb-int:info :setf :expander symbol))
# Line 435  Return NIL if the symbol is unbound." Line 945  Return NIL if the symbol is unbound."
945       (describe (find-class symbol)))       (describe (find-class symbol)))
946      (:type      (:type
947       (describe (sb-kernel:values-specifier-type symbol)))))       (describe (sb-kernel:values-specifier-type symbol)))))
948    
949    #+#.(swank-backend::sbcl-with-xref-p)
950    (progn
951      (defmacro defxref (name &optional fn-name)
952        `(defimplementation ,name (what)
953           (sanitize-xrefs
954            (mapcar #'source-location-for-xref-data
955                    (,(find-symbol (symbol-name (if fn-name
956                                                    fn-name
957                                                    name))
958                                   "SB-INTROSPECT")
959                      what)))))
960      (defxref who-calls)
961      (defxref who-binds)
962      (defxref who-sets)
963      (defxref who-references)
964      (defxref who-macroexpands)
965      #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
966      (defxref who-specializes who-specializes-directly))
967    
968    (defun source-location-for-xref-data (xref-data)
969      (destructuring-bind (name . defsrc) xref-data
970        (list name (converting-errors-to-error-location
971                     (definition-source-for-emacs defsrc 'function name)))))
972    
973    (defimplementation list-callers (symbol)
974      (let ((fn (fdefinition symbol)))
975        (sanitize-xrefs
976         (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
977    
978    (defimplementation list-callees (symbol)
979      (let ((fn (fdefinition symbol)))
980        (sanitize-xrefs
981         (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
982    
983    (defun sanitize-xrefs (xrefs)
984      (remove-duplicates
985       (remove-if (lambda (f)
986                    (member f (ignored-xref-function-names)))
987                  (loop for entry in xrefs
988                        for name = (car entry)
989                        collect (if (and (consp name)
990                                         (member (car name)
991                                                 '(sb-pcl::fast-method
992                                                   sb-pcl::slow-method
993                                                   sb-pcl::method)))
994                                    (cons (cons 'defmethod (cdr name))
995                                          (cdr entry))
996                                    entry))
997                  :key #'car)
998       :test (lambda (a b)
999               (and (eq (first a) (first b))
1000                    (equal (second a) (second b))))))
1001    
1002    (defun ignored-xref-function-names ()
1003      #-#.(swank-backend::sbcl-with-new-stepper-p)
1004      '(nil sb-c::step-form sb-c::step-values)
1005      #+#.(swank-backend::sbcl-with-new-stepper-p)
1006      '(nil))
1007    
1008    (defun function-dspec (fn)
1009      "Describe where the function FN was defined.
1010    Return a list of the form (NAME LOCATION)."
1011      (let ((name (function-name fn)))
1012        (list name (converting-errors-to-error-location
1013                     (function-source-location fn name)))))
1014    
1015  ;;; macroexpansion  ;;; macroexpansion
1016    
# Line 445  Return NIL if the symbol is unbound." Line 1021  Return NIL if the symbol is unbound."
1021    
1022  ;;; Debugging  ;;; Debugging
1023    
1024    ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1025    ;;; than just a hook into BREAK. In particular, it'll make
1026    ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1027    ;;; than the native debugger. That should probably be considered a
1028    ;;; feature.
1029    
1030    (defun make-invoke-debugger-hook (hook)
1031      (when hook
1032        #'(sb-int:named-lambda swank-invoke-debugger-hook
1033              (condition old-hook)
1034            (if *debugger-hook*
1035                nil         ; decline, *DEBUGGER-HOOK* will be tried next.
1036                (funcall hook condition old-hook)))))
1037    
1038    (defun set-break-hook (hook)
1039      (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1040    
1041    (defun call-with-break-hook (hook continuation)
1042      (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1043        (funcall continuation)))
1044    
1045    (defimplementation install-debugger-globally (function)
1046      (setq *debugger-hook* function)
1047      (set-break-hook function))
1048    
1049    (defimplementation condition-extras (condition)
1050      (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1051            ((typep condition 'sb-impl::step-form-condition)
1052             `((:show-frame-source 0)))
1053            ((typep condition 'sb-int:reference-condition)
1054             (let ((refs (sb-int:reference-condition-references condition)))
1055               (if refs
1056                   `((:references ,(externalize-reference refs))))))))
1057    
1058    (defun externalize-reference (ref)
1059      (etypecase ref
1060        (null nil)
1061        (cons (cons (externalize-reference (car ref))
1062                    (externalize-reference (cdr ref))))
1063        ((or string number) ref)
1064        (symbol
1065         (cond ((eq (symbol-package ref) (symbol-package :test))
1066                ref)
1067               (t (symbol-name ref))))))
1068    
1069  (defvar *sldb-stack-top*)  (defvar *sldb-stack-top*)
1070    
1071  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
1072    (declare (type function debugger-loop-fn))    (declare (type function debugger-loop-fn))
1073    (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))    (let ((*sldb-stack-top*
1074           (sb-debug:*stack-top-hint* nil))            (if (and (not *debug-swank-backend*)
1075      (handler-bind ((sb-di:debug-condition                     sb-debug:*stack-top-hint*)
1076                      (lambda (condition)                #+#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1077                        (signal (make-condition                (sb-debug::resolve-stack-top-hint)
1078                                 'sldb-condition                #-#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1079                                 :original-condition condition)))))                sb-debug:*stack-top-hint*
1080                  (sb-di:top-frame)))
1081            (sb-debug:*stack-top-hint* nil))
1082        (handler-bind ((sb-di:debug-condition
1083                         (lambda (condition)
1084                           (signal 'sldb-condition
1085                                   :original-condition condition))))
1086        (funcall debugger-loop-fn))))        (funcall debugger-loop-fn))))
1087    
1088    #+#.(swank-backend::sbcl-with-new-stepper-p)
1089    (progn
1090      (defimplementation activate-stepping (frame)
1091        (declare (ignore frame))
1092        (sb-impl::enable-stepping))
1093      (defimplementation sldb-stepper-condition-p (condition)
1094        (typep condition 'sb-ext:step-form-condition))
1095      (defimplementation sldb-step-into ()
1096        (invoke-restart 'sb-ext:step-into))
1097      (defimplementation sldb-step-next ()
1098        (invoke-restart 'sb-ext:step-next))
1099      (defimplementation sldb-step-out ()
1100        (invoke-restart 'sb-ext:step-out)))
1101    
1102    (defimplementation call-with-debugger-hook (hook fun)
1103      (let ((*debugger-hook* hook)
1104            #+#.(swank-backend::sbcl-with-new-stepper-p)
1105            (sb-ext:*stepper-hook*
1106             (lambda (condition)
1107               (typecase condition
1108                 (sb-ext:step-form-condition
1109                  (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1110                    (sb-impl::invoke-debugger condition)))))))
1111        (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1112                       (sb-ext:step-condition #'sb-impl::invoke-stepper))
1113          (call-with-break-hook hook fun))))
1114    
1115  (defun nth-frame (index)  (defun nth-frame (index)
1116    (do ((frame *sldb-stack-top* (sb-di:frame-down frame))    (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1117         (i index (1- i)))         (i index (1- i)))
# Line 470  stack." Line 1124  stack."
1124    (let ((end (or end most-positive-fixnum)))    (let ((end (or end most-positive-fixnum)))
1125      (loop for f = (nth-frame start) then (sb-di:frame-down f)      (loop for f = (nth-frame start) then (sb-di:frame-down f)
1126            for i from start below end            for i from start below end
1127            while f            while f collect f)))
           collect f)))  
1128    
1129  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
1130    (let ((*standard-output* stream))    (sb-debug::print-frame-call frame stream))
     (sb-debug::print-frame-call frame :verbosity 1 :number nil)))  
1131    
1132  (defun code-location-source-path (code-location)  (defimplementation frame-restartable-p (frame)
1133    (let* ((location (sb-debug::maybe-block-start-location code-location))    #+#.(swank-backend::sbcl-with-restart-frame)
1134           (form-num (sb-di:code-location-form-number location)))    (not (null (sb-debug:frame-has-debug-tag-p frame))))
1135      (let ((translations (sb-debug::get-toplevel-form location)))  
1136        (unless (< form-num (length translations))  (defimplementation frame-call (frame-number)
1137          (error "Source path no longer exists."))    (multiple-value-bind (name args)
1138        (reverse (cdr (svref translations form-num))))))        (sb-debug::frame-call (nth-frame frame-number))
1139        (with-output-to-string (stream)
1140  (defun code-location-file-position (code-location)        (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1141    (let* ((debug-source (sb-di:code-location-debug-source code-location))          (let ((*print-length* nil)
1142           (filename (sb-di:debug-source-name debug-source))                (*print-level* nil))
1143           (path (code-location-source-path code-location)))            (prin1 (sb-debug::ensure-printable-object name) stream))
1144      (source-path-file-position path filename)))          (let ((args (sb-debug::ensure-printable-object args)))
1145              (if (listp args)
1146                  (format stream "~{ ~_~S~}" args)
1147                  (format stream " ~S" args)))))))
1148    
1149    ;;;; Code-location -> source-location translation
1150    
1151    ;;; If debug-block info is avaibale, we determine the file position of
1152    ;;; the source-path for a code-location.  If the code was compiled
1153    ;;; with C-c C-c, we have to search the position in the source string.
1154    ;;; If there's no debug-block info, we return the (less precise)
1155    ;;; source-location of the corresponding function.
1156    
1157    (defun code-location-source-location (code-location)
1158      (let* ((dsource (sb-di:code-location-debug-source code-location))
1159             (plist (sb-c::debug-source-plist dsource)))
1160        (if (getf plist :emacs-buffer)
1161            (emacs-buffer-source-location code-location plist)
1162            #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1163            (ecase (sb-di:debug-source-from dsource)
1164              (:file (file-source-location code-location))
1165              (:lisp (lisp-source-location code-location)))
1166            #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1167            (if (sb-di:debug-source-namestring dsource)
1168                (file-source-location code-location)
1169                (lisp-source-location code-location)))))
1170    
1171    ;;; FIXME: The naming policy of source-location functions is a bit
1172    ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1173    ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1174    ;;; which returns the source location for a _code-location_.
1175    ;;;
1176    ;;; Maybe these should be named code-location-file-source-location,
1177    ;;; etc, turned into generic functions, or something. In the very
1178    ;;; least the names should indicate the main entry point vs. helper
1179    ;;; status.
1180    
1181    (defun file-source-location (code-location)
1182      (if (code-location-has-debug-block-info-p code-location)
1183          (source-file-source-location code-location)
1184          (fallback-source-location code-location)))
1185    
1186    (defun fallback-source-location (code-location)
1187      (let ((fun (code-location-debug-fun-fun code-location)))
1188        (cond (fun (function-source-location fun))
1189              (t (error "Cannot find source location for: ~A " code-location)))))
1190    
1191    (defun lisp-source-location (code-location)
1192      (let ((source (prin1-to-string
1193                     (sb-debug::code-location-source-form code-location 100)))
1194            (condition (swank-value '*swank-debugger-condition*)))
1195        (if (and (typep condition 'sb-impl::step-form-condition)
1196                 (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1197                         :test #'char-equal)
1198                 (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1199            ;; The initial form is utterly uninteresting -- and almost
1200            ;; certainly right there in the REPL.
1201            (make-error-location "Stepping...")
1202            (make-location `(:source-form ,source) '(:position 1)))))
1203    
1204    (defun emacs-buffer-source-location (code-location plist)
1205      (if (code-location-has-debug-block-info-p code-location)
1206          (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1207                                    &allow-other-keys)
1208              plist
1209            (let* ((pos (string-source-position code-location emacs-string))
1210                   (snipped (read-snippet-from-string emacs-string pos)))
1211              (make-location `(:buffer ,emacs-buffer)
1212                             `(:offset ,emacs-position ,pos)
1213                             `(:snippet ,snipped))))
1214          (fallback-source-location code-location)))
1215    
1216    (defun source-file-source-location (code-location)
1217      (let* ((code-date (code-location-debug-source-created code-location))
1218             (filename (code-location-debug-source-name code-location))
1219             (*readtable* (guess-readtable-for-filename filename))
1220             (source-code (get-source-code filename code-date)))
1221        (with-debootstrapping
1222          (with-input-from-string (s source-code)
1223            (let* ((pos (stream-source-position code-location s))
1224                   (snippet (read-snippet s pos)))
1225              (make-location `(:file ,filename)
1226                             `(:position ,pos)
1227                             `(:snippet ,snippet)))))))
1228    
1229    (defun code-location-debug-source-name (code-location)
1230      (namestring (truename (#+#.(swank-backend:with-symbol
1231                                  'debug-source-name 'sb-di)
1232                                 sb-c::debug-source-name
1233                                 #-#.(swank-backend:with-symbol
1234                                      'debug-source-name 'sb-di)
1235                                 sb-c::debug-source-namestring
1236                             (sb-di::code-location-debug-source code-location)))))
1237    
1238    (defun code-location-debug-source-created (code-location)
1239      (sb-c::debug-source-created
1240       (sb-di::code-location-debug-source code-location)))
1241    
1242    (defun code-location-debug-fun-fun (code-location)
1243      (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1244    
1245    (defun code-location-has-debug-block-info-p (code-location)
1246      (handler-case
1247          (progn (sb-di:code-location-debug-block code-location)
1248                 t)
1249        (sb-di:no-debug-blocks  () nil)))
1250    
1251    (defun stream-source-position (code-location stream)
1252      (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1253             (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1254             (form-number (sb-di::code-location-form-number cloc)))
1255        (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1256          (let* ((path-table (sb-di::form-number-translations tlf 0))
1257                 (path (cond ((<= (length path-table) form-number)
1258                              (warn "inconsistent form-number-translations")
1259                              (list 0))
1260                             (t
1261                              (reverse (cdr (aref path-table form-number)))))))
1262            (source-path-source-position path tlf pos-map)))))
1263    
1264    (defun string-source-position (code-location string)
1265      (with-input-from-string (s string)
1266        (stream-source-position code-location s)))
1267    
1268  ;;; source-path-file-position and friends are in swank-source-path-parser  ;;; source-path-file-position and friends are in swank-source-path-parser
1269    
1270  (defun debug-source-info-from-emacs-buffer-p (debug-source)  (defimplementation frame-source-location (index)
1271    (let ((info (sb-c::debug-source-info debug-source)))    (converting-errors-to-error-location
1272      (and info      (code-location-source-location
1273           (consp info)       (sb-di:frame-code-location (nth-frame index)))))
1274           (eq :emacs-buffer (car info)))))  
1275    (defvar *keep-non-valid-locals* nil)
1276  (defun source-location-for-emacs (code-location)  
1277    (let* ((debug-source (sb-di:code-location-debug-source code-location))  (defun frame-debug-vars (frame)
1278           (from (sb-di:debug-source-from debug-source))    "Return a vector of debug-variables in frame."
1279           (name (sb-di:debug-source-name debug-source)))    (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
1280      (ecase from      (cond (*keep-non-valid-locals* all-vars)
1281        (:file            (t (let ((loc (sb-di:frame-code-location frame)))
1282         (let ((source-path (ignore-errors                 (remove-if (lambda (var)
1283                              (code-location-source-path code-location))))                              (ecase (sb-di:debug-var-validity var loc)
1284           (cond (source-path                                (:valid nil)
1285                  ;; XXX: code-location-source-path reads the source !!                                ((:invalid :unknown) t)))
1286                  (let ((position (code-location-file-position code-location)))                            all-vars))))))
1287                    (make-location  
1288                     (list :file (namestring (truename name)))  (defun debug-var-value (var frame location)
1289                     (list :source-path source-path position))))    (ecase (sb-di:debug-var-validity var location)
1290                 (t      (:valid (sb-di:debug-var-value var frame))
1291                  (let* ((dfn (sb-di:code-location-debug-fun code-location))      ((:invalid :unknown) ':<not-available>)))
1292                         (fn (sb-di:debug-fun-fun dfn)))  
1293                    (unless fn  (defun debug-var-info (var)
1294                      (error "Cannot find source location for: ~A "    ;; Introduced by SBCL 1.0.49.76.
1295                             code-location))    (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1296                    (function-source-location      (when (and s (fboundp s))
1297                     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))))  
1298    
1299  (defimplementation frame-locals (index)  (defimplementation frame-locals (index)
1300    (let* ((frame (nth-frame index))    (let* ((frame (nth-frame index))
1301           (location (sb-di:frame-code-location frame))           (loc (sb-di:frame-code-location frame))
1302           (debug-function (sb-di:frame-debug-fun frame))           (vars (frame-debug-vars frame))
1303           (debug-variables (sb-di::debug-fun-debug-vars debug-function)))           ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1304      (declare (type (or null simple-vector) debug-variables))           ;; specially.
1305      (loop for v across debug-variables           (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1306            collect (list           (more-context nil)
1307                     :name (sb-di:debug-var-symbol v)           (more-count nil)
1308                     :id (sb-di:debug-var-id v)           (more-id 0))
1309                     :value (if (eq (sb-di:debug-var-validity v location)      (when vars
1310                                    :valid)        (let ((locals
1311                                (sb-di:debug-var-value v frame)                (loop for v across vars
1312                                '#:<not-available>)))))                      do (when (eq (sb-di:debug-var-symbol v) more-name)
1313                             (incf more-id))
1314                           (case (debug-var-info v)
1315                             (:more-context
1316                              (setf more-context (debug-var-value v frame loc)))
1317                             (:more-count
1318                              (setf more-count (debug-var-value v frame loc))))
1319                        collect
1320                           (list :name (sb-di:debug-var-symbol v)
1321                                 :id (sb-di:debug-var-id v)
1322                                 :value (debug-var-value v frame loc)))))
1323            (when (and more-context more-count)
1324              (setf locals (append locals
1325                                   (list
1326                                    (list :name more-name
1327                                          :id more-id
1328                                          :value (multiple-value-list
1329                                                  (sb-c:%more-arg-values
1330                                                   more-context
1331                                                   0 more-count)))))))
1332            locals))))
1333    
1334    (defimplementation frame-var-value (frame var)
1335      (let* ((frame (nth-frame frame))
1336             (vars (frame-debug-vars frame))
1337             (loc (sb-di:frame-code-location frame))
1338             (dvar (if (= var (length vars))
1339                       ;; If VAR is out of bounds, it must be the fake var
1340                       ;; we made up for &MORE.
1341                       (let* ((context-var (find :more-context vars
1342                                                 :key #'debug-var-info))
1343                              (more-context (debug-var-value context-var frame
1344                                                             loc))
1345                              (count-var (find :more-count vars
1346                                               :key #'debug-var-info))
1347                              (more-count (debug-var-value count-var frame loc)))
1348                         (return-from frame-var-value
1349                           (multiple-value-list (sb-c:%more-arg-values
1350                                                 more-context
1351                                                 0 more-count))))
1352                       (aref vars var))))
1353        (debug-var-value dvar frame loc)))
1354    
1355  (defimplementation frame-catch-tags (index)  (defimplementation frame-catch-tags (index)
1356    (mapcar #'car (sb-di:frame-catches (nth-frame index))))    (mapcar #'car (sb-di:frame-catches (nth-frame index))))
# Line 558  stack." Line 1358  stack."
1358  (defimplementation eval-in-frame (form index)  (defimplementation eval-in-frame (form index)
1359    (let ((frame (nth-frame index)))    (let ((frame (nth-frame index)))
1360      (funcall (the function      (funcall (the function
1361                 (sb-di:preprocess-for-eval form                 (sb-di:preprocess-for-eval form
1362                                            (sb-di:frame-code-location frame)))                                            (sb-di:frame-code-location frame)))
1363               frame)))               frame)))
1364    
1365  (defun sb-debug-catch-tag-p (tag)  (defimplementation frame-package (frame-number)
1366    (and (symbolp tag)    (let* ((frame (nth-frame frame-number))
1367         (not (symbol-package tag))           (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
1368         (string= tag :sb-debug-catch-tag)))      (when fun
1369          (let ((name (function-name fun)))
1370            (typecase name
1371              (null nil)
1372              (symbol (symbol-package name))
1373              ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
1374    
1375    #+#.(swank-backend::sbcl-with-restart-frame)
1376    (progn
1377      (defimplementation return-from-frame (index form)
1378        (let* ((frame (nth-frame index)))
1379          (cond ((sb-debug:frame-has-debug-tag-p frame)
1380                 (let ((values (multiple-value-list (eval-in-frame form index))))
1381                   (sb-debug:unwind-to-frame-and-call frame
1382                                                       (lambda ()
1383                                                         (values-list values)))))
1384                (t (format nil "Cannot return from frame: ~S" frame)))))
1385    
1386      (defimplementation restart-frame (index)
1387        (let ((frame (nth-frame index)))
1388          (when (sb-debug:frame-has-debug-tag-p frame)
1389            (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1390              (multiple-value-bind (fun arglist)
1391                  (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1392                      (values (fdefinition fname) args)
1393                      (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1394                              (sb-debug::frame-args-as-list frame)))
1395                (when (functionp fun)
1396                  (sb-debug:unwind-to-frame-and-call
1397                   frame
1398                   (lambda ()
1399                     ;; Ensure TCO.
1400                     (declare (optimize (debug 0)))
1401                     (apply fun arglist)))))))
1402          (format nil "Cannot restart frame: ~S" frame))))
1403    
1404    ;; FIXME: this implementation doesn't unwind the stack before
1405    ;; re-invoking the function, but it's better than no implementation at
1406    ;; all.
1407    #-#.(swank-backend::sbcl-with-restart-frame)
1408    (progn
1409      (defun sb-debug-catch-tag-p (tag)
1410        (and (symbolp tag)
1411             (not (symbol-package tag))
1412             (string= tag :sb-debug-catch-tag)))
1413    
1414      (defimplementation return-from-frame (index form)
1415        (let* ((frame (nth-frame index))
1416               (probe (assoc-if #'sb-debug-catch-tag-p
1417                                (sb-di::frame-catches frame))))
1418          (cond (probe (throw (car probe) (eval-in-frame form index)))
1419                (t (format nil "Cannot return from frame: ~S" frame)))))
1420    
1421      (defimplementation restart-frame (index)
1422        (let ((frame (nth-frame index)))
1423          (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1424    
1425    ;;;;; reference-conditions
1426    
1427    (defimplementation format-sldb-condition (condition)
1428      (let ((sb-int:*print-condition-references* nil))
1429        (princ-to-string condition)))
1430    
 (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)))))  
   
1431    
1432  ;;;; Profiling  ;;;; Profiling
1433    
# Line 597  stack." Line 1451  stack."
1451  (defimplementation profiled-functions ()  (defimplementation profiled-functions ()
1452    (sb-profile:profile))    (sb-profile:profile))
1453    
1454    (defimplementation profile-package (package callers methods)
1455      (declare (ignore callers methods))
1456      (eval `(sb-profile:profile ,(package-name (find-package package)))))
1457    
1458    
1459  ;;;; Inspector  ;;;; Inspector
1460    
1461  (defmethod inspected-parts (o)  (defmethod emacs-inspect ((o t))
1462    (cond ((sb-di::indirect-value-cell-p o)    (cond ((sb-di::indirect-value-cell-p o)
1463           (inspected-parts-of-value-cell o))           (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1464          (t          (t
1465           (multiple-value-bind (text labeledp parts)           (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1466               (sb-impl::inspected-parts o)             (list* (string-right-trim '(#\Newline) text)
1467             (let ((parts (if labeledp                    '(:newline)
1468                              (loop for (label . value) in parts                    (if label
1469                                    collect (cons (string label) value))                        (loop for (l . v) in parts
1470                              (loop for value in parts                              append (label-value-line l v))
1471                                    for i from 0                        (loop for value in parts
1472                                    collect (cons (format nil "~D" i) value)))))                              for i from 0
1473               (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)))))  
1474    
1475  (defmethod inspected-parts ((o function))  (defmethod emacs-inspect ((o function))
1476    (let ((header (sb-kernel:widetag-of o)))    (let ((header (sb-kernel:widetag-of o)))
1477      (cond ((= header sb-vm:simple-fun-header-widetag)      (cond ((= header sb-vm:simple-fun-header-widetag)
1478             (values                     (label-value-line*
1479              (format nil "~A~% is a simple-fun." o)                      (:name (sb-kernel:%simple-fun-name o))
1480              (list (cons "Self" (sb-kernel:%simple-fun-self o))                      (:arglist (sb-kernel:%simple-fun-arglist o))
1481                    (cons "Next" (sb-kernel:%simple-fun-next o))                      (:self (sb-kernel:%simple-fun-self o))
1482                    (cons "Name" (sb-kernel:%simple-fun-name o))                      (:next (sb-kernel:%simple-fun-next o))
1483                    (cons "Arglist" (sb-kernel:%simple-fun-arglist o))                      (:type (sb-kernel:%simple-fun-type o))
1484                    (cons "Type" (sb-kernel:%simple-fun-type o))                      (:code (sb-kernel:fun-code-header o))))
                   (cons "Code Object" (sb-kernel:fun-code-header o)))))  
1485            ((= header sb-vm:closure-header-widetag)            ((= header sb-vm:closure-header-widetag)
1486             (values (format nil "~A~% is a closure." o)                     (append
1487                     (list*                      (label-value-line :function (sb-kernel:%closure-fun o))
1488                      (cons "Function" (sb-kernel:%closure-fun o))                      `("Closed over values:" (:newline))
1489                      (loop for i from 0                      (loop for i below (1- (sb-kernel:get-closure-length o))
1490                            below (- (sb-kernel:get-closure-length o)                            append (label-value-line
1491                                     (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))))))  
1492            (t (call-next-method o)))))            (t (call-next-method o)))))
1493    
1494  (defmethod inspected-parts ((o sb-kernel:code-component))  (defmethod emacs-inspect ((o sb-kernel:code-component))
1495    (values (format nil "~A~% is a code data-block." o)            (append
1496            `(("First entry point" . ,(sb-kernel:%code-entry-points o))             (label-value-line*
1497              ,@(loop for i from sb-vm:code-constants-offset              (:code-size (sb-kernel:%code-code-size o))
1498                      below (sb-kernel:get-header-data o)              (:entry-points (sb-kernel:%code-entry-points o))
1499                      collect (cons (format nil "Constant#~D" i)              (:debug-info (sb-kernel:%code-debug-info o))
1500                                    (sb-kernel:code-header-ref o i)))              (:trace-table-offset (sb-kernel:code-header-ref
1501              ("Debug info" . ,(sb-kernel:%code-debug-info o))                                    o sb-vm:code-trace-table-offset-slot)))
1502              ("Instructions"  . ,(sb-kernel:code-instructions o)))))             `("Constants:" (:newline))
1503               (loop for i from sb-vm:code-constants-offset
1504  (defmethod inspected-parts ((o sb-kernel:fdefn))                   below (sb-kernel:get-header-data o)
1505    (values (format nil "~A~% is a fdefn object." o)                   append (label-value-line i (sb-kernel:code-header-ref o i)))
1506            `(("Name" . ,(sb-kernel:fdefn-name o))             `("Code:" (:newline)
1507              ("Function" . ,(sb-kernel:fdefn-fun o)))))               , (with-output-to-string (s)
1508                     (cond ((sb-kernel:%code-debug-info o)
1509                            (sb-disassem:disassemble-code-component o :stream s))
1510  (defmethod inspected-parts ((o generic-function))                         (t
1511    (values (format nil "~A~% is a generic function." o)                          (sb-disassem:disassemble-memory
1512            (list                           (sb-disassem::align
1513             (cons "Method-Class" (sb-pcl:generic-function-method-class o))                            (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1514             (cons "Methods" (sb-pcl:generic-function-methods o))                                         sb-vm:lowtag-mask)
1515             (cons "Name" (sb-pcl:generic-function-name o))                               (* sb-vm:code-constants-offset
1516             (cons "Declarations" (sb-pcl:generic-function-declarations o))                                  sb-vm:n-word-bytes))
1517             (cons "Method-Combination"                            (ash 1 sb-vm:n-lowtag-bits))
1518                   (sb-pcl:generic-function-method-combination o))                           (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1519             (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))                           :stream s)))))))
1520             (cons "Precedence-Order"  
1521                   (sb-pcl:generic-function-argument-precedence-order o))  (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1522             (cons "Pretty-Arglist"            (label-value-line*
1523                   (sb-pcl::generic-function-pretty-arglist o))             (:value (sb-ext:weak-pointer-value o))))
1524             (cons "Initial-Methods"  
1525                   (sb-pcl::generic-function-initial-methods  o)))))  (defmethod emacs-inspect ((o sb-kernel:fdefn))
1526              (label-value-line*
1527               (:name (sb-kernel:fdefn-name o))
1528               (:function (sb-kernel:fdefn-fun o))))
1529    
1530    (defmethod emacs-inspect :around ((o generic-function))
1531                (append
1532                 (call-next-method)
1533                 (label-value-line*
1534                  (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1535                  (:initial-methods (sb-pcl::generic-function-initial-methods o))
1536                  )))
1537    
1538    
1539  ;;;; Multiprocessing  ;;;; Multiprocessing
1540    
1541  #+SB-THREAD  #+(and sb-thread
1542           #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1543  (progn  (progn
1544      (defvar *thread-id-counter* 0)
1545    
1546      (defvar *thread-id-counter-lock*
1547        (sb-thread:make-mutex :name "thread id counter lock"))
1548    
1549      (defun next-thread-id ()
1550        (sb-thread:with-mutex (*thread-id-counter-lock*)
1551          (incf *thread-id-counter*)))
1552    
1553      (defparameter *thread-id-map* (make-hash-table))
1554    
1555      ;; This should be a thread -> id map but as weak keys are not
1556      ;; supported it is id -> map instead.
1557      (defvar *thread-id-map-lock*
1558        (sb-thread:make-mutex :name "thread id map lock"))
1559    
1560    (defimplementation spawn (fn &key name)    (defimplementation spawn (fn &key name)
1561      (declare (ignore name))      (sb-thread:make-thread fn :name name))
     (sb-thread:make-thread fn))  
1562    
1563    (defimplementation startup-multiprocessing ()    (defimplementation thread-id (thread)
1564      (setq *swank-in-background* :spawn))      (block thread-id
1565          (sb-thread:with-mutex (*thread-id-map-lock*)
1566            (loop for id being the hash-key in *thread-id-map*
1567                  using (hash-value thread-pointer)
1568                  do
1569                  (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1570                    (cond ((null maybe-thread)
1571                           ;; the value is gc'd, remove it manually
1572                           (remhash id *thread-id-map*))
1573                          ((eq thread maybe-thread)
1574                           (return-from thread-id id)))))
1575            ;; lazy numbering
1576            (let ((id (next-thread-id)))
1577              (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1578              id))))
1579    
1580      (defimplementation find-thread (id)
1581        (sb-thread:with-mutex (*thread-id-map-lock*)
1582          (let ((thread-pointer (gethash id *thread-id-map*)))
1583            (if thread-pointer
1584                (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1585                  (if maybe-thread
1586                      maybe-thread
1587                      ;; the value is gc'd, remove it manually
1588                      (progn
1589                        (remhash id *thread-id-map*)
1590                        nil)))
1591                nil))))
1592    
1593    (defimplementation thread-name (thread)    (defimplementation thread-name (thread)
1594      (format nil "Thread ~D" thread))      ;; sometimes the name is not a string (e.g. NIL)
1595        (princ-to-string (sb-thread:thread-name thread)))
1596    
1597    (defimplementation thread-status (thread)    (defimplementation thread-status (thread)
1598      (declare (ignore thread))      (if (sb-thread:thread-alive-p thread)
1599      "???")          "Running"
1600            "Stopped"))
1601    
1602    (defimplementation make-lock (&key name)    (defimplementation make-lock (&key name)
1603      (sb-thread:make-mutex :name name))      (sb-thread:make-mutex :name name))
1604    
1605    (defimplementation call-with-lock-held (lock function)    (defimplementation call-with-lock-held (lock function)
1606      (declare (type function function))      (declare (type function function))
1607      (sb-thread:with-mutex (lock) (funcall function)))      (sb-thread:with-recursive-lock (lock) (funcall function)))
1608    
1609    (defimplementation current-thread ()    (defimplementation current-thread ()
1610      (sb-thread:current-thread-id))      sb-thread:*current-thread*)
1611    
1612    (defimplementation all-threads ()    (defimplementation all-threads ()
1613      (sb-thread::mapcar-threads      (sb-thread:list-all-threads))
1614       (lambda (sap)  
        (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes  
                                  sb-vm::thread-pid-slot)))))  
   
1615    (defimplementation interrupt-thread (thread fn)    (defimplementation interrupt-thread (thread fn)
1616      (sb-thread:interrupt-thread thread fn))      (sb-thread:interrupt-thread thread fn))
1617    
1618    (defimplementation kill-thread (thread)    (defimplementation kill-thread (thread)
1619      (sb-thread:terminate-thread thread))      (sb-thread:terminate-thread thread))
1620    
1621    ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)    (defimplementation thread-alive-p (thread)
1622        (sb-thread:thread-alive-p thread))
1623    
1624    (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))    (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1625    (defvar *mailboxes* (list))    (defvar *mailboxes* (list))
1626    (declaim (type list *mailboxes*))    (declaim (type list *mailboxes*))
1627    
1628    (defstruct (mailbox (:conc-name mailbox.))    (defstruct (mailbox (:conc-name mailbox.))
1629      thread      thread
1630      (mutex (sb-thread:make-mutex))      (mutex (sb-thread:make-mutex))
1631      (waitqueue  (sb-thread:make-waitqueue))      (waitqueue  (sb-thread:make-waitqueue))
# Line 742  stack." Line 1647  stack."
1647                (nconc (mailbox.queue mbox) (list message)))                (nconc (mailbox.queue mbox) (list message)))
1648          (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))          (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1649    
   (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))))))))  
1650    
1651      (defun condition-timed-wait (waitqueue mutex timeout)
1652        (macrolet ((foo ()
1653                     (cond ((member :sb-lutex *features*) ; Darwin
1654                            '(sb-thread:condition-wait waitqueue mutex))
1655                           (t
1656                            '(handler-case
1657                              (let ((*break-on-signals* nil))
1658                                (sb-sys:with-deadline (:seconds timeout
1659                                                                :override t)
1660                                  (sb-thread:condition-wait waitqueue mutex) t))
1661                              (sb-ext:timeout ()
1662                               nil))))))
1663          (foo)))
1664    
1665      (defimplementation receive-if (test &optional timeout)
1666        (let* ((mbox (mailbox (current-thread)))
1667               (mutex (mailbox.mutex mbox))
1668               (waitq (mailbox.waitqueue mbox)))
1669          (assert (or (not timeout) (eq timeout t)))
1670          (loop
1671           (check-slime-interrupts)
1672           (sb-thread:with-mutex (mutex)
1673             (let* ((q (mailbox.queue mbox))
1674                    (tail (member-if test q)))
1675               (when tail
1676                 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1677                 (return (car tail))))
1678             (when (eq timeout t) (return (values nil t)))
1679             (condition-timed-wait waitq mutex 0.2)))))
1680    
1681      (let ((alist '())
1682            (mutex (sb-thread:make-mutex :name "register-thread")))
1683    
1684        (defimplementation register-thread (name thread)
1685          (declare (type symbol name))
1686          (sb-thread:with-mutex (mutex)
1687            (etypecase thread
1688              (null
1689               (setf alist (delete name alist :key #'car)))
1690              (sb-thread:thread
1691               (let ((probe (assoc name alist)))
1692                 (cond (probe (setf (cdr probe) thread))
1693                       (t (setf alist (acons name thread alist))))))))
1694          nil)
1695    
1696        (defimplementation find-registered (name)
1697          (sb-thread:with-mutex (mutex)
1698            (cdr (assoc name alist)))))
1699    
1700      ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1701      ;; buffer write lock.
1702      ;;
1703      ;; Another alternative would be to grab the world-lock here, but that's less
1704      ;; future-proof, and could introduce other lock-ordering issues in the
1705      ;; future.
1706      ;;
1707      ;; In an ideal world we would just have an :AROUND method on
1708      ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1709      ;; file is loaded -- so first we need a dummy definition that will be
1710      ;; overridden by swank-gray.lisp.
1711      (defclass slime-output-stream (fundamental-character-output-stream)
1712        ())
1713      (defmethod stream-force-output :around ((stream slime-output-stream))
1714        (handler-case
1715            (sb-sys:with-deadline (:seconds 0.1)
1716              (call-next-method))
1717          (sb-sys:deadline-timeout ()
1718            nil)))
1719    )    )
1720    
1721    (defimplementation quit-lisp ()
1722      #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1723      (sb-ext:exit)
1724      #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1725      (progn
1726        #+sb-thread
1727        (dolist (thread (remove (current-thread) (all-threads)))
1728          (ignore-errors (sb-thread:terminate-thread thread)))
1729        (sb-ext:quit)))
1730    
1731    
1732    
1733    ;;Trace implementations
1734    ;;In SBCL, we have:
1735    ;; (trace <name>)
1736    ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1737    ;; (trace (method <name> <qualifier>? (<specializer>+)))
1738    ;; <name> can be a normal name or a (setf name)
1739    
1740    (defun toggle-trace-aux (fspec &rest args)
1741      (cond ((member fspec (eval '(trace)) :test #'equal)
1742             (eval `(untrace ,fspec))
1743             (format nil "~S is now untraced." fspec))
1744            (t
1745             (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1746             (format nil "~S is now traced." fspec))))
1747    
1748    (defun process-fspec (fspec)
1749      (cond ((consp fspec)
1750             (ecase (first fspec)
1751               ((:defun :defgeneric) (second fspec))
1752               ((:defmethod) `(method ,@(rest fspec)))
1753               ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1754               ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1755            (t
1756             fspec)))
1757    
1758    (defimplementation toggle-trace (spec)
1759      (ecase (car spec)
1760        ((setf)
1761         (toggle-trace-aux spec))
1762        ((:defmethod)
1763         (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1764        ((:defgeneric)
1765         (toggle-trace-aux (second spec) :methods t))
1766        ((:call)
1767         (destructuring-bind (caller callee) (cdr spec)
1768           (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1769    
1770    ;;; Weak datastructures
1771    
1772    (defimplementation make-weak-key-hash-table (&rest args)
1773      #+#.(swank-backend::sbcl-with-weak-hash-tables)
1774      (apply #'make-hash-table :weakness :key args)
1775      #-#.(swank-backend::sbcl-with-weak-hash-tables)
1776      (apply #'make-hash-table args))
1777    
1778    (defimplementation make-weak-value-hash-table (&rest args)
1779      #+#.(swank-backend::sbcl-with-weak-hash-tables)
1780      (apply #'make-hash-table :weakness :value args)
1781      #-#.(swank-backend::sbcl-with-weak-hash-tables)
1782      (apply #'make-hash-table args))
1783    
1784    (defimplementation hash-table-weakness (hashtable)
1785      #+#.(swank-backend::sbcl-with-weak-hash-tables)
1786      (sb-ext:hash-table-weakness hashtable))
1787    
1788    #-win32
1789    (defimplementation save-image (filename &optional restart-function)
1790      (flet ((restart-sbcl ()
1791               (sb-debug::enable-debugger)
1792               (setf sb-impl::*descriptor-handlers* nil)
1793               (funcall restart-function)))
1794        (let ((pid (sb-posix:fork)))
1795          (cond ((= pid 0)
1796                 (sb-debug::disable-debugger)
1797                 (apply #'sb-ext:save-lisp-and-die filename
1798                        (when restart-function
1799                          (list :toplevel #'restart-sbcl))))
1800                (t
1801                 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1802                   (assert (= pid rpid))
1803                   (assert (and (sb-posix:wifexited status)
1804                                (zerop (sb-posix:wexitstatus status))))))))))
1805    
1806    #+unix
1807    (progn
1808      (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1809        (program sb-alien:c-string)
1810        (argv (* sb-alien:c-string)))
1811    
1812      (defun execv (program args)
1813        "Replace current executable with another one."
1814        (let ((a-args (sb-alien:make-alien sb-alien:c-string
1815                                           (+ 1 (length args)))))
1816          (unwind-protect
1817               (progn
1818                 (loop for index from 0 by 1
1819                       and item in (append args '(nil))
1820                       do (setf (sb-alien:deref a-args index)
1821                                item))
1822                 (when (minusp
1823                        (sys-execv program a-args))
1824                   (error "execv(3) returned.")))
1825            (sb-alien:free-alien a-args))))
1826    
1827      (defun runtime-pathname ()
1828        #+#.(swank-backend:with-symbol
1829                '*runtime-pathname* 'sb-ext)
1830        sb-ext:*runtime-pathname*
1831        #-#.(swank-backend:with-symbol
1832                '*runtime-pathname* 'sb-ext)
1833        (car sb-ext:*posix-argv*))
1834    
1835      (defimplementation exec-image (image-file args)
1836        (loop with fd-arg =
1837              (loop for arg in args
1838                    and key = "" then arg
1839                    when (string-equal key "--swank-fd")
1840                    return (parse-integer arg))
1841              for my-fd from 3 to 1024
1842              when (/= my-fd fd-arg)
1843              do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1844        (let* ((self-string (pathname-to-filename (runtime-pathname))))
1845          (execv
1846           self-string
1847           (apply 'list self-string "--core" image-file args)))))
1848    
1849    (defimplementation make-fd-stream (fd external-format)
1850      (sb-sys:make-fd-stream fd :input t :output t
1851                             :element-type 'character
1852                             :buffering :full
1853                             :dual-channel-p t
1854                             :external-format external-format))
1855    
1856    #-win32
1857    (defimplementation background-save-image (filename &key restart-function
1858                                                       completion-function)
1859      (flet ((restart-sbcl ()
1860               (sb-debug::enable-debugger)
1861               (setf sb-impl::*descriptor-handlers* nil)
1862               (funcall restart-function)))
1863        (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1864          (let ((pid (sb-posix:fork)))
1865            (cond ((= pid 0)
1866                   (sb-posix:close pipe-in)
1867                   (sb-debug::disable-debugger)
1868                   (apply #'sb-ext:save-lisp-and-die filename
1869                          (when restart-function
1870                            (list :toplevel #'restart-sbcl))))
1871                  (t
1872                   (sb-posix:close pipe-out)
1873                   (sb-sys:add-fd-handler
1874                    pipe-in :input
1875                    (lambda (fd)
1876                      (sb-sys:invalidate-descriptor fd)
1877                      (sb-posix:close fd)
1878                      (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1879                        (assert (= pid rpid))
1880                        (assert (sb-posix:wifexited status))
1881                        (funcall completion-function
1882                                 (zerop (sb-posix:wexitstatus status))))))))))))
1883    
1884    (pushnew 'deinit-log-output sb-ext:*save-hooks*)

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

  ViewVC Help
Powered by ViewVC 1.1.5