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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.287 - (show annotations)
Tue Aug 9 10:35:00 2011 UTC (2 years, 8 months ago) by nsiivola
Branch: MAIN
Changes since 1.286: +4 -1 lines
sbcl: oops, can't intern SWANK*COMMUNICATION-STYLE* when loading the backend

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

  ViewVC Help
Powered by ViewVC 1.1.5