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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5