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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5