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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.304 - (show annotations)
Fri Mar 30 09:45:00 2012 UTC (2 years ago) by nsiivola
Branch: MAIN
Changes since 1.303: +7 -1 lines
sbcl: make STEP friendlier when SBCL gives the source form for the initial form

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

  ViewVC Help
Powered by ViewVC 1.1.5