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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.325 - (show annotations)
Mon Dec 3 03:43:16 2012 UTC (16 months, 1 week ago) by sboukarev
Branch: MAIN
Changes since 1.324: +0 -5 lines
* swank-backend.lisp (deinit-log-output): Move from swank-sbcl,
use it on CCL in ccl:*save-exit-functions* as well.
1 ;;;;; -*- indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4 ;;;
5 ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties are
8 ;;; disclaimed.
9
10 ;;; Requires the SB-INTROSPECT contrib.
11
12 ;;; Administrivia
13
14 (in-package :swank-backend)
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (require 'sb-bsd-sockets)
18 (require 'sb-introspect)
19 (require 'sb-posix)
20 (require 'sb-cltl2)
21 (import-from :sb-gray *gray-stream-symbols* :swank-backend))
22
23 (declaim (optimize (debug 2)
24 (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-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
47
48 (defun swank-mop:slot-definition-documentation (slot)
49 (sb-pcl::documentation slot t))
50
51 ;;; Connection info
52
53 (defimplementation lisp-implementation-type-name ()
54 "sbcl")
55
56 ;; Declare return type explicitly to shut up STYLE-WARNINGS about
57 ;; %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
71
72 (defimplementation preferred-communication-style ()
73 (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)
81 (car (sb-bsd-sockets:host-ent-addresses
82 (sb-bsd-sockets:get-host-by-name name))))
83
84 (defimplementation create-socket (host port &key backlog)
85 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
86 :type :stream
87 :protocol :tcp)))
88 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
89 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
90 (sb-bsd-sockets:socket-listen socket (or backlog 5))
91 socket))
92
93 (defimplementation local-port (socket)
94 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
95
96 (defimplementation close-socket (socket)
97 (sb-sys:invalidate-descriptor (socket-fd socket))
98 (sb-bsd-sockets:socket-close socket))
99
100 (defimplementation accept-connection (socket &key
101 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* '()
121 "List of (key . fn) pairs to be called on SIGIO.")
122
123 (defun sigio-handler (signal code scp)
124 (declare (ignore signal code scp))
125 (mapc (lambda (handler)
126 (funcall (the function (cdr handler))))
127 *sigio-handlers*))
128
129 (defun set-sigio-handler ()
130 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
131 (sigio-handler signal code scp))))
132
133 (defun enable-sigio-on-fd (fd)
134 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
135 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
136 (values))
137
138 (defimplementation add-sigio-handler (socket fn)
139 (set-sigio-handler)
140 (let ((fd (socket-fd socket)))
141 (enable-sigio-on-fd fd)
142 (push (cons fd fn) *sigio-handlers*)))
143
144 (defimplementation remove-sigio-handlers (socket)
145 (let ((fd (socket-fd socket)))
146 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
147 (sb-sys:invalidate-descriptor fd))
148 (close socket))
149
150 (defimplementation add-fd-handler (socket fun)
151 (let ((fd (socket-fd socket))
152 (handler nil))
153 (labels ((add ()
154 (setq handler (sb-sys:add-fd-handler fd :input #'run)))
155 (run (fd)
156 (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)
164 (sb-sys:invalidate-descriptor (socket-fd socket)))
165
166 (defimplementation socket-fd (socket)
167 (etypecase socket
168 (fixnum socket)
169 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
170 (file-stream (sb-sys:fd-stream-fd socket))))
171
172 (defimplementation command-line-args ()
173 sb-ext:*posix-argv*)
174
175 (defimplementation dup (fd)
176 (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)
305 "Like socket-accept, but retry on EAGAIN."
306 (loop (handler-case
307 (return (sb-bsd-sockets:socket-accept socket))
308 (sb-bsd-sockets:interrupted-error ()))))
309
310
311 ;;;; Support for SBCL syntax
312
313 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
314 ;;; 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 default-readtable-alist ()
394 (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
399
400 (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)
415 (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
442 (defvar *buffer-name* nil)
443 (defvar *buffer-tmpfile* nil)
444 (defvar *buffer-offset*)
445 (defvar *buffer-substring* nil)
446
447 (defvar *previous-compiler-condition* nil
448 "Used to detect duplicates.")
449
450 (defun handle-notification-condition (condition)
451 "Handle a condition caused by a compiler warning.
452 This traps all compiler conditions at a lower-level than using
453 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
454 craft our own error messages, which can omit a lot of redundant
455 information."
456 (unless (or (eq condition *previous-compiler-condition*))
457 ;; First resignal warnings, so that outer handlers -- which may choose to
458 ;; muffle this -- get a chance to run.
459 (when (typep condition 'warning)
460 (signal condition))
461 (setq *previous-compiler-condition* condition)
462 (signal-compiler-condition (real-condition condition)
463 (sb-c::find-error-context nil))))
464
465 (defun signal-compiler-condition (condition context)
466 (signal 'compiler-condition
467 :original-condition condition
468 :severity (etypecase condition
469 (sb-ext:compiler-note :note)
470 (sb-c:compiler-error :error)
471 (reader-error :read-error)
472 (error :error)
473 #+#.(swank-backend:with-symbol redefinition-warning
474 sb-kernel)
475 (sb-kernel:redefinition-warning
476 :redefinition)
477 (style-warning :style-warning)
478 (warning :warning))
479 :references (condition-references condition)
480 :message (brief-compiler-message-for-emacs condition)
481 :source-context (compiler-error-context context)
482 :location (compiler-note-location condition context)))
483
484 (defun real-condition (condition)
485 "Return the encapsulated condition or CONDITION itself."
486 (typecase condition
487 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
488 (t condition)))
489
490 (defun condition-references (condition)
491 (if (typep condition 'sb-int:reference-condition)
492 (externalize-reference
493 (sb-int:reference-condition-references condition))))
494
495 (defun compiler-note-location (condition context)
496 (flet ((bailout ()
497 (return-from compiler-note-location
498 (make-error-location "No error location available"))))
499 (cond (context
500 (locate-compiler-note
501 (sb-c::compiler-error-context-file-name context)
502 (compiler-source-path context)
503 (sb-c::compiler-error-context-original-source context)))
504 ((typep condition 'reader-error)
505 (let* ((stream (stream-error-stream condition))
506 (file (pathname stream)))
507 (unless (open-stream-p stream)
508 (bailout))
509 (if (compiling-from-buffer-p file)
510 ;; The stream position for e.g. "comma not inside
511 ;; backquote" is at the character following the
512 ;; comma, :offset is 0-based, hence the 1-.
513 (make-location (list :buffer *buffer-name*)
514 (list :offset *buffer-offset*
515 (1- (file-position stream))))
516 (progn
517 (assert (compiling-from-file-p file))
518 ;; No 1- because :position is 1-based.
519 (make-location (list :file (namestring file))
520 (list :position (file-position stream)))))))
521 (t (bailout)))))
522
523 (defun compiling-from-buffer-p (filename)
524 (and *buffer-name*
525 ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
526 ;; in LOCATE-COMPILER-NOTE, and allows handling nested
527 ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
528 ;;
529 ;; PROBE-FILE to handle tempfile directory being a symlink.
530 (pathnamep filename)
531 (let ((true1 (probe-file filename))
532 (true2 (probe-file *buffer-tmpfile*)))
533 (and true1 (equal true1 true2)))))
534
535 (defun compiling-from-file-p (filename)
536 (and (pathnamep filename)
537 (or (null *buffer-name*)
538 (null *buffer-tmpfile*)
539 (let ((true1 (probe-file filename))
540 (true2 (probe-file *buffer-tmpfile*)))
541 (not (and true1 (equal true1 true2)))))))
542
543 (defun compiling-from-generated-code-p (filename source)
544 (and (eq filename :lisp) (stringp source)))
545
546 (defun locate-compiler-note (file source-path source)
547 (cond ((compiling-from-buffer-p file)
548 (make-location (list :buffer *buffer-name*)
549 (list :offset *buffer-offset*
550 (source-path-string-position
551 source-path *buffer-substring*))))
552 ((compiling-from-file-p file)
553 (make-location (list :file (namestring file))
554 (list :position (1+ (source-path-file-position
555 source-path file)))))
556 ((compiling-from-generated-code-p file source)
557 (make-location (list :source-form source)
558 (list :position 1)))
559 (t
560 (error "unhandled case in compiler note ~S ~S ~S"
561 file source-path source))))
562
563 (defun brief-compiler-message-for-emacs (condition)
564 "Briefly describe a compiler error for Emacs.
565 When Emacs presents the message it already has the source popped up
566 and the source form highlighted. This makes much of the information in
567 the error-context redundant."
568 (let ((sb-int:*print-condition-references* nil))
569 (princ-to-string condition)))
570
571 (defun compiler-error-context (error-context)
572 "Describe a compiler error for Emacs including context information."
573 (declare (type (or sb-c::compiler-error-context null) error-context))
574 (multiple-value-bind (enclosing source)
575 (if error-context
576 (values (sb-c::compiler-error-context-enclosing-source error-context)
577 (sb-c::compiler-error-context-source error-context)))
578 (and (or enclosing source)
579 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
580 enclosing source))))
581
582 (defun compiler-source-path (context)
583 "Return the source-path for the current compiler error.
584 Returns NIL if this cannot be determined by examining internal
585 compiler state."
586 (cond ((sb-c::node-p context)
587 (reverse
588 (sb-c::source-path-original-source
589 (sb-c::node-source-path context))))
590 ((sb-c::compiler-error-context-p context)
591 (reverse
592 (sb-c::compiler-error-context-original-source-path context)))))
593
594 (defimplementation call-with-compilation-hooks (function)
595 (declare (type function function))
596 (handler-bind
597 ;; N.B. Even though these handlers are called HANDLE-FOO they
598 ;; actually decline, i.e. the signalling of the original
599 ;; condition continues upward.
600 ((sb-c:fatal-compiler-error #'handle-notification-condition)
601 (sb-c:compiler-error #'handle-notification-condition)
602 (sb-ext:compiler-note #'handle-notification-condition)
603 (error #'handle-notification-condition)
604 (warning #'handle-notification-condition))
605 (funcall function)))
606
607
608 (defvar *trap-load-time-warnings* t)
609
610 (defun compiler-policy (qualities)
611 "Return compiler policy qualities present in the QUALITIES alist.
612 QUALITIES is an alist with (quality . value)"
613 #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
614 (loop with policy = (sb-ext:restrict-compiler-policy)
615 for (quality) in qualities
616 collect (cons quality
617 (or (cdr (assoc quality policy))
618 0))))
619
620 (defun (setf compiler-policy) (policy)
621 (declare (ignorable policy))
622 #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
623 (loop for (qual . value) in policy
624 do (sb-ext:restrict-compiler-policy qual value)))
625
626 (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 (defimplementation swank-compile-string (string &key buffer position filename
671 policy)
672 (let ((*buffer-name* buffer)
673 (*buffer-offset* position)
674 (*buffer-substring* string)
675 (*buffer-tmpfile* (temp-file-name)))
676 (flet ((load-it (filename)
677 (when filename (load filename)))
678 (compile-it (cont)
679 (with-compilation-hooks ()
680 (with-compilation-unit
681 (:source-plist (list :emacs-buffer buffer
682 :emacs-filename filename
683 :emacs-string string
684 :emacs-position position)
685 :source-namestring filename
686 :allow-other-keys t)
687 (multiple-value-bind (output-file warningsp failurep)
688 (compile-file *buffer-tmpfile* :external-format :utf-8)
689 (declare (ignore warningsp))
690 (unless failurep
691 (funcall cont output-file)))))))
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 (with-compiler-policy policy
697 (if *trap-load-time-warnings*
698 (compile-it #'load-it)
699 (load-it (compile-it #'identity))))
700 (ignore-errors
701 (delete-file *buffer-tmpfile*)
702 (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
703
704 ;;;; Definitions
705
706 (defparameter *definition-types*
707 '(:variable defvar
708 :constant defconstant
709 :type deftype
710 :symbol-macro define-symbol-macro
711 :macro defmacro
712 :compiler-macro define-compiler-macro
713 :function defun
714 :generic-function defgeneric
715 :method defmethod
716 :setf-expander define-setf-expander
717 :structure defstruct
718 :condition define-condition
719 :class defclass
720 :method-combination define-method-combination
721 :package defpackage
722 :transform :deftransform
723 :optimizer :defoptimizer
724 :vop :define-vop
725 :source-transform :define-source-transform)
726 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
727
728 (defun definition-specifier (type name)
729 "Return a pretty specifier for NAME representing a definition of type TYPE."
730 (if (and (symbolp name)
731 (eq type :function)
732 (sb-int:info :function :ir1-convert name))
733 :def-ir1-translator
734 (getf *definition-types* type)))
735
736 (defun make-dspec (type name source-location)
737 (let ((spec (definition-specifier type name))
738 (desc (sb-introspect::definition-source-description source-location)))
739 (if (eq :define-vop spec)
740 ;; The first part of the VOP description is the name of the template
741 ;; -- which is actually good information and often long. So elide the
742 ;; original name in favor of making the interesting bit more visible.
743 ;;
744 ;; The second part of the VOP description is the associated
745 ;; compiler note, or NIL -- which is quite uninteresting and
746 ;; confuses the eye when reading the actual name which usually
747 ;; has a worthwhile postfix. So drop the note.
748 (list spec (car desc))
749 (list* spec name desc))))
750
751 (defimplementation find-definitions (name)
752 (loop for type in *definition-types* by #'cddr
753 for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
754 append (loop for defsrc in defsrcs collect
755 (list (make-dspec type name defsrc)
756 (converting-errors-to-error-location
757 (definition-source-for-emacs defsrc
758 type name))))))
759
760 (defimplementation find-source-location (obj)
761 (flet ((general-type-of (obj)
762 (typecase obj
763 (method :method)
764 (generic-function :generic-function)
765 (function :function)
766 (structure-class :structure-class)
767 (class :class)
768 (method-combination :method-combination)
769 (package :package)
770 (condition :condition)
771 (structure-object :structure-object)
772 (standard-object :standard-object)
773 (t :thing)))
774 (to-string (obj)
775 (typecase obj
776 ;; Packages are possibly named entities.
777 (package (princ-to-string obj))
778 ((or structure-object standard-object condition)
779 (with-output-to-string (s)
780 (print-unreadable-object (obj s :type t :identity t))))
781 (t (princ-to-string obj)))))
782 (converting-errors-to-error-location
783 (let ((defsrc (sb-introspect:find-definition-source obj)))
784 (definition-source-for-emacs defsrc
785 (general-type-of obj)
786 (to-string obj))))))
787
788 (defmacro with-definition-source ((&rest names) obj &body body)
789 "Like with-slots but works only for structs."
790 (flet ((reader (slot)
791 ;; Use read-from-string instead of intern so that
792 ;; conc-name can be a string such as ext:struct- and not
793 ;; cause errors and not force interning ext::struct-
794 (read-from-string
795 (concatenate 'string "sb-introspect:definition-source-"
796 (string slot)))))
797 (let ((tmp (gensym "OO-")))
798 ` (let ((,tmp ,obj))
799 (symbol-macrolet
800 ,(loop for name in names collect
801 (typecase name
802 (symbol `(,name (,(reader name) ,tmp)))
803 (cons `(,(first name) (,(reader (second name)) ,tmp)))
804 (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
805 ,@body)))))
806
807 (defun categorize-definition-source (definition-source)
808 (with-definition-source (pathname form-path character-offset plist)
809 definition-source
810 (let ((file-p (and pathname (probe-file pathname)
811 (or form-path character-offset))))
812 (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
813 ((getf plist :emacs-buffer) :buffer)
814 (file-p :file)
815 (pathname :file-without-position)
816 (t :invalid)))))
817
818 (defun definition-source-buffer-location (definition-source)
819 (with-definition-source (form-path character-offset plist) definition-source
820 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
821 emacs-string &allow-other-keys)
822 plist
823 (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
824 (multiple-value-bind (start end)
825 (if form-path
826 (with-debootstrapping
827 (source-path-string-position form-path
828 emacs-string))
829 (values character-offset
830 most-positive-fixnum))
831 (make-location
832 `(:buffer ,emacs-buffer)
833 `(:offset ,emacs-position ,start)
834 `(:snippet
835 ,(subseq emacs-string
836 start
837 (min end (+ start *source-snippet-size*))))))))))
838
839 (defun definition-source-file-location (definition-source)
840 (with-definition-source (pathname form-path character-offset plist
841 file-write-date) definition-source
842 (let* ((namestring (namestring (translate-logical-pathname pathname)))
843 (pos (if form-path
844 (source-file-position namestring file-write-date
845 form-path)
846 character-offset))
847 (snippet (source-hint-snippet namestring file-write-date pos)))
848 (make-location `(:file ,namestring)
849 ;; /file positions/ in Common Lisp start from
850 ;; 0, buffer positions in Emacs start from 1.
851 `(:position ,(1+ pos))
852 `(:snippet ,snippet)))))
853
854 (defun definition-source-buffer-and-file-location (definition-source)
855 (let ((buffer (definition-source-buffer-location definition-source))
856 (file (definition-source-file-location definition-source)))
857 (make-location (list :buffer-and-file
858 (cadr (location-buffer buffer))
859 (cadr (location-buffer file)))
860 (location-position buffer)
861 (location-hints buffer))))
862
863 (defun definition-source-for-emacs (definition-source type name)
864 (with-definition-source (pathname form-path character-offset plist
865 file-write-date)
866 definition-source
867 (ecase (categorize-definition-source definition-source)
868 (:buffer-and-file
869 (definition-source-buffer-and-file-location definition-source))
870 (:buffer
871 (definition-source-buffer-location definition-source))
872 (:file
873 (definition-source-file-location definition-source))
874 (:file-without-position
875 (make-location `(:file ,(namestring
876 (translate-logical-pathname pathname)))
877 '(:position 1)
878 (when (eql type :function)
879 `(:snippet ,(format nil "(defun ~a "
880 (symbol-name name))))))
881 (:invalid
882 (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
883 meaningful information."
884 type name)))))
885
886 (defun source-file-position (filename write-date form-path)
887 (let ((source (get-source-code filename write-date))
888 (*readtable* (guess-readtable-for-filename filename)))
889 (with-debootstrapping
890 (source-path-string-position form-path source))))
891
892 (defun source-hint-snippet (filename write-date position)
893 (read-snippet-from-string (get-source-code filename write-date) position))
894
895 (defun function-source-location (function &optional name)
896 (declare (type function function))
897 (definition-source-for-emacs (sb-introspect:find-definition-source function)
898 :function
899 (or name (function-name function))))
900
901 (defimplementation describe-symbol-for-emacs (symbol)
902 "Return a plist describing SYMBOL.
903 Return NIL if the symbol is unbound."
904 (let ((result '()))
905 (flet ((doc (kind)
906 (or (documentation symbol kind) :not-documented))
907 (maybe-push (property value)
908 (when value
909 (setf result (list* property value result)))))
910 (maybe-push
911 :variable (multiple-value-bind (kind recorded-p)
912 (sb-int:info :variable :kind symbol)
913 (declare (ignore kind))
914 (if (or (boundp symbol) recorded-p)
915 (doc 'variable))))
916 (when (fboundp symbol)
917 (maybe-push
918 (cond ((macro-function symbol) :macro)
919 ((special-operator-p symbol) :special-operator)
920 ((typep (fdefinition symbol) 'generic-function)
921 :generic-function)
922 (t :function))
923 (doc 'function)))
924 (maybe-push
925 :setf (if (or (sb-int:info :setf :inverse symbol)
926 (sb-int:info :setf :expander symbol))
927 (doc 'setf)))
928 (maybe-push
929 :type (if (sb-int:info :type :kind symbol)
930 (doc 'type)))
931 result)))
932
933 (defimplementation describe-definition (symbol type)
934 (case type
935 (:variable
936 (describe symbol))
937 (:function
938 (describe (symbol-function symbol)))
939 (:setf
940 (describe (or (sb-int:info :setf :inverse symbol)
941 (sb-int:info :setf :expander symbol))))
942 (:class
943 (describe (find-class symbol)))
944 (:type
945 (describe (sb-kernel:values-specifier-type symbol)))))
946
947 #+#.(swank-backend::sbcl-with-xref-p)
948 (progn
949 (defmacro defxref (name &optional fn-name)
950 `(defimplementation ,name (what)
951 (sanitize-xrefs
952 (mapcar #'source-location-for-xref-data
953 (,(find-symbol (symbol-name (if fn-name
954 fn-name
955 name))
956 "SB-INTROSPECT")
957 what)))))
958 (defxref who-calls)
959 (defxref who-binds)
960 (defxref who-sets)
961 (defxref who-references)
962 (defxref who-macroexpands)
963 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
964 (defxref who-specializes who-specializes-directly))
965
966 (defun source-location-for-xref-data (xref-data)
967 (destructuring-bind (name . defsrc) xref-data
968 (list name (converting-errors-to-error-location
969 (definition-source-for-emacs defsrc 'function name)))))
970
971 (defimplementation list-callers (symbol)
972 (let ((fn (fdefinition symbol)))
973 (sanitize-xrefs
974 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
975
976 (defimplementation list-callees (symbol)
977 (let ((fn (fdefinition symbol)))
978 (sanitize-xrefs
979 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
980
981 (defun sanitize-xrefs (xrefs)
982 (remove-duplicates
983 (remove-if (lambda (f)
984 (member f (ignored-xref-function-names)))
985 (loop for entry in xrefs
986 for name = (car entry)
987 collect (if (and (consp name)
988 (member (car name)
989 '(sb-pcl::fast-method
990 sb-pcl::slow-method
991 sb-pcl::method)))
992 (cons (cons 'defmethod (cdr name))
993 (cdr entry))
994 entry))
995 :key #'car)
996 :test (lambda (a b)
997 (and (eq (first a) (first b))
998 (equal (second a) (second b))))))
999
1000 (defun ignored-xref-function-names ()
1001 #-#.(swank-backend::sbcl-with-new-stepper-p)
1002 '(nil sb-c::step-form sb-c::step-values)
1003 #+#.(swank-backend::sbcl-with-new-stepper-p)
1004 '(nil))
1005
1006 (defun function-dspec (fn)
1007 "Describe where the function FN was defined.
1008 Return a list of the form (NAME LOCATION)."
1009 (let ((name (function-name fn)))
1010 (list name (converting-errors-to-error-location
1011 (function-source-location fn name)))))
1012
1013 ;;; macroexpansion
1014
1015 (defimplementation macroexpand-all (form)
1016 (let ((sb-walker:*walk-form-expand-macros-p* t))
1017 (sb-walker:walk-form form)))
1018
1019
1020 ;;; Debugging
1021
1022 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1023 ;;; than just a hook into BREAK. In particular, it'll make
1024 ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1025 ;;; than the native debugger. That should probably be considered a
1026 ;;; feature.
1027
1028 (defun make-invoke-debugger-hook (hook)
1029 (when hook
1030 #'(sb-int:named-lambda swank-invoke-debugger-hook
1031 (condition old-hook)
1032 (if *debugger-hook*
1033 nil ; decline, *DEBUGGER-HOOK* will be tried next.
1034 (funcall hook condition old-hook)))))
1035
1036 (defun set-break-hook (hook)
1037 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1038
1039 (defun call-with-break-hook (hook continuation)
1040 (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1041 (funcall continuation)))
1042
1043 (defimplementation install-debugger-globally (function)
1044 (setq *debugger-hook* function)
1045 (set-break-hook function))
1046
1047 (defimplementation condition-extras (condition)
1048 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1049 ((typep condition 'sb-impl::step-form-condition)
1050 `((:show-frame-source 0)))
1051 ((typep condition 'sb-int:reference-condition)
1052 (let ((refs (sb-int:reference-condition-references condition)))
1053 (if refs
1054 `((:references ,(externalize-reference refs))))))))
1055
1056 (defun externalize-reference (ref)
1057 (etypecase ref
1058 (null nil)
1059 (cons (cons (externalize-reference (car ref))
1060 (externalize-reference (cdr ref))))
1061 ((or string number) ref)
1062 (symbol
1063 (cond ((eq (symbol-package ref) (symbol-package :test))
1064 ref)
1065 (t (symbol-name ref))))))
1066
1067 (defvar *sldb-stack-top*)
1068
1069 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1070 (declare (type function debugger-loop-fn))
1071 (let ((*sldb-stack-top*
1072 (if (and (not *debug-swank-backend*)
1073 sb-debug:*stack-top-hint*)
1074 #+#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1075 (sb-debug::resolve-stack-top-hint)
1076 #-#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1077 sb-debug:*stack-top-hint*
1078 (sb-di:top-frame)))
1079 (sb-debug:*stack-top-hint* nil))
1080 (handler-bind ((sb-di:debug-condition
1081 (lambda (condition)
1082 (signal 'sldb-condition
1083 :original-condition condition))))
1084 (funcall debugger-loop-fn))))
1085
1086 #+#.(swank-backend::sbcl-with-new-stepper-p)
1087 (progn
1088 (defimplementation activate-stepping (frame)
1089 (declare (ignore frame))
1090 (sb-impl::enable-stepping))
1091 (defimplementation sldb-stepper-condition-p (condition)
1092 (typep condition 'sb-ext:step-form-condition))
1093 (defimplementation sldb-step-into ()
1094 (invoke-restart 'sb-ext:step-into))
1095 (defimplementation sldb-step-next ()
1096 (invoke-restart 'sb-ext:step-next))
1097 (defimplementation sldb-step-out ()
1098 (invoke-restart 'sb-ext:step-out)))
1099
1100 (defimplementation call-with-debugger-hook (hook fun)
1101 (let ((*debugger-hook* hook)
1102 #+#.(swank-backend::sbcl-with-new-stepper-p)
1103 (sb-ext:*stepper-hook*
1104 (lambda (condition)
1105 (typecase condition
1106 (sb-ext:step-form-condition
1107 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1108 (sb-impl::invoke-debugger condition)))))))
1109 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1110 (sb-ext:step-condition #'sb-impl::invoke-stepper))
1111 (call-with-break-hook hook fun))))
1112
1113 (defun nth-frame (index)
1114 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1115 (i index (1- i)))
1116 ((zerop i) frame)))
1117
1118 (defimplementation compute-backtrace (start end)
1119 "Return a list of frames starting with frame number START and
1120 continuing to frame number END or, if END is nil, the last frame on the
1121 stack."
1122 (let ((end (or end most-positive-fixnum)))
1123 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1124 for i from start below end
1125 while f collect f)))
1126
1127 (defimplementation print-frame (frame stream)
1128 (sb-debug::print-frame-call frame stream))
1129
1130 (defimplementation frame-restartable-p (frame)
1131 #+#.(swank-backend::sbcl-with-restart-frame)
1132 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1133
1134 (defimplementation frame-call (frame-number)
1135 (multiple-value-bind (name args)
1136 (sb-debug::frame-call (nth-frame frame-number))
1137 (with-output-to-string (stream)
1138 (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1139 (let ((*print-length* nil)
1140 (*print-level* nil))
1141 (prin1 (sb-debug::ensure-printable-object name) stream))
1142 (let ((args (sb-debug::ensure-printable-object args)))
1143 (if (listp args)
1144 (format stream "~{ ~_~S~}" args)
1145 (format stream " ~S" args)))))))
1146
1147 ;;;; Code-location -> source-location translation
1148
1149 ;;; If debug-block info is avaibale, we determine the file position of
1150 ;;; the source-path for a code-location. If the code was compiled
1151 ;;; with C-c C-c, we have to search the position in the source string.
1152 ;;; If there's no debug-block info, we return the (less precise)
1153 ;;; source-location of the corresponding function.
1154
1155 (defun code-location-source-location (code-location)
1156 (let* ((dsource (sb-di:code-location-debug-source code-location))
1157 (plist (sb-c::debug-source-plist dsource)))
1158 (if (getf plist :emacs-buffer)
1159 (emacs-buffer-source-location code-location plist)
1160 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1161 (ecase (sb-di:debug-source-from dsource)
1162 (:file (file-source-location code-location))
1163 (:lisp (lisp-source-location code-location)))
1164 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1165 (if (sb-di:debug-source-namestring dsource)
1166 (file-source-location code-location)
1167 (lisp-source-location code-location)))))
1168
1169 ;;; FIXME: The naming policy of source-location functions is a bit
1170 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1171 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1172 ;;; which returns the source location for a _code-location_.
1173 ;;;
1174 ;;; Maybe these should be named code-location-file-source-location,
1175 ;;; etc, turned into generic functions, or something. In the very
1176 ;;; least the names should indicate the main entry point vs. helper
1177 ;;; status.
1178
1179 (defun file-source-location (code-location)
1180 (if (code-location-has-debug-block-info-p code-location)
1181 (source-file-source-location code-location)
1182 (fallback-source-location code-location)))
1183
1184 (defun fallback-source-location (code-location)
1185 (let ((fun (code-location-debug-fun-fun code-location)))
1186 (cond (fun (function-source-location fun))
1187 (t (error "Cannot find source location for: ~A " code-location)))))
1188
1189 (defun lisp-source-location (code-location)
1190 (let ((source (prin1-to-string
1191 (sb-debug::code-location-source-form code-location 100)))
1192 (condition (swank-value '*swank-debugger-condition*)))
1193 (if (and (typep condition 'sb-impl::step-form-condition)
1194 (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1195 :test #'char-equal)
1196 (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1197 ;; The initial form is utterly uninteresting -- and almost
1198 ;; certainly right there in the REPL.
1199 (make-error-location "Stepping...")
1200 (make-location `(:source-form ,source) '(:position 1)))))
1201
1202 (defun emacs-buffer-source-location (code-location plist)
1203 (if (code-location-has-debug-block-info-p code-location)
1204 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1205 &allow-other-keys)
1206 plist
1207 (let* ((pos (string-source-position code-location emacs-string))
1208 (snipped (read-snippet-from-string emacs-string pos)))
1209 (make-location `(:buffer ,emacs-buffer)
1210 `(:offset ,emacs-position ,pos)
1211 `(:snippet ,snipped))))
1212 (fallback-source-location code-location)))
1213
1214 (defun source-file-source-location (code-location)
1215 (let* ((code-date (code-location-debug-source-created code-location))
1216 (filename (code-location-debug-source-name code-location))
1217 (*readtable* (guess-readtable-for-filename filename))
1218 (source-code (get-source-code filename code-date)))
1219 (with-debootstrapping
1220 (with-input-from-string (s source-code)
1221 (let* ((pos (stream-source-position code-location s))
1222 (snippet (read-snippet s pos)))
1223 (make-location `(:file ,filename)
1224 `(:position ,pos)
1225 `(:snippet ,snippet)))))))
1226
1227 (defun code-location-debug-source-name (code-location)
1228 (namestring (truename (#+#.(swank-backend:with-symbol
1229 'debug-source-name 'sb-di)
1230 sb-c::debug-source-name
1231 #-#.(swank-backend:with-symbol
1232 'debug-source-name 'sb-di)
1233 sb-c::debug-source-namestring
1234 (sb-di::code-location-debug-source code-location)))))
1235
1236 (defun code-location-debug-source-created (code-location)
1237 (sb-c::debug-source-created
1238 (sb-di::code-location-debug-source code-location)))
1239
1240 (defun code-location-debug-fun-fun (code-location)
1241 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1242
1243 (defun code-location-has-debug-block-info-p (code-location)
1244 (handler-case
1245 (progn (sb-di:code-location-debug-block code-location)
1246 t)
1247 (sb-di:no-debug-blocks () nil)))
1248
1249 (defun stream-source-position (code-location stream)
1250 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1251 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1252 (form-number (sb-di::code-location-form-number cloc)))
1253 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1254 (let* ((path-table (sb-di::form-number-translations tlf 0))
1255 (path (cond ((<= (length path-table) form-number)
1256 (warn "inconsistent form-number-translations")
1257 (list 0))
1258 (t
1259 (reverse (cdr (aref path-table form-number)))))))
1260 (source-path-source-position path tlf pos-map)))))
1261
1262 (defun string-source-position (code-location string)
1263 (with-input-from-string (s string)
1264 (stream-source-position code-location s)))
1265
1266 ;;; source-path-file-position and friends are in swank-source-path-parser
1267
1268 (defimplementation frame-source-location (index)
1269 (converting-errors-to-error-location
1270 (code-location-source-location
1271 (sb-di:frame-code-location (nth-frame index)))))
1272
1273 (defun frame-debug-vars (frame)
1274 "Return a vector of debug-variables in frame."
1275 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1276
1277 (defun debug-var-value (var frame location)
1278 (ecase (sb-di:debug-var-validity var location)
1279 (:valid (sb-di:debug-var-value var frame))
1280 ((:invalid :unknown) ':<not-available>)))
1281
1282 (defun debug-var-info (var)
1283 ;; Introduced by SBCL 1.0.49.76.
1284 (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1285 (when (and s (fboundp s))
1286 (funcall s var))))
1287
1288 (defimplementation frame-locals (index)
1289 (let* ((frame (nth-frame index))
1290 (loc (sb-di:frame-code-location frame))
1291 (vars (frame-debug-vars frame))
1292 ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1293 ;; specially.
1294 (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1295 (more-context nil)
1296 (more-count nil)
1297 (more-id 0))
1298 (when vars
1299 (let ((locals
1300 (loop for v across vars
1301 do (when (eq (sb-di:debug-var-symbol v) more-name)
1302 (incf more-id))
1303 (case (debug-var-info v)
1304 (:more-context
1305 (setf more-context (debug-var-value v frame loc)))
1306 (:more-count
1307 (setf more-count (debug-var-value v frame loc))))
1308 collect
1309 (list :name (sb-di:debug-var-symbol v)
1310 :id (sb-di:debug-var-id v)
1311 :value (debug-var-value v frame loc)))))
1312 (when (and more-context more-count)
1313 (setf locals (append locals
1314 (list
1315 (list :name more-name
1316 :id more-id
1317 :value (multiple-value-list
1318 (sb-c:%more-arg-values
1319 more-context
1320 0 more-count)))))))
1321 locals))))
1322
1323 (defimplementation frame-var-value (frame var)
1324 (let* ((frame (nth-frame frame))
1325 (vars (frame-debug-vars frame))
1326 (loc (sb-di:frame-code-location frame))
1327 (dvar (if (= var (length vars))
1328 ;; If VAR is out of bounds, it must be the fake var
1329 ;; we made up for &MORE.
1330 (let* ((context-var (find :more-context vars
1331 :key #'debug-var-info))
1332 (more-context (debug-var-value context-var frame
1333 loc))
1334 (count-var (find :more-count vars
1335 :key #'debug-var-info))
1336 (more-count (debug-var-value count-var frame loc)))
1337 (return-from frame-var-value
1338 (multiple-value-list (sb-c:%more-arg-values
1339 more-context
1340 0 more-count))))
1341 (aref vars var))))
1342 (debug-var-value dvar frame loc)))
1343
1344 (defimplementation frame-catch-tags (index)
1345 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1346
1347 (defimplementation eval-in-frame (form index)
1348 (let ((frame (nth-frame index)))
1349 (funcall (the function
1350 (sb-di:preprocess-for-eval form
1351 (sb-di:frame-code-location frame)))
1352 frame)))
1353
1354 #+#.(swank-backend::sbcl-with-restart-frame)
1355 (progn
1356 (defimplementation return-from-frame (index form)
1357 (let* ((frame (nth-frame index)))
1358 (cond ((sb-debug:frame-has-debug-tag-p frame)
1359 (let ((values (multiple-value-list (eval-in-frame form index))))
1360 (sb-debug:unwind-to-frame-and-call frame
1361 (lambda ()
1362 (values-list values)))))
1363 (t (format nil "Cannot return from frame: ~S" frame)))))
1364
1365 (defimplementation restart-frame (index)
1366 (let ((frame (nth-frame index)))
1367 (when (sb-debug:frame-has-debug-tag-p frame)
1368 (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1369 (multiple-value-bind (fun arglist)
1370 (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1371 (values (fdefinition fname) args)
1372 (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1373 (sb-debug::frame-args-as-list frame)))
1374 (when (functionp fun)
1375 (sb-debug:unwind-to-frame-and-call
1376 frame
1377 (lambda ()
1378 ;; Ensure TCO.
1379 (declare (optimize (debug 0)))
1380 (apply fun arglist)))))))
1381 (format nil "Cannot restart frame: ~S" frame))))
1382
1383 ;; FIXME: this implementation doesn't unwind the stack before
1384 ;; re-invoking the function, but it's better than no implementation at
1385 ;; all.
1386 #-#.(swank-backend::sbcl-with-restart-frame)
1387 (progn
1388 (defun sb-debug-catch-tag-p (tag)
1389 (and (symbolp tag)
1390 (not (symbol-package tag))
1391 (string= tag :sb-debug-catch-tag)))
1392
1393 (defimplementation return-from-frame (index form)
1394 (let* ((frame (nth-frame index))
1395 (probe (assoc-if #'sb-debug-catch-tag-p
1396 (sb-di::frame-catches frame))))
1397 (cond (probe (throw (car probe) (eval-in-frame form index)))
1398 (t (format nil "Cannot return from frame: ~S" frame)))))
1399
1400 (defimplementation restart-frame (index)
1401 (let ((frame (nth-frame index)))
1402 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1403
1404 ;;;;; reference-conditions
1405
1406 (defimplementation format-sldb-condition (condition)
1407 (let ((sb-int:*print-condition-references* nil))
1408 (princ-to-string condition)))
1409
1410
1411 ;;;; Profiling
1412
1413 (defimplementation profile (fname)
1414 (when fname (eval `(sb-profile:profile ,fname))))
1415
1416 (defimplementation unprofile (fname)
1417 (when fname (eval `(sb-profile:unprofile ,fname))))
1418
1419 (defimplementation unprofile-all ()
1420 (sb-profile:unprofile)
1421 "All functions unprofiled.")
1422
1423 (defimplementation profile-report ()
1424 (sb-profile:report))
1425
1426 (defimplementation profile-reset ()
1427 (sb-profile:reset)
1428 "Reset profiling counters.")
1429
1430 (defimplementation profiled-functions ()
1431 (sb-profile:profile))
1432
1433 (defimplementation profile-package (package callers methods)
1434 (declare (ignore callers methods))
1435 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1436
1437
1438 ;;;; Inspector
1439
1440 (defmethod emacs-inspect ((o t))
1441 (cond ((sb-di::indirect-value-cell-p o)
1442 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1443 (t
1444 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1445 (list* (string-right-trim '(#\Newline) text)
1446 '(:newline)
1447 (if label
1448 (loop for (l . v) in parts
1449 append (label-value-line l v))
1450 (loop for value in parts
1451 for i from 0
1452 append (label-value-line i value))))))))
1453
1454 (defmethod emacs-inspect ((o function))
1455 (let ((header (sb-kernel:widetag-of o)))
1456 (cond ((= header sb-vm:simple-fun-header-widetag)
1457 (label-value-line*
1458 (:name (sb-kernel:%simple-fun-name o))
1459 (:arglist (sb-kernel:%simple-fun-arglist o))
1460 (:self (sb-kernel:%simple-fun-self o))
1461 (:next (sb-kernel:%simple-fun-next o))
1462 (:type (sb-kernel:%simple-fun-type o))
1463 (:code (sb-kernel:fun-code-header o))))
1464 ((= header sb-vm:closure-header-widetag)
1465 (append
1466 (label-value-line :function (sb-kernel:%closure-fun o))
1467 `("Closed over values:" (:newline))
1468 (loop for i below (1- (sb-kernel:get-closure-length o))
1469 append (label-value-line
1470 i (sb-kernel:%closure-index-ref o i)))))
1471 (t (call-next-method o)))))
1472
1473 (defmethod emacs-inspect ((o sb-kernel:code-component))
1474 (append
1475 (label-value-line*
1476 (:code-size (sb-kernel:%code-code-size o))
1477 (:entry-points (sb-kernel:%code-entry-points o))
1478 (:debug-info (sb-kernel:%code-debug-info o))
1479 (:trace-table-offset (sb-kernel:code-header-ref
1480 o sb-vm:code-trace-table-offset-slot)))
1481 `("Constants:" (:newline))
1482 (loop for i from sb-vm:code-constants-offset
1483 below (sb-kernel:get-header-data o)
1484 append (label-value-line i (sb-kernel:code-header-ref o i)))
1485 `("Code:" (:newline)
1486 , (with-output-to-string (s)
1487 (cond ((sb-kernel:%code-debug-info o)
1488 (sb-disassem:disassemble-code-component o :stream s))
1489 (t
1490 (sb-disassem:disassemble-memory
1491 (sb-disassem::align
1492 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1493 sb-vm:lowtag-mask)
1494 (* sb-vm:code-constants-offset
1495 sb-vm:n-word-bytes))
1496 (ash 1 sb-vm:n-lowtag-bits))
1497 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1498 :stream s)))))))
1499
1500 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1501 (label-value-line*
1502 (:value (sb-ext:weak-pointer-value o))))
1503
1504 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1505 (label-value-line*
1506 (:name (sb-kernel:fdefn-name o))
1507 (:function (sb-kernel:fdefn-fun o))))
1508
1509 (defmethod emacs-inspect :around ((o generic-function))
1510 (append
1511 (call-next-method)
1512 (label-value-line*
1513 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1514 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1515 )))
1516
1517
1518 ;;;; Multiprocessing
1519
1520 #+(and sb-thread
1521 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1522 (progn
1523 (defvar *thread-id-counter* 0)
1524
1525 (defvar *thread-id-counter-lock*
1526 (sb-thread:make-mutex :name "thread id counter lock"))
1527
1528 (defun next-thread-id ()
1529 (sb-thread:with-mutex (*thread-id-counter-lock*)
1530 (incf *thread-id-counter*)))
1531
1532 (defparameter *thread-id-map* (make-hash-table))
1533
1534 ;; This should be a thread -> id map but as weak keys are not
1535 ;; supported it is id -> map instead.
1536 (defvar *thread-id-map-lock*
1537 (sb-thread:make-mutex :name "thread id map lock"))
1538
1539 (defimplementation spawn (fn &key name)
1540 (sb-thread:make-thread fn :name name))
1541
1542 (defimplementation thread-id (thread)
1543 (block thread-id
1544 (sb-thread:with-mutex (*thread-id-map-lock*)
1545 (loop for id being the hash-key in *thread-id-map*
1546 using (hash-value thread-pointer)
1547 do
1548 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1549 (cond ((null maybe-thread)
1550 ;; the value is gc'd, remove it manually
1551 (remhash id *thread-id-map*))
1552 ((eq thread maybe-thread)
1553 (return-from thread-id id)))))
1554 ;; lazy numbering
1555 (let ((id (next-thread-id)))
1556 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1557 id))))
1558
1559 (defimplementation find-thread (id)
1560 (sb-thread:with-mutex (*thread-id-map-lock*)
1561 (let ((thread-pointer (gethash id *thread-id-map*)))
1562 (if thread-pointer
1563 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1564 (if maybe-thread
1565 maybe-thread
1566 ;; the value is gc'd, remove it manually
1567 (progn
1568 (remhash id *thread-id-map*)
1569 nil)))
1570 nil))))
1571
1572 (defimplementation thread-name (thread)
1573 ;; sometimes the name is not a string (e.g. NIL)
1574 (princ-to-string (sb-thread:thread-name thread)))
1575
1576 (defimplementation thread-status (thread)
1577 (if (sb-thread:thread-alive-p thread)
1578 "Running"
1579 "Stopped"))
1580
1581 (defimplementation make-lock (&key name)
1582 (sb-thread:make-mutex :name name))
1583
1584 (defimplementation call-with-lock-held (lock function)
1585 (declare (type function function))
1586 (sb-thread:with-recursive-lock (lock) (funcall function)))
1587
1588 (defimplementation current-thread ()
1589 sb-thread:*current-thread*)
1590
1591 (defimplementation all-threads ()
1592 (sb-thread:list-all-threads))
1593
1594 (defimplementation interrupt-thread (thread fn)
1595 (sb-thread:interrupt-thread thread fn))
1596
1597 (defimplementation kill-thread (thread)
1598 (sb-thread:terminate-thread thread))
1599
1600 (defimplementation thread-alive-p (thread)
1601 (sb-thread:thread-alive-p thread))
1602
1603 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1604 (defvar *mailboxes* (list))
1605 (declaim (type list *mailboxes*))
1606
1607 (defstruct (mailbox (:conc-name mailbox.))
1608 thread
1609 (mutex (sb-thread:make-mutex))
1610 (waitqueue (sb-thread:make-waitqueue))
1611 (queue '() :type list))
1612
1613 (defun mailbox (thread)
1614 "Return THREAD's mailbox."
1615 (sb-thread:with-mutex (*mailbox-lock*)
1616 (or (find thread *mailboxes* :key #'mailbox.thread)
1617 (let ((mb (make-mailbox :thread thread)))
1618 (push mb *mailboxes*)
1619 mb))))
1620
1621 (defimplementation send (thread message)
1622 (let* ((mbox (mailbox thread))
1623 (mutex (mailbox.mutex mbox)))
1624 (sb-thread:with-mutex (mutex)
1625 (setf (mailbox.queue mbox)
1626 (nconc (mailbox.queue mbox) (list message)))
1627 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1628
1629
1630 (defun condition-timed-wait (waitqueue mutex timeout)
1631 (macrolet ((foo ()
1632 (cond ((member :sb-lutex *features*) ; Darwin
1633 '(sb-thread:condition-wait waitqueue mutex))
1634 (t
1635 '(handler-case
1636 (let ((*break-on-signals* nil))
1637 (sb-sys:with-deadline (:seconds timeout
1638 :override t)
1639 (sb-thread:condition-wait waitqueue mutex) t))
1640 (sb-ext:timeout ()
1641 nil))))))
1642 (foo)))
1643
1644 (defimplementation receive-if (test &optional timeout)
1645 (let* ((mbox (mailbox (current-thread)))
1646 (mutex (mailbox.mutex mbox))
1647 (waitq (mailbox.waitqueue mbox)))
1648 (assert (or (not timeout) (eq timeout t)))
1649 (loop
1650 (check-slime-interrupts)
1651 (sb-thread:with-mutex (mutex)
1652 (let* ((q (mailbox.queue mbox))
1653 (tail (member-if test q)))
1654 (when tail
1655 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1656 (return (car tail))))
1657 (when (eq timeout t) (return (values nil t)))
1658 (condition-timed-wait waitq mutex 0.2)))))
1659
1660 (let ((alist '())
1661 (mutex (sb-thread:make-mutex :name "register-thread")))
1662
1663 (defimplementation register-thread (name thread)
1664 (declare (type symbol name))
1665 (sb-thread:with-mutex (mutex)
1666 (etypecase thread
1667 (null
1668 (setf alist (delete name alist :key #'car)))
1669 (sb-thread:thread
1670 (let ((probe (assoc name alist)))
1671 (cond (probe (setf (cdr probe) thread))
1672 (t (setf alist (acons name thread alist))))))))
1673 nil)
1674
1675 (defimplementation find-registered (name)
1676 (sb-thread:with-mutex (mutex)
1677 (cdr (assoc name alist)))))
1678
1679 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1680 ;; buffer write lock.
1681 ;;
1682 ;; Another alternative would be to grab the world-lock here, but that's less
1683 ;; future-proof, and could introduce other lock-ordering issues in the
1684 ;; future.
1685 ;;
1686 ;; In an ideal world we would just have an :AROUND method on
1687 ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1688 ;; file is loaded -- so first we need a dummy definition that will be
1689 ;; overridden by swank-gray.lisp.
1690 (defclass slime-output-stream (fundamental-character-output-stream)
1691 ())
1692 (defmethod stream-force-output :around ((stream slime-output-stream))
1693 (handler-case
1694 (sb-sys:with-deadline (:seconds 0.1)
1695 (call-next-method))
1696 (sb-sys:deadline-timeout ()
1697 nil)))
1698 )
1699
1700 (defimplementation quit-lisp ()
1701 #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1702 (sb-ext:exit)
1703 #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1704 (progn
1705 #+sb-thread
1706 (dolist (thread (remove (current-thread) (all-threads)))
1707 (ignore-errors (sb-thread:terminate-thread thread)))
1708 (sb-ext:quit)))
1709
1710
1711
1712 ;;Trace implementations
1713 ;;In SBCL, we have:
1714 ;; (trace <name>)
1715 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1716 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1717 ;; <name> can be a normal name or a (setf name)
1718
1719 (defun toggle-trace-aux (fspec &rest args)
1720 (cond ((member fspec (eval '(trace)) :test #'equal)
1721 (eval `(untrace ,fspec))
1722 (format nil "~S is now untraced." fspec))
1723 (t
1724 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1725 (format nil "~S is now traced." fspec))))
1726
1727 (defun process-fspec (fspec)
1728 (cond ((consp fspec)
1729 (ecase (first fspec)
1730 ((:defun :defgeneric) (second fspec))
1731 ((:defmethod) `(method ,@(rest fspec)))
1732 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1733 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1734 (t
1735 fspec)))
1736
1737 (defimplementation toggle-trace (spec)
1738 (ecase (car spec)
1739 ((setf)
1740 (toggle-trace-aux spec))
1741 ((:defmethod)
1742 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1743 ((:defgeneric)
1744 (toggle-trace-aux (second spec) :methods t))
1745 ((:call)
1746 (destructuring-bind (caller callee) (cdr spec)
1747 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1748
1749 ;;; Weak datastructures
1750
1751 (defimplementation make-weak-key-hash-table (&rest args)
1752 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1753 (apply #'make-hash-table :weakness :key args)
1754 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1755 (apply #'make-hash-table args))
1756
1757 (defimplementation make-weak-value-hash-table (&rest args)
1758 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1759 (apply #'make-hash-table :weakness :value args)
1760 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1761 (apply #'make-hash-table args))
1762
1763 (defimplementation hash-table-weakness (hashtable)
1764 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1765 (sb-ext:hash-table-weakness hashtable))
1766
1767 #-win32
1768 (defimplementation save-image (filename &optional restart-function)
1769 (flet ((restart-sbcl ()
1770 (sb-debug::enable-debugger)
1771 (setf sb-impl::*descriptor-handlers* nil)
1772 (funcall restart-function)))
1773 (let ((pid (sb-posix:fork)))
1774 (cond ((= pid 0)
1775 (sb-debug::disable-debugger)
1776 (apply #'sb-ext:save-lisp-and-die filename
1777 (when restart-function
1778 (list :toplevel #'restart-sbcl))))
1779 (t
1780 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1781 (assert (= pid rpid))
1782 (assert (and (sb-posix:wifexited status)
1783 (zerop (sb-posix:wexitstatus status))))))))))
1784
1785 #+unix
1786 (progn
1787 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1788 (program sb-alien:c-string)
1789 (argv (* sb-alien:c-string)))
1790
1791 (defun execv (program args)
1792 "Replace current executable with another one."
1793 (let ((a-args (sb-alien:make-alien sb-alien:c-string
1794 (+ 1 (length args)))))
1795 (unwind-protect
1796 (progn
1797 (loop for index from 0 by 1
1798 and item in (append args '(nil))
1799 do (setf (sb-alien:deref a-args index)
1800 item))
1801 (when (minusp
1802 (sys-execv program a-args))
1803 (error "execv(3) returned.")))
1804 (sb-alien:free-alien a-args))))
1805
1806 (defun runtime-pathname ()
1807 #+#.(swank-backend:with-symbol
1808 '*runtime-pathname* 'sb-ext)
1809 sb-ext:*runtime-pathname*
1810 #-#.(swank-backend:with-symbol
1811 '*runtime-pathname* 'sb-ext)
1812 (car sb-ext:*posix-argv*))
1813
1814 (defimplementation exec-image (image-file args)
1815 (loop with fd-arg =
1816 (loop for arg in args
1817 and key = "" then arg
1818 when (string-equal key "--swank-fd")
1819 return (parse-integer arg))
1820 for my-fd from 3 to 1024
1821 when (/= my-fd fd-arg)
1822 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1823 (let* ((self-string (pathname-to-filename (runtime-pathname))))
1824 (execv
1825 self-string
1826 (apply 'list self-string "--core" image-file args)))))
1827
1828 (defimplementation make-fd-stream (fd external-format)
1829 (sb-sys:make-fd-stream fd :input t :output t
1830 :element-type 'character
1831 :buffering :full
1832 :dual-channel-p t
1833 :external-format external-format))
1834
1835 #-win32
1836 (defimplementation background-save-image (filename &key restart-function
1837 completion-function)
1838 (flet ((restart-sbcl ()
1839 (sb-debug::enable-debugger)
1840 (setf sb-impl::*descriptor-handlers* nil)
1841 (funcall restart-function)))
1842 (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1843 (let ((pid (sb-posix:fork)))
1844 (cond ((= pid 0)
1845 (sb-posix:close pipe-in)
1846 (sb-debug::disable-debugger)
1847 (apply #'sb-ext:save-lisp-and-die filename
1848 (when restart-function
1849 (list :toplevel #'restart-sbcl))))
1850 (t
1851 (sb-posix:close pipe-out)
1852 (sb-sys:add-fd-handler
1853 pipe-in :input
1854 (lambda (fd)
1855 (sb-sys:invalidate-descriptor fd)
1856 (sb-posix:close fd)
1857 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1858 (assert (= pid rpid))
1859 (assert (sb-posix:wifexited status))
1860 (funcall completion-function
1861 (zerop (sb-posix:wexitstatus status))))))))))))
1862
1863 (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5