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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5