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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.321 - (show annotations)
Fri May 11 18:08:45 2012 UTC (23 months ago) by heller
Branch: MAIN
Changes since 1.320: +1 -1 lines
* swank-sbcl.lisp (stream-force-output): Use with-world-lock
i.e. with-recursive-lock instead of with-mutex.
* slime.el (sbcl-world-lock): New test.
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* (if *debug-swank-backend*
1073 (sb-di:top-frame)
1074 (or sb-debug:*stack-top-hint*
1075 (sb-di:top-frame))))
1076 (sb-debug:*stack-top-hint* nil))
1077 (handler-bind ((sb-di:debug-condition
1078 (lambda (condition)
1079 (signal (make-condition
1080 'sldb-condition
1081 :original-condition condition)))))
1082 (funcall debugger-loop-fn))))
1083
1084 #+#.(swank-backend::sbcl-with-new-stepper-p)
1085 (progn
1086 (defimplementation activate-stepping (frame)
1087 (declare (ignore frame))
1088 (sb-impl::enable-stepping))
1089 (defimplementation sldb-stepper-condition-p (condition)
1090 (typep condition 'sb-ext:step-form-condition))
1091 (defimplementation sldb-step-into ()
1092 (invoke-restart 'sb-ext:step-into))
1093 (defimplementation sldb-step-next ()
1094 (invoke-restart 'sb-ext:step-next))
1095 (defimplementation sldb-step-out ()
1096 (invoke-restart 'sb-ext:step-out)))
1097
1098 (defimplementation call-with-debugger-hook (hook fun)
1099 (let ((*debugger-hook* hook)
1100 #+#.(swank-backend::sbcl-with-new-stepper-p)
1101 (sb-ext:*stepper-hook*
1102 (lambda (condition)
1103 (typecase condition
1104 (sb-ext:step-form-condition
1105 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1106 (sb-impl::invoke-debugger condition)))))))
1107 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1108 (sb-ext:step-condition #'sb-impl::invoke-stepper))
1109 (call-with-break-hook hook fun))))
1110
1111 (defun nth-frame (index)
1112 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1113 (i index (1- i)))
1114 ((zerop i) frame)))
1115
1116 (defimplementation compute-backtrace (start end)
1117 "Return a list of frames starting with frame number START and
1118 continuing to frame number END or, if END is nil, the last frame on the
1119 stack."
1120 (let ((end (or end most-positive-fixnum)))
1121 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1122 for i from start below end
1123 while f collect f)))
1124
1125 (defimplementation print-frame (frame stream)
1126 (sb-debug::print-frame-call frame stream))
1127
1128 (defimplementation frame-restartable-p (frame)
1129 #+#.(swank-backend::sbcl-with-restart-frame)
1130 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1131
1132 (defimplementation frame-call (frame-number)
1133 (multiple-value-bind (name args)
1134 (sb-debug::frame-call (nth-frame frame-number))
1135 (with-output-to-string (stream)
1136 (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1137 (let ((*print-length* nil)
1138 (*print-level* nil))
1139 (prin1 (sb-debug::ensure-printable-object name) stream))
1140 (let ((args (sb-debug::ensure-printable-object args)))
1141 (if (listp args)
1142 (format stream "~{ ~_~S~}" args)
1143 (format stream " ~S" args)))))))
1144
1145 ;;;; Code-location -> source-location translation
1146
1147 ;;; If debug-block info is avaibale, we determine the file position of
1148 ;;; the source-path for a code-location. If the code was compiled
1149 ;;; with C-c C-c, we have to search the position in the source string.
1150 ;;; If there's no debug-block info, we return the (less precise)
1151 ;;; source-location of the corresponding function.
1152
1153 (defun code-location-source-location (code-location)
1154 (let* ((dsource (sb-di:code-location-debug-source code-location))
1155 (plist (sb-c::debug-source-plist dsource)))
1156 (if (getf plist :emacs-buffer)
1157 (emacs-buffer-source-location code-location plist)
1158 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1159 (ecase (sb-di:debug-source-from dsource)
1160 (:file (file-source-location code-location))
1161 (:lisp (lisp-source-location code-location)))
1162 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1163 (if (sb-di:debug-source-namestring dsource)
1164 (file-source-location code-location)
1165 (lisp-source-location code-location)))))
1166
1167 ;;; FIXME: The naming policy of source-location functions is a bit
1168 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1169 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1170 ;;; which returns the source location for a _code-location_.
1171 ;;;
1172 ;;; Maybe these should be named code-location-file-source-location,
1173 ;;; etc, turned into generic functions, or something. In the very
1174 ;;; least the names should indicate the main entry point vs. helper
1175 ;;; status.
1176
1177 (defun file-source-location (code-location)
1178 (if (code-location-has-debug-block-info-p code-location)
1179 (source-file-source-location code-location)
1180 (fallback-source-location code-location)))
1181
1182 (defun fallback-source-location (code-location)
1183 (let ((fun (code-location-debug-fun-fun code-location)))
1184 (cond (fun (function-source-location fun))
1185 (t (error "Cannot find source location for: ~A " code-location)))))
1186
1187 (defun lisp-source-location (code-location)
1188 (let ((source (prin1-to-string
1189 (sb-debug::code-location-source-form code-location 100)))
1190 (condition (swank-value '*swank-debugger-condition*)))
1191 (if (and (typep condition 'sb-impl::step-form-condition)
1192 (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1193 :test #'char-equal)
1194 (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1195 ;; The initial form is utterly uninteresting -- and almost
1196 ;; certainly right there in the REPL.
1197 (make-error-location "Stepping...")
1198 (make-location `(:source-form ,source) '(:position 1)))))
1199
1200 (defun emacs-buffer-source-location (code-location plist)
1201 (if (code-location-has-debug-block-info-p code-location)
1202 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1203 &allow-other-keys)
1204 plist
1205 (let* ((pos (string-source-position code-location emacs-string))
1206 (snipped (read-snippet-from-string emacs-string pos)))
1207 (make-location `(:buffer ,emacs-buffer)
1208 `(:offset ,emacs-position ,pos)
1209 `(:snippet ,snipped))))
1210 (fallback-source-location code-location)))
1211
1212 (defun source-file-source-location (code-location)
1213 (let* ((code-date (code-location-debug-source-created code-location))
1214 (filename (code-location-debug-source-name code-location))
1215 (*readtable* (guess-readtable-for-filename filename))
1216 (source-code (get-source-code filename code-date)))
1217 (with-debootstrapping
1218 (with-input-from-string (s source-code)
1219 (let* ((pos (stream-source-position code-location s))
1220 (snippet (read-snippet s pos)))
1221 (make-location `(:file ,filename)
1222 `(:position ,pos)
1223 `(:snippet ,snippet)))))))
1224
1225 (defun code-location-debug-source-name (code-location)
1226 (namestring (truename (#+#.(swank-backend:with-symbol
1227 'debug-source-name 'sb-di)
1228 sb-c::debug-source-name
1229 #-#.(swank-backend:with-symbol
1230 'debug-source-name 'sb-di)
1231 sb-c::debug-source-namestring
1232 (sb-di::code-location-debug-source code-location)))))
1233
1234 (defun code-location-debug-source-created (code-location)
1235 (sb-c::debug-source-created
1236 (sb-di::code-location-debug-source code-location)))
1237
1238 (defun code-location-debug-fun-fun (code-location)
1239 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1240
1241 (defun code-location-has-debug-block-info-p (code-location)
1242 (handler-case
1243 (progn (sb-di:code-location-debug-block code-location)
1244 t)
1245 (sb-di:no-debug-blocks () nil)))
1246
1247 (defun stream-source-position (code-location stream)
1248 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1249 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1250 (form-number (sb-di::code-location-form-number cloc)))
1251 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1252 (let* ((path-table (sb-di::form-number-translations tlf 0))
1253 (path (cond ((<= (length path-table) form-number)
1254 (warn "inconsistent form-number-translations")
1255 (list 0))
1256 (t
1257 (reverse (cdr (aref path-table form-number)))))))
1258 (source-path-source-position path tlf pos-map)))))
1259
1260 (defun string-source-position (code-location string)
1261 (with-input-from-string (s string)
1262 (stream-source-position code-location s)))
1263
1264 ;;; source-path-file-position and friends are in swank-source-path-parser
1265
1266 (defimplementation frame-source-location (index)
1267 (converting-errors-to-error-location
1268 (code-location-source-location
1269 (sb-di:frame-code-location (nth-frame index)))))
1270
1271 (defun frame-debug-vars (frame)
1272 "Return a vector of debug-variables in frame."
1273 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1274
1275 (defun debug-var-value (var frame location)
1276 (ecase (sb-di:debug-var-validity var location)
1277 (:valid (sb-di:debug-var-value var frame))
1278 ((:invalid :unknown) ':<not-available>)))
1279
1280 (defun debug-var-info (var)
1281 ;; Introduced by SBCL 1.0.49.76.
1282 (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1283 (when (and s (fboundp s))
1284 (funcall s var))))
1285
1286 (defimplementation frame-locals (index)
1287 (let* ((frame (nth-frame index))
1288 (loc (sb-di:frame-code-location frame))
1289 (vars (frame-debug-vars frame))
1290 ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1291 ;; specially.
1292 (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1293 (more-context nil)
1294 (more-count nil)
1295 (more-id 0))
1296 (when vars
1297 (let ((locals
1298 (loop for v across vars
1299 do (when (eq (sb-di:debug-var-symbol v) more-name)
1300 (incf more-id))
1301 (case (debug-var-info v)
1302 (:more-context
1303 (setf more-context (debug-var-value v frame loc)))
1304 (:more-count
1305 (setf more-count (debug-var-value v frame loc))))
1306 collect
1307 (list :name (sb-di:debug-var-symbol v)
1308 :id (sb-di:debug-var-id v)
1309 :value (debug-var-value v frame loc)))))
1310 (when (and more-context more-count)
1311 (setf locals (append locals
1312 (list
1313 (list :name more-name
1314 :id more-id
1315 :value (multiple-value-list
1316 (sb-c:%more-arg-values
1317 more-context
1318 0 more-count)))))))
1319 locals))))
1320
1321 (defimplementation frame-var-value (frame var)
1322 (let* ((frame (nth-frame frame))
1323 (vars (frame-debug-vars frame))
1324 (loc (sb-di:frame-code-location frame))
1325 (dvar (if (= var (length vars))
1326 ;; If VAR is out of bounds, it must be the fake var
1327 ;; we made up for &MORE.
1328 (let* ((context-var (find :more-context vars
1329 :key #'debug-var-info))
1330 (more-context (debug-var-value context-var frame
1331 loc))
1332 (count-var (find :more-count vars
1333 :key #'debug-var-info))
1334 (more-count (debug-var-value count-var frame loc)))
1335 (return-from frame-var-value
1336 (multiple-value-list (sb-c:%more-arg-values
1337 more-context
1338 0 more-count))))
1339 (aref vars var))))
1340 (debug-var-value dvar frame loc)))
1341
1342 (defimplementation frame-catch-tags (index)
1343 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1344
1345 (defimplementation eval-in-frame (form index)
1346 (let ((frame (nth-frame index)))
1347 (funcall (the function
1348 (sb-di:preprocess-for-eval form
1349 (sb-di:frame-code-location frame)))
1350 frame)))
1351
1352 #+#.(swank-backend::sbcl-with-restart-frame)
1353 (progn
1354 (defimplementation return-from-frame (index form)
1355 (let* ((frame (nth-frame index)))
1356 (cond ((sb-debug:frame-has-debug-tag-p frame)
1357 (let ((values (multiple-value-list (eval-in-frame form index))))
1358 (sb-debug:unwind-to-frame-and-call frame
1359 (lambda ()
1360 (values-list values)))))
1361 (t (format nil "Cannot return from frame: ~S" frame)))))
1362
1363 (defimplementation restart-frame (index)
1364 (let ((frame (nth-frame index)))
1365 (when (sb-debug:frame-has-debug-tag-p frame)
1366 (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1367 (multiple-value-bind (fun arglist)
1368 (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1369 (values (fdefinition fname) args)
1370 (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1371 (sb-debug::frame-args-as-list frame)))
1372 (when (functionp fun)
1373 (sb-debug:unwind-to-frame-and-call
1374 frame
1375 (lambda ()
1376 ;; Ensure TCO.
1377 (declare (optimize (debug 0)))
1378 (apply fun arglist)))))))
1379 (format nil "Cannot restart frame: ~S" frame))))
1380
1381 ;; FIXME: this implementation doesn't unwind the stack before
1382 ;; re-invoking the function, but it's better than no implementation at
1383 ;; all.
1384 #-#.(swank-backend::sbcl-with-restart-frame)
1385 (progn
1386 (defun sb-debug-catch-tag-p (tag)
1387 (and (symbolp tag)
1388 (not (symbol-package tag))
1389 (string= tag :sb-debug-catch-tag)))
1390
1391 (defimplementation return-from-frame (index form)
1392 (let* ((frame (nth-frame index))
1393 (probe (assoc-if #'sb-debug-catch-tag-p
1394 (sb-di::frame-catches frame))))
1395 (cond (probe (throw (car probe) (eval-in-frame form index)))
1396 (t (format nil "Cannot return from frame: ~S" frame)))))
1397
1398 (defimplementation restart-frame (index)
1399 (let ((frame (nth-frame index)))
1400 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1401
1402 ;;;;; reference-conditions
1403
1404 (defimplementation format-sldb-condition (condition)
1405 (let ((sb-int:*print-condition-references* nil))
1406 (princ-to-string condition)))
1407
1408
1409 ;;;; Profiling
1410
1411 (defimplementation profile (fname)
1412 (when fname (eval `(sb-profile:profile ,fname))))
1413
1414 (defimplementation unprofile (fname)
1415 (when fname (eval `(sb-profile:unprofile ,fname))))
1416
1417 (defimplementation unprofile-all ()
1418 (sb-profile:unprofile)
1419 "All functions unprofiled.")
1420
1421 (defimplementation profile-report ()
1422 (sb-profile:report))
1423
1424 (defimplementation profile-reset ()
1425 (sb-profile:reset)
1426 "Reset profiling counters.")
1427
1428 (defimplementation profiled-functions ()
1429 (sb-profile:profile))
1430
1431 (defimplementation profile-package (package callers methods)
1432 (declare (ignore callers methods))
1433 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1434
1435
1436 ;;;; Inspector
1437
1438 (defmethod emacs-inspect ((o t))
1439 (cond ((sb-di::indirect-value-cell-p o)
1440 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1441 (t
1442 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1443 (list* (string-right-trim '(#\Newline) text)
1444 '(:newline)
1445 (if label
1446 (loop for (l . v) in parts
1447 append (label-value-line l v))
1448 (loop for value in parts
1449 for i from 0
1450 append (label-value-line i value))))))))
1451
1452 (defmethod emacs-inspect ((o function))
1453 (let ((header (sb-kernel:widetag-of o)))
1454 (cond ((= header sb-vm:simple-fun-header-widetag)
1455 (label-value-line*
1456 (:name (sb-kernel:%simple-fun-name o))
1457 (:arglist (sb-kernel:%simple-fun-arglist o))
1458 (:self (sb-kernel:%simple-fun-self o))
1459 (:next (sb-kernel:%simple-fun-next o))
1460 (:type (sb-kernel:%simple-fun-type o))
1461 (:code (sb-kernel:fun-code-header o))))
1462 ((= header sb-vm:closure-header-widetag)
1463 (append
1464 (label-value-line :function (sb-kernel:%closure-fun o))
1465 `("Closed over values:" (:newline))
1466 (loop for i below (1- (sb-kernel:get-closure-length o))
1467 append (label-value-line
1468 i (sb-kernel:%closure-index-ref o i)))))
1469 (t (call-next-method o)))))
1470
1471 (defmethod emacs-inspect ((o sb-kernel:code-component))
1472 (append
1473 (label-value-line*
1474 (:code-size (sb-kernel:%code-code-size o))
1475 (:entry-points (sb-kernel:%code-entry-points o))
1476 (:debug-info (sb-kernel:%code-debug-info o))
1477 (:trace-table-offset (sb-kernel:code-header-ref
1478 o sb-vm:code-trace-table-offset-slot)))
1479 `("Constants:" (:newline))
1480 (loop for i from sb-vm:code-constants-offset
1481 below (sb-kernel:get-header-data o)
1482 append (label-value-line i (sb-kernel:code-header-ref o i)))
1483 `("Code:" (:newline)
1484 , (with-output-to-string (s)
1485 (cond ((sb-kernel:%code-debug-info o)
1486 (sb-disassem:disassemble-code-component o :stream s))
1487 (t
1488 (sb-disassem:disassemble-memory
1489 (sb-disassem::align
1490 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1491 sb-vm:lowtag-mask)
1492 (* sb-vm:code-constants-offset
1493 sb-vm:n-word-bytes))
1494 (ash 1 sb-vm:n-lowtag-bits))
1495 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1496 :stream s)))))))
1497
1498 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1499 (label-value-line*
1500 (:value (sb-ext:weak-pointer-value o))))
1501
1502 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1503 (label-value-line*
1504 (:name (sb-kernel:fdefn-name o))
1505 (:function (sb-kernel:fdefn-fun o))))
1506
1507 (defmethod emacs-inspect :around ((o generic-function))
1508 (append
1509 (call-next-method)
1510 (label-value-line*
1511 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1512 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1513 )))
1514
1515
1516 ;;;; Multiprocessing
1517
1518 #+(and sb-thread
1519 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1520 (progn
1521 (defvar *thread-id-counter* 0)
1522
1523 (defvar *thread-id-counter-lock*
1524 (sb-thread:make-mutex :name "thread id counter lock"))
1525
1526 (defun next-thread-id ()
1527 (sb-thread:with-mutex (*thread-id-counter-lock*)
1528 (incf *thread-id-counter*)))
1529
1530 (defparameter *thread-id-map* (make-hash-table))
1531
1532 ;; This should be a thread -> id map but as weak keys are not
1533 ;; supported it is id -> map instead.
1534 (defvar *thread-id-map-lock*
1535 (sb-thread:make-mutex :name "thread id map lock"))
1536
1537 (defimplementation spawn (fn &key name)
1538 (sb-thread:make-thread fn :name name))
1539
1540 (defimplementation thread-id (thread)
1541 (block thread-id
1542 (sb-thread:with-mutex (*thread-id-map-lock*)
1543 (loop for id being the hash-key in *thread-id-map*
1544 using (hash-value thread-pointer)
1545 do
1546 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1547 (cond ((null maybe-thread)
1548 ;; the value is gc'd, remove it manually
1549 (remhash id *thread-id-map*))
1550 ((eq thread maybe-thread)
1551 (return-from thread-id id)))))
1552 ;; lazy numbering
1553 (let ((id (next-thread-id)))
1554 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1555 id))))
1556
1557 (defimplementation find-thread (id)
1558 (sb-thread:with-mutex (*thread-id-map-lock*)
1559 (let ((thread-pointer (gethash id *thread-id-map*)))
1560 (if thread-pointer
1561 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1562 (if maybe-thread
1563 maybe-thread
1564 ;; the value is gc'd, remove it manually
1565 (progn
1566 (remhash id *thread-id-map*)
1567 nil)))
1568 nil))))
1569
1570 (defimplementation thread-name (thread)
1571 ;; sometimes the name is not a string (e.g. NIL)
1572 (princ-to-string (sb-thread:thread-name thread)))
1573
1574 (defimplementation thread-status (thread)
1575 (if (sb-thread:thread-alive-p thread)
1576 "Running"
1577 "Stopped"))
1578
1579 (defimplementation make-lock (&key name)
1580 (sb-thread:make-mutex :name name))
1581
1582 (defimplementation call-with-lock-held (lock function)
1583 (declare (type function function))
1584 (sb-thread:with-recursive-lock (lock) (funcall function)))
1585
1586 (defimplementation current-thread ()
1587 sb-thread:*current-thread*)
1588
1589 (defimplementation all-threads ()
1590 (sb-thread:list-all-threads))
1591
1592 (defimplementation interrupt-thread (thread fn)
1593 (sb-thread:interrupt-thread thread fn))
1594
1595 (defimplementation kill-thread (thread)
1596 (sb-thread:terminate-thread thread))
1597
1598 (defimplementation thread-alive-p (thread)
1599 (sb-thread:thread-alive-p thread))
1600
1601 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1602 (defvar *mailboxes* (list))
1603 (declaim (type list *mailboxes*))
1604
1605 (defstruct (mailbox (:conc-name mailbox.))
1606 thread
1607 (mutex (sb-thread:make-mutex))
1608 (waitqueue (sb-thread:make-waitqueue))
1609 (queue '() :type list))
1610
1611 (defun mailbox (thread)
1612 "Return THREAD's mailbox."
1613 (sb-thread:with-mutex (*mailbox-lock*)
1614 (or (find thread *mailboxes* :key #'mailbox.thread)
1615 (let ((mb (make-mailbox :thread thread)))
1616 (push mb *mailboxes*)
1617 mb))))
1618
1619 (defimplementation send (thread message)
1620 (let* ((mbox (mailbox thread))
1621 (mutex (mailbox.mutex mbox)))
1622 (sb-thread:with-mutex (mutex)
1623 (setf (mailbox.queue mbox)
1624 (nconc (mailbox.queue mbox) (list message)))
1625 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1626
1627
1628 (defun condition-timed-wait (waitqueue mutex timeout)
1629 (macrolet ((foo ()
1630 (cond ((> (length (sb-introspect:function-lambda-list
1631 #'sb-thread:condition-wait))
1632 2)
1633 '(sb-thread:condition-wait waitqueue mutex
1634 :timeout timeout))
1635 ((member :sb-lutex *features*) ; Darwin
1636 '(sb-thread:condition-wait waitqueue mutex))
1637 (t
1638 '(handler-case
1639 (let ((*break-on-signals* nil))
1640 (sb-sys:with-deadline (:seconds timeout
1641 :override t)
1642 (sb-thread:condition-wait waitqueue mutex) t))
1643 (sb-ext:timeout ()
1644 nil))))))
1645 (foo)))
1646
1647 (defimplementation receive-if (test &optional timeout)
1648 (let* ((mbox (mailbox (current-thread)))
1649 (mutex (mailbox.mutex mbox))
1650 (waitq (mailbox.waitqueue mbox)))
1651 (assert (or (not timeout) (eq timeout t)))
1652 (loop
1653 (check-slime-interrupts)
1654 (sb-thread:with-mutex (mutex)
1655 (let* ((q (mailbox.queue mbox))
1656 (tail (member-if test q)))
1657 (when tail
1658 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1659 (return (car tail))))
1660 (when (eq timeout t) (return (values nil t)))
1661 (condition-timed-wait waitq mutex 0.2)))))
1662
1663 (let ((alist '())
1664 (mutex (sb-thread:make-mutex :name "register-thread")))
1665
1666 (defimplementation register-thread (name thread)
1667 (declare (type symbol name))
1668 (sb-thread:with-mutex (mutex)
1669 (etypecase thread
1670 (null
1671 (setf alist (delete name alist :key #'car)))
1672 (sb-thread:thread
1673 (let ((probe (assoc name alist)))
1674 (cond (probe (setf (cdr probe) thread))
1675 (t (setf alist (acons name thread alist))))))))
1676 nil)
1677
1678 (defimplementation find-registered (name)
1679 (sb-thread:with-mutex (mutex)
1680 (cdr (assoc name alist)))))
1681
1682 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1683 ;; buffer write lock.
1684 ;;
1685 ;; Another alternative would be to grab the world-lock here, but that's less
1686 ;; future-proof, and could introduce other lock-ordering issues in the
1687 ;; future.
1688 ;;
1689 ;; In an ideal world we would just have an :AROUND method on
1690 ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1691 ;; file is loaded -- so first we need a dummy definition that will be
1692 ;; overridden by swank-gray.lisp.
1693 (defclass slime-output-stream (fundamental-character-output-stream)
1694 ())
1695 (defmethod stream-force-output :around ((stream slime-output-stream))
1696 (sb-kernel:with-world-lock ()
1697 (call-next-method)))
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 (defun deinit-log-output ()
1864 ;; Can't hang on to an fd-stream from a previous session.
1865 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1866 nil))
1867
1868 (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5