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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.299 - (show annotations)
Sat Dec 3 19:47:45 2011 UTC (2 years, 4 months ago) by nsiivola
Branch: MAIN
Changes since 1.298: +1 -1 lines
sbcl: fix INPUT-READY-P

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

  ViewVC Help
Powered by ViewVC 1.1.5