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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5