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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.274 - (hide annotations)
Sat Aug 21 06:39:59 2010 UTC (3 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.273: +91 -11 lines
Snapshot restore support for SBCL.

* swank-backend.lisp (background-save-image): New.
* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
(make-fd-stream, background-save-image): New.

Add support to save snapshots in backround.

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

  ViewVC Help
Powered by ViewVC 1.1.5