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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.285 - (show annotations)
Sun Jul 3 18:15:38 2011 UTC (2 years, 9 months ago) by nsiivola
Branch: MAIN
Changes since 1.284: +49 -7 lines
sbcl: teach the SBCL backend about &MORE vars

  Only makes a difference on bleeding-edge SBCL.
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 (defun debug-var-info (var)
1192 ;; Introduced by SBCL 1.0.49.76.
1193 (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1194 (when (and s (fboundp s))
1195 (funcall s var))))
1196
1197 (defimplementation frame-locals (index)
1198 (let* ((frame (nth-frame index))
1199 (loc (sb-di:frame-code-location frame))
1200 (vars (frame-debug-vars frame))
1201 ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1202 ;; specially.
1203 (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1204 (more-context nil)
1205 (more-count nil)
1206 (more-id 0))
1207 (when vars
1208 (let ((locals
1209 (loop for v across vars
1210 do (when (eq (sb-di:debug-var-symbol v) more-name)
1211 (incf more-id))
1212 (case (debug-var-info v)
1213 (:more-context
1214 (setf more-context (debug-var-value v frame loc)))
1215 (:more-count
1216 (setf more-count (debug-var-value v frame loc))))
1217 collect
1218 (list :name (sb-di:debug-var-symbol v)
1219 :id (sb-di:debug-var-id v)
1220 :value (debug-var-value v frame loc)))))
1221 (when (and more-context more-count)
1222 (setf locals (append locals
1223 (list
1224 (list :name more-name
1225 :id more-id
1226 :value (multiple-value-list
1227 (sb-c:%more-arg-values more-context
1228 0 more-count)))))))
1229 locals))))
1230
1231 (defimplementation frame-var-value (frame var)
1232 (let* ((frame (nth-frame frame))
1233 (vars (frame-debug-vars frame))
1234 (loc (sb-di:frame-code-location frame))
1235 (dvar (if (= var (length vars))
1236 ;; If VAR is out of bounds, it must be the fake var we made up for
1237 ;; &MORE.
1238 (let* ((context-var (find :more-context vars :key #'debug-var-info))
1239 (more-context (debug-var-value context-var frame loc))
1240 (count-var (find :more-count vars :key #'debug-var-info))
1241 (more-count (debug-var-value count-var frame loc)))
1242 (return-from frame-var-value
1243 (multiple-value-list (sb-c:%more-arg-values more-context
1244 0 more-count))))
1245 (aref vars var))))
1246 (debug-var-value dvar frame loc)))
1247
1248 (defimplementation frame-catch-tags (index)
1249 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1250
1251 (defimplementation eval-in-frame (form index)
1252 (let ((frame (nth-frame index)))
1253 (funcall (the function
1254 (sb-di:preprocess-for-eval form
1255 (sb-di:frame-code-location frame)))
1256 frame)))
1257
1258 #+#.(swank-backend::sbcl-with-restart-frame)
1259 (progn
1260 (defimplementation return-from-frame (index form)
1261 (let* ((frame (nth-frame index)))
1262 (cond ((sb-debug:frame-has-debug-tag-p frame)
1263 (let ((values (multiple-value-list (eval-in-frame form index))))
1264 (sb-debug:unwind-to-frame-and-call frame
1265 (lambda ()
1266 (values-list values)))))
1267 (t (format nil "Cannot return from frame: ~S" frame)))))
1268
1269 (defimplementation restart-frame (index)
1270 (let* ((frame (nth-frame index)))
1271 (cond ((sb-debug:frame-has-debug-tag-p frame)
1272 (let* ((call-list (sb-debug::frame-call-as-list frame))
1273 (fun (fdefinition (car call-list)))
1274 (thunk (lambda ()
1275 ;; Ensure that the thunk gets tail-call-optimized
1276 (declare (optimize (debug 1)))
1277 (apply fun (cdr call-list)))))
1278 (sb-debug:unwind-to-frame-and-call frame thunk)))
1279 (t (format nil "Cannot restart frame: ~S" frame))))))
1280
1281 ;; FIXME: this implementation doesn't unwind the stack before
1282 ;; re-invoking the function, but it's better than no implementation at
1283 ;; all.
1284 #-#.(swank-backend::sbcl-with-restart-frame)
1285 (progn
1286 (defun sb-debug-catch-tag-p (tag)
1287 (and (symbolp tag)
1288 (not (symbol-package tag))
1289 (string= tag :sb-debug-catch-tag)))
1290
1291 (defimplementation return-from-frame (index form)
1292 (let* ((frame (nth-frame index))
1293 (probe (assoc-if #'sb-debug-catch-tag-p
1294 (sb-di::frame-catches frame))))
1295 (cond (probe (throw (car probe) (eval-in-frame form index)))
1296 (t (format nil "Cannot return from frame: ~S" frame)))))
1297
1298 (defimplementation restart-frame (index)
1299 (let ((frame (nth-frame index)))
1300 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1301
1302 ;;;;; reference-conditions
1303
1304 (defimplementation format-sldb-condition (condition)
1305 (let ((sb-int:*print-condition-references* nil))
1306 (princ-to-string condition)))
1307
1308
1309 ;;;; Profiling
1310
1311 (defimplementation profile (fname)
1312 (when fname (eval `(sb-profile:profile ,fname))))
1313
1314 (defimplementation unprofile (fname)
1315 (when fname (eval `(sb-profile:unprofile ,fname))))
1316
1317 (defimplementation unprofile-all ()
1318 (sb-profile:unprofile)
1319 "All functions unprofiled.")
1320
1321 (defimplementation profile-report ()
1322 (sb-profile:report))
1323
1324 (defimplementation profile-reset ()
1325 (sb-profile:reset)
1326 "Reset profiling counters.")
1327
1328 (defimplementation profiled-functions ()
1329 (sb-profile:profile))
1330
1331 (defimplementation profile-package (package callers methods)
1332 (declare (ignore callers methods))
1333 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1334
1335
1336 ;;;; Inspector
1337
1338 (defmethod emacs-inspect ((o t))
1339 (cond ((sb-di::indirect-value-cell-p o)
1340 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1341 (t
1342 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1343 (list* (string-right-trim '(#\Newline) text)
1344 '(:newline)
1345 (if label
1346 (loop for (l . v) in parts
1347 append (label-value-line l v))
1348 (loop for value in parts
1349 for i from 0
1350 append (label-value-line i value))))))))
1351
1352 (defmethod emacs-inspect ((o function))
1353 (let ((header (sb-kernel:widetag-of o)))
1354 (cond ((= header sb-vm:simple-fun-header-widetag)
1355 (label-value-line*
1356 (:name (sb-kernel:%simple-fun-name o))
1357 (:arglist (sb-kernel:%simple-fun-arglist o))
1358 (:self (sb-kernel:%simple-fun-self o))
1359 (:next (sb-kernel:%simple-fun-next o))
1360 (:type (sb-kernel:%simple-fun-type o))
1361 (:code (sb-kernel:fun-code-header o))))
1362 ((= header sb-vm:closure-header-widetag)
1363 (append
1364 (label-value-line :function (sb-kernel:%closure-fun o))
1365 `("Closed over values:" (:newline))
1366 (loop for i below (1- (sb-kernel:get-closure-length o))
1367 append (label-value-line
1368 i (sb-kernel:%closure-index-ref o i)))))
1369 (t (call-next-method o)))))
1370
1371 (defmethod emacs-inspect ((o sb-kernel:code-component))
1372 (append
1373 (label-value-line*
1374 (:code-size (sb-kernel:%code-code-size o))
1375 (:entry-points (sb-kernel:%code-entry-points o))
1376 (:debug-info (sb-kernel:%code-debug-info o))
1377 (:trace-table-offset (sb-kernel:code-header-ref
1378 o sb-vm:code-trace-table-offset-slot)))
1379 `("Constants:" (:newline))
1380 (loop for i from sb-vm:code-constants-offset
1381 below (sb-kernel:get-header-data o)
1382 append (label-value-line i (sb-kernel:code-header-ref o i)))
1383 `("Code:" (:newline)
1384 , (with-output-to-string (s)
1385 (cond ((sb-kernel:%code-debug-info o)
1386 (sb-disassem:disassemble-code-component o :stream s))
1387 (t
1388 (sb-disassem:disassemble-memory
1389 (sb-disassem::align
1390 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1391 sb-vm:lowtag-mask)
1392 (* sb-vm:code-constants-offset
1393 sb-vm:n-word-bytes))
1394 (ash 1 sb-vm:n-lowtag-bits))
1395 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1396 :stream s)))))))
1397
1398 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1399 (label-value-line*
1400 (:value (sb-ext:weak-pointer-value o))))
1401
1402 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1403 (label-value-line*
1404 (:name (sb-kernel:fdefn-name o))
1405 (:function (sb-kernel:fdefn-fun o))))
1406
1407 (defmethod emacs-inspect :around ((o generic-function))
1408 (append
1409 (call-next-method)
1410 (label-value-line*
1411 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1412 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1413 )))
1414
1415
1416 ;;;; Multiprocessing
1417
1418 #+(and sb-thread
1419 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1420 (progn
1421 (defvar *thread-id-counter* 0)
1422
1423 (defvar *thread-id-counter-lock*
1424 (sb-thread:make-mutex :name "thread id counter lock"))
1425
1426 (defun next-thread-id ()
1427 (sb-thread:with-mutex (*thread-id-counter-lock*)
1428 (incf *thread-id-counter*)))
1429
1430 (defparameter *thread-id-map* (make-hash-table))
1431
1432 ;; This should be a thread -> id map but as weak keys are not
1433 ;; supported it is id -> map instead.
1434 (defvar *thread-id-map-lock*
1435 (sb-thread:make-mutex :name "thread id map lock"))
1436
1437 (defimplementation spawn (fn &key name)
1438 (sb-thread:make-thread fn :name name))
1439
1440 (defimplementation thread-id (thread)
1441 (block thread-id
1442 (sb-thread:with-mutex (*thread-id-map-lock*)
1443 (loop for id being the hash-key in *thread-id-map*
1444 using (hash-value thread-pointer)
1445 do
1446 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1447 (cond ((null maybe-thread)
1448 ;; the value is gc'd, remove it manually
1449 (remhash id *thread-id-map*))
1450 ((eq thread maybe-thread)
1451 (return-from thread-id id)))))
1452 ;; lazy numbering
1453 (let ((id (next-thread-id)))
1454 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1455 id))))
1456
1457 (defimplementation find-thread (id)
1458 (sb-thread:with-mutex (*thread-id-map-lock*)
1459 (let ((thread-pointer (gethash id *thread-id-map*)))
1460 (if thread-pointer
1461 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1462 (if maybe-thread
1463 maybe-thread
1464 ;; the value is gc'd, remove it manually
1465 (progn
1466 (remhash id *thread-id-map*)
1467 nil)))
1468 nil))))
1469
1470 (defimplementation thread-name (thread)
1471 ;; sometimes the name is not a string (e.g. NIL)
1472 (princ-to-string (sb-thread:thread-name thread)))
1473
1474 (defimplementation thread-status (thread)
1475 (if (sb-thread:thread-alive-p thread)
1476 "Running"
1477 "Stopped"))
1478
1479 (defimplementation make-lock (&key name)
1480 (sb-thread:make-mutex :name name))
1481
1482 (defimplementation call-with-lock-held (lock function)
1483 (declare (type function function))
1484 (sb-thread:with-recursive-lock (lock) (funcall function)))
1485
1486 (defimplementation current-thread ()
1487 sb-thread:*current-thread*)
1488
1489 (defimplementation all-threads ()
1490 (sb-thread:list-all-threads))
1491
1492 (defimplementation interrupt-thread (thread fn)
1493 (sb-thread:interrupt-thread thread fn))
1494
1495 (defimplementation kill-thread (thread)
1496 (sb-thread:terminate-thread thread))
1497
1498 (defimplementation thread-alive-p (thread)
1499 (sb-thread:thread-alive-p thread))
1500
1501 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1502 (defvar *mailboxes* (list))
1503 (declaim (type list *mailboxes*))
1504
1505 (defstruct (mailbox (:conc-name mailbox.))
1506 thread
1507 (mutex (sb-thread:make-mutex))
1508 (waitqueue (sb-thread:make-waitqueue))
1509 (queue '() :type list))
1510
1511 (defun mailbox (thread)
1512 "Return THREAD's mailbox."
1513 (sb-thread:with-mutex (*mailbox-lock*)
1514 (or (find thread *mailboxes* :key #'mailbox.thread)
1515 (let ((mb (make-mailbox :thread thread)))
1516 (push mb *mailboxes*)
1517 mb))))
1518
1519 (defimplementation send (thread message)
1520 (let* ((mbox (mailbox thread))
1521 (mutex (mailbox.mutex mbox)))
1522 (sb-thread:with-mutex (mutex)
1523 (setf (mailbox.queue mbox)
1524 (nconc (mailbox.queue mbox) (list message)))
1525 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1526 #-sb-lutex
1527 (defun condition-timed-wait (waitqueue mutex timeout)
1528 (handler-case
1529 (let ((*break-on-signals* nil))
1530 (sb-sys:with-deadline (:seconds timeout :override t)
1531 (sb-thread:condition-wait waitqueue mutex) t))
1532 (sb-ext:timeout ()
1533 nil)))
1534
1535 ;; FIXME: with-timeout doesn't work properly on Darwin
1536 #+sb-lutex
1537 (defun condition-timed-wait (waitqueue mutex timeout)
1538 (declare (ignore timeout))
1539 (sb-thread:condition-wait waitqueue mutex))
1540
1541 (defimplementation receive-if (test &optional timeout)
1542 (let* ((mbox (mailbox (current-thread)))
1543 (mutex (mailbox.mutex mbox))
1544 (waitq (mailbox.waitqueue mbox)))
1545 (assert (or (not timeout) (eq timeout t)))
1546 (loop
1547 (check-slime-interrupts)
1548 (sb-thread:with-mutex (mutex)
1549 (let* ((q (mailbox.queue mbox))
1550 (tail (member-if test q)))
1551 (when tail
1552 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1553 (return (car tail))))
1554 (when (eq timeout t) (return (values nil t)))
1555 (condition-timed-wait waitq mutex 0.2)))))
1556 )
1557
1558 (defimplementation quit-lisp ()
1559 #+sb-thread
1560 (dolist (thread (remove (current-thread) (all-threads)))
1561 (ignore-errors (sb-thread:terminate-thread thread)))
1562 (sb-ext:quit))
1563
1564
1565
1566 ;;Trace implementations
1567 ;;In SBCL, we have:
1568 ;; (trace <name>)
1569 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1570 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1571 ;; <name> can be a normal name or a (setf name)
1572
1573 (defun toggle-trace-aux (fspec &rest args)
1574 (cond ((member fspec (eval '(trace)) :test #'equal)
1575 (eval `(untrace ,fspec))
1576 (format nil "~S is now untraced." fspec))
1577 (t
1578 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1579 (format nil "~S is now traced." fspec))))
1580
1581 (defun process-fspec (fspec)
1582 (cond ((consp fspec)
1583 (ecase (first fspec)
1584 ((:defun :defgeneric) (second fspec))
1585 ((:defmethod) `(method ,@(rest fspec)))
1586 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1587 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1588 (t
1589 fspec)))
1590
1591 (defimplementation toggle-trace (spec)
1592 (ecase (car spec)
1593 ((setf)
1594 (toggle-trace-aux spec))
1595 ((:defmethod)
1596 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1597 ((:defgeneric)
1598 (toggle-trace-aux (second spec) :methods t))
1599 ((:call)
1600 (destructuring-bind (caller callee) (cdr spec)
1601 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1602
1603 ;;; Weak datastructures
1604
1605 (defimplementation make-weak-key-hash-table (&rest args)
1606 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1607 (apply #'make-hash-table :weakness :key args)
1608 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1609 (apply #'make-hash-table args))
1610
1611 (defimplementation make-weak-value-hash-table (&rest args)
1612 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1613 (apply #'make-hash-table :weakness :value args)
1614 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1615 (apply #'make-hash-table args))
1616
1617 (defimplementation hash-table-weakness (hashtable)
1618 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1619 (sb-ext:hash-table-weakness hashtable))
1620
1621 #-win32
1622 (defimplementation save-image (filename &optional restart-function)
1623 (flet ((restart-sbcl ()
1624 (sb-debug::enable-debugger)
1625 (setf sb-impl::*descriptor-handlers* nil)
1626 (funcall restart-function)))
1627 (let ((pid (sb-posix:fork)))
1628 (cond ((= pid 0)
1629 (sb-debug::disable-debugger)
1630 (apply #'sb-ext:save-lisp-and-die filename
1631 (when restart-function
1632 (list :toplevel #'restart-sbcl))))
1633 (t
1634 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1635 (assert (= pid rpid))
1636 (assert (and (sb-posix:wifexited status)
1637 (zerop (sb-posix:wexitstatus status))))))))))
1638
1639 #+unix
1640 (progn
1641 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1642 (program sb-alien:c-string)
1643 (argv (* sb-alien:c-string)))
1644
1645 (defun execv (program args)
1646 "Replace current executable with another one."
1647 (let ((a-args (sb-alien:make-alien sb-alien:c-string
1648 (+ 1 (length args)))))
1649 (unwind-protect
1650 (progn
1651 (loop for index from 0 by 1
1652 and item in (append args '(nil))
1653 do (setf (sb-alien:deref a-args index)
1654 item))
1655 (when (minusp
1656 (sys-execv program a-args))
1657 (error "execv(3) returned.")))
1658 (sb-alien:free-alien a-args))))
1659
1660 (defun runtime-pathname ()
1661 #+#.(swank-backend:with-symbol
1662 '*runtime-pathname* 'sb-ext)
1663 sb-ext:*runtime-pathname*
1664 #-#.(swank-backend:with-symbol
1665 '*runtime-pathname* 'sb-ext)
1666 (car sb-ext:*posix-argv*))
1667
1668 (defimplementation exec-image (image-file args)
1669 (loop with fd-arg =
1670 (loop for arg in args
1671 and key = "" then arg
1672 when (string-equal key "--swank-fd")
1673 return (parse-integer arg))
1674 for my-fd from 3 to 1024
1675 when (/= my-fd fd-arg)
1676 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1677 (let* ((self-string (pathname-to-filename (runtime-pathname))))
1678 (execv
1679 self-string
1680 (apply 'list self-string "--core" image-file args)))))
1681
1682 (defimplementation make-fd-stream (fd external-format)
1683 (sb-sys:make-fd-stream fd :input t :output t
1684 :element-type 'character
1685 :buffering :full
1686 :dual-channel-p t
1687 :external-format external-format))
1688
1689 (defimplementation call-with-io-timeout (function &key seconds)
1690 (handler-case
1691 (sb-sys:with-deadline (:seconds seconds)
1692 (funcall function))
1693 (sb-sys:deadline-timeout ()
1694 nil)))
1695
1696 #-win32
1697 (defimplementation background-save-image (filename &key restart-function
1698 completion-function)
1699 (flet ((restart-sbcl ()
1700 (sb-debug::enable-debugger)
1701 (setf sb-impl::*descriptor-handlers* nil)
1702 (funcall restart-function)))
1703 (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1704 (let ((pid (sb-posix:fork)))
1705 (cond ((= pid 0)
1706 (sb-posix:close pipe-in)
1707 (sb-debug::disable-debugger)
1708 (apply #'sb-ext:save-lisp-and-die filename
1709 (when restart-function
1710 (list :toplevel #'restart-sbcl))))
1711 (t
1712 (sb-posix:close pipe-out)
1713 (sb-sys:add-fd-handler
1714 pipe-in :input
1715 (lambda (fd)
1716 (sb-sys:invalidate-descriptor fd)
1717 (sb-posix:close fd)
1718 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1719 (assert (= pid rpid))
1720 (assert (sb-posix:wifexited status))
1721 (funcall completion-function
1722 (zerop (sb-posix:wexitstatus status))))))))))))
1723
1724 (defun deinit-log-output ()
1725 ;; Can't hang on to an fd-stream from a previous session.
1726 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1727 nil))
1728
1729 (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5