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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.284 - (show annotations)
Thu Jun 16 08:28:45 2011 UTC (2 years, 10 months ago) by nsiivola
Branch: MAIN
Changes since 1.283: +9 -2 lines
sbcl: compiling from buffer tmpfile directory can be a symlink

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

  ViewVC Help
Powered by ViewVC 1.1.5