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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.189 - (show annotations)
Mon Feb 4 17:41:22 2008 UTC (6 years, 2 months ago) by mbaringer
Branch: MAIN
Changes since 1.188: +0 -6 lines
drop sbcl inspector defclass
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 'asdf)
18 (require 'sb-bsd-sockets)
19 (require 'sb-introspect)
20 (require 'sb-posix)
21 (require 'sb-cltl2))
22
23 (declaim (optimize (debug 2) (sb-c:insert-step-conditions 0)))
24
25 (import-from :sb-gray *gray-stream-symbols* :swank-backend)
26
27 ;;; backwards compability tests
28
29 (eval-when (:compile-toplevel :load-toplevel :execute)
30 ;; Generate a form suitable for testing for stepper support (0.9.17)
31 ;; with #+.
32 (defun sbcl-with-new-stepper-p ()
33 (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
34 '(:and)
35 '(:or)))
36 ;; Ditto for weak hash-tables
37 (defun sbcl-with-weak-hash-tables ()
38 (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
39 '(:and)
40 '(:or)))
41 ;; And for xref support (1.0.1)
42 (defun sbcl-with-xref-p ()
43 (if (find-symbol "WHO-CALLS" "SB-INTROSPECT")
44 '(:and)
45 '(:or)))
46 ;; ... for restart-frame support (1.0.2)
47 (defun sbcl-with-restart-frame ()
48 (if (find-symbol "FRAME-HAS-DEBUG-TAG-P" "SB-DEBUG")
49 '(:and)
50 '(:or))))
51
52 ;;; swank-mop
53
54 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
55
56 (defun swank-mop:slot-definition-documentation (slot)
57 (sb-pcl::documentation slot t))
58
59 ;;; TCP Server
60
61 (defimplementation preferred-communication-style ()
62 (cond
63 ;; fixme: when SBCL/win32 gains better select() support, remove
64 ;; this.
65 ((member :win32 *features*) nil)
66 ((member :sb-thread *features*) :spawn)
67 (t :fd-handler)))
68
69 (defun resolve-hostname (name)
70 (car (sb-bsd-sockets:host-ent-addresses
71 (sb-bsd-sockets:get-host-by-name name))))
72
73 (defimplementation create-socket (host port)
74 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
75 :type :stream
76 :protocol :tcp)))
77 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
78 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
79 (sb-bsd-sockets:socket-listen socket 5)
80 socket))
81
82 (defimplementation local-port (socket)
83 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
84
85 (defimplementation close-socket (socket)
86 (sb-sys:invalidate-descriptor (socket-fd socket))
87 (sb-bsd-sockets:socket-close socket))
88
89 (defimplementation accept-connection (socket &key
90 external-format
91 buffering timeout)
92 (declare (ignore timeout))
93 (make-socket-io-stream (accept socket)
94 (or external-format :iso-latin-1-unix)
95 (or buffering :full)))
96
97 (defvar *sigio-handlers* '()
98 "List of (key . fn) pairs to be called on SIGIO.")
99
100 (defun sigio-handler (signal code scp)
101 (declare (ignore signal code scp))
102 (mapc (lambda (handler)
103 (funcall (the function (cdr handler))))
104 *sigio-handlers*))
105
106 (defun set-sigio-handler ()
107 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
108 (sigio-handler signal code scp))))
109
110 (defun enable-sigio-on-fd (fd)
111 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
112 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
113
114 (defimplementation add-sigio-handler (socket fn)
115 (set-sigio-handler)
116 (let ((fd (socket-fd socket)))
117 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
118 (enable-sigio-on-fd fd)
119 (push (cons fd fn) *sigio-handlers*)))
120
121 (defimplementation remove-sigio-handlers (socket)
122 (let ((fd (socket-fd socket)))
123 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
124 (sb-sys:invalidate-descriptor fd))
125 (close socket))
126
127 (defimplementation add-fd-handler (socket fn)
128 (declare (type function fn))
129 (let ((fd (socket-fd socket)))
130 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
131 (sb-sys:add-fd-handler fd :input (lambda (_)
132 _
133 (funcall fn)))))
134
135 (defimplementation remove-fd-handlers (socket)
136 (sb-sys:invalidate-descriptor (socket-fd socket)))
137
138 (defun socket-fd (socket)
139 (etypecase socket
140 (fixnum socket)
141 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
142 (file-stream (sb-sys:fd-stream-fd socket))))
143
144 (defvar *external-format-to-coding-system*
145 '((:iso-8859-1
146 "latin-1" "latin-1-unix" "iso-latin-1-unix"
147 "iso-8859-1" "iso-8859-1-unix")
148 (:utf-8 "utf-8" "utf-8-unix")
149 (:euc-jp "euc-jp" "euc-jp-unix")
150 (:us-ascii "us-ascii" "us-ascii-unix")))
151
152 (defimplementation find-external-format (coding-system)
153 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
154 *external-format-to-coding-system*)))
155
156 (defun make-socket-io-stream (socket external-format buffering)
157 (sb-bsd-sockets:socket-make-stream socket
158 :output t
159 :input t
160 :element-type 'character
161 :buffering buffering
162 #+sb-unicode :external-format
163 #+sb-unicode external-format
164 ))
165
166 (defun accept (socket)
167 "Like socket-accept, but retry on EAGAIN."
168 (loop (handler-case
169 (return (sb-bsd-sockets:socket-accept socket))
170 (sb-bsd-sockets:interrupted-error ()))))
171
172 (defimplementation call-without-interrupts (fn)
173 (declare (type function fn))
174 (sb-sys:without-interrupts (funcall fn)))
175
176 (defimplementation getpid ()
177 (sb-posix:getpid))
178
179 (defimplementation lisp-implementation-type-name ()
180 "sbcl")
181
182
183 ;;;; Support for SBCL syntax
184
185 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
186 ;;; containing `!' have special meaning. We have to work long and
187 ;;; hard to be able to read the source. To deal with #! reader
188 ;;; macros, we use a special readtable. The special symbols are
189 ;;; converted by a condition handler.
190
191 (defun feature-in-list-p (feature list)
192 (etypecase feature
193 (symbol (member feature list :test #'eq))
194 (cons (flet ((subfeature-in-list-p (subfeature)
195 (feature-in-list-p subfeature list)))
196 (ecase (first feature)
197 (:or (some #'subfeature-in-list-p (rest feature)))
198 (:and (every #'subfeature-in-list-p (rest feature)))
199 (:not (destructuring-bind (e) (cdr feature)
200 (not (subfeature-in-list-p e)))))))))
201
202 (defun shebang-reader (stream sub-character infix-parameter)
203 (declare (ignore sub-character))
204 (when infix-parameter
205 (error "illegal read syntax: #~D!" infix-parameter))
206 (let ((next-char (read-char stream)))
207 (unless (find next-char "+-")
208 (error "illegal read syntax: #!~C" next-char))
209 ;; When test is not satisfied
210 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
211 ;; would become "unless test is satisfied"..
212 (when (let* ((*package* (find-package "KEYWORD"))
213 (*read-suppress* nil)
214 (not-p (char= next-char #\-))
215 (feature (read stream)))
216 (if (feature-in-list-p feature *features*)
217 not-p
218 (not not-p)))
219 ;; Read (and discard) a form from input.
220 (let ((*read-suppress* t))
221 (read stream t nil t))))
222 (values))
223
224 (defvar *shebang-readtable*
225 (let ((*readtable* (copy-readtable nil)))
226 (set-dispatch-macro-character #\# #\!
227 (lambda (s c n) (shebang-reader s c n))
228 *readtable*)
229 *readtable*))
230
231 (defun shebang-readtable ()
232 *shebang-readtable*)
233
234 (defun sbcl-package-p (package)
235 (let ((name (package-name package)))
236 (eql (mismatch "SB-" name) 3)))
237
238 (defun sbcl-source-file-p (filename)
239 (when filename
240 (loop for (_ pattern) in (logical-pathname-translations "SYS")
241 thereis (pathname-match-p filename pattern))))
242
243 (defun guess-readtable-for-filename (filename)
244 (if (sbcl-source-file-p filename)
245 (shebang-readtable)
246 *readtable*))
247
248 (defvar *debootstrap-packages* t)
249
250 (defun call-with-debootstrapping (fun)
251 (handler-bind ((sb-int:bootstrap-package-not-found
252 #'sb-int:debootstrap-package))
253 (funcall fun)))
254
255 (defmacro with-debootstrapping (&body body)
256 `(call-with-debootstrapping (lambda () ,@body)))
257
258 (defimplementation call-with-syntax-hooks (fn)
259 (cond ((and *debootstrap-packages*
260 (sbcl-package-p *package*))
261 (with-debootstrapping (funcall fn)))
262 (t
263 (funcall fn))))
264
265 (defimplementation default-readtable-alist ()
266 (let ((readtable (shebang-readtable)))
267 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
268 collect (cons (package-name p) readtable))))
269
270 ;;; Utilities
271
272 (defimplementation arglist (fname)
273 (sb-introspect:function-arglist fname))
274
275 (defimplementation function-name (f)
276 (check-type f function)
277 (sb-impl::%fun-name f))
278
279 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
280 (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
281 (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
282 (if flags
283 ;; Symbols aren't printed with package qualifiers, but the FLAGS would
284 ;; have to be fully qualified when used inside a declaration. So we
285 ;; strip those as long as there's no better way. (FIXME)
286 `(&any ,@(remove-if-not #'(lambda (qualifier)
287 (find-symbol (symbol-name (first qualifier)) :cl))
288 flags :key #'ensure-list))
289 (call-next-method)))))
290
291 (defvar *buffer-name* nil)
292 (defvar *buffer-offset*)
293 (defvar *buffer-substring* nil)
294
295 (defvar *previous-compiler-condition* nil
296 "Used to detect duplicates.")
297
298 (defun handle-notification-condition (condition)
299 "Handle a condition caused by a compiler warning.
300 This traps all compiler conditions at a lower-level than using
301 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
302 craft our own error messages, which can omit a lot of redundant
303 information."
304 (let ((context (sb-c::find-error-context nil)))
305 (unless (eq condition *previous-compiler-condition*)
306 (setq *previous-compiler-condition* condition)
307 (signal-compiler-condition condition context))))
308
309 (defun signal-compiler-condition (condition context)
310 (signal (make-condition
311 'compiler-condition
312 :original-condition condition
313 :severity (etypecase condition
314 (sb-c:compiler-error :error)
315 (sb-ext:compiler-note :note)
316 (style-warning :style-warning)
317 (warning :warning)
318 (error :error))
319 :short-message (brief-compiler-message-for-emacs condition)
320 :references (condition-references (real-condition condition))
321 :message (long-compiler-message-for-emacs condition context)
322 :location (compiler-note-location context))))
323
324 (defun real-condition (condition)
325 "Return the encapsulated condition or CONDITION itself."
326 (typecase condition
327 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
328 (t condition)))
329
330 (defun condition-references (condition)
331 (if (typep condition 'sb-int:reference-condition)
332 (externalize-reference
333 (sb-int:reference-condition-references condition))))
334
335 (defun compiler-note-location (context)
336 (if context
337 (locate-compiler-note
338 (sb-c::compiler-error-context-file-name context)
339 (compiler-source-path context)
340 (sb-c::compiler-error-context-original-source context))
341 (list :error "No error location available")))
342
343 (defun locate-compiler-note (file source-path source)
344 (cond ((and (not (eq file :lisp)) *buffer-name*)
345 ;; Compiling from a buffer
346 (let ((position (+ *buffer-offset*
347 (source-path-string-position
348 source-path *buffer-substring*))))
349 (make-location (list :buffer *buffer-name*)
350 (list :position position))))
351 ((and (pathnamep file) (null *buffer-name*))
352 ;; Compiling from a file
353 (make-location (list :file (namestring file))
354 (list :position
355 (1+ (source-path-file-position
356 source-path file)))))
357 ((and (eq file :lisp) (stringp source))
358 ;; Compiling macro generated code
359 (make-location (list :source-form source)
360 (list :position 1)))
361 (t
362 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
363
364 (defun brief-compiler-message-for-emacs (condition)
365 "Briefly describe a compiler error for Emacs.
366 When Emacs presents the message it already has the source popped up
367 and the source form highlighted. This makes much of the information in
368 the error-context redundant."
369 (let ((sb-int:*print-condition-references* nil))
370 (princ-to-string condition)))
371
372 (defun long-compiler-message-for-emacs (condition error-context)
373 "Describe a compiler error for Emacs including context information."
374 (declare (type (or sb-c::compiler-error-context null) error-context))
375 (multiple-value-bind (enclosing source)
376 (if error-context
377 (values (sb-c::compiler-error-context-enclosing-source error-context)
378 (sb-c::compiler-error-context-source error-context)))
379 (let ((sb-int:*print-condition-references* nil))
380 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
381 enclosing source condition))))
382
383 (defun compiler-source-path (context)
384 "Return the source-path for the current compiler error.
385 Returns NIL if this cannot be determined by examining internal
386 compiler state."
387 (cond ((sb-c::node-p context)
388 (reverse
389 (sb-c::source-path-original-source
390 (sb-c::node-source-path context))))
391 ((sb-c::compiler-error-context-p context)
392 (reverse
393 (sb-c::compiler-error-context-original-source-path context)))))
394
395 (defimplementation call-with-compilation-hooks (function)
396 (declare (type function function))
397 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
398 (sb-c:compiler-error #'handle-notification-condition)
399 (sb-ext:compiler-note #'handle-notification-condition)
400 (style-warning #'handle-notification-condition)
401 (warning #'handle-notification-condition))
402 (funcall function)))
403
404 (defun handle-file-compiler-termination (condition)
405 "Handle a condition that caused the file compiler to terminate."
406 (handle-notification-condition
407 (sb-int:encapsulated-condition condition)))
408
409 (defvar *trap-load-time-warnings* nil)
410
411 (defimplementation swank-compile-file (filename load-p external-format)
412 (handler-case
413 (let ((output-file (with-compilation-hooks ()
414 (compile-file filename
415 :external-format external-format))))
416 (when output-file
417 ;; Cache the latest source file for definition-finding.
418 (source-cache-get filename (file-write-date filename))
419 (when load-p
420 (load output-file))))
421 (sb-c:fatal-compiler-error () nil)))
422
423 ;;;; compile-string
424
425 ;;; We copy the string to a temporary file in order to get adequate
426 ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
427 ;;; which the previous approach using
428 ;;; (compile nil `(lambda () ,(read-from-string string)))
429 ;;; did not provide.
430
431 (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
432 (dest (* sb-alien:c-string)))
433
434 (defun temp-file-name ()
435 "Return a temporary file name to compile strings into."
436 (concatenate 'string (tmpnam nil) ".lisp"))
437
438 (defimplementation swank-compile-string (string &key buffer position directory)
439 (let ((*buffer-name* buffer)
440 (*buffer-offset* position)
441 (*buffer-substring* string)
442 (filename (temp-file-name)))
443 (flet ((compile-it (fn)
444 (with-compilation-hooks ()
445 (with-compilation-unit
446 (:source-plist (list :emacs-buffer buffer
447 :emacs-directory directory
448 :emacs-string string
449 :emacs-position position))
450 (funcall fn (compile-file filename))))))
451 (with-open-file (s filename :direction :output :if-exists :error)
452 (write-string string s))
453 (unwind-protect
454 (if *trap-load-time-warnings*
455 (compile-it #'load)
456 (load (compile-it #'identity)))
457 (ignore-errors
458 (delete-file filename)
459 (delete-file (compile-file-pathname filename)))))))
460
461 ;;;; Definitions
462
463 (defvar *debug-definition-finding* nil
464 "When true don't handle errors while looking for definitions.
465 This is useful when debugging the definition-finding code.")
466
467 (defparameter *definition-types*
468 '(:variable defvar
469 :constant defconstant
470 :type deftype
471 :symbol-macro define-symbol-macro
472 :macro defmacro
473 :compiler-macro define-compiler-macro
474 :function defun
475 :generic-function defgeneric
476 :method defmethod
477 :setf-expander define-setf-expander
478 :structure defstruct
479 :condition define-condition
480 :class defclass
481 :method-combination define-method-combination
482 :package defpackage
483 :transform :deftransform
484 :optimizer :defoptimizer
485 :vop :define-vop
486 :source-transform :define-source-transform)
487 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
488
489 (defimplementation find-definitions (name)
490 (loop for type in *definition-types* by #'cddr
491 for locations = (sb-introspect:find-definition-sources-by-name
492 name type)
493 append (loop for source-location in locations collect
494 (make-source-location-specification type name
495 source-location))))
496
497 (defun make-source-location-specification (type name source-location)
498 (list (list* (getf *definition-types* type)
499 name
500 (sb-introspect::definition-source-description source-location))
501 (if *debug-definition-finding*
502 (make-definition-source-location source-location type name)
503 (handler-case
504 (make-definition-source-location source-location type name)
505 (error (e)
506 (list :error (format nil "Error: ~A" e)))))))
507
508 (defun make-definition-source-location (definition-source type name)
509 (with-struct (sb-introspect::definition-source-
510 pathname form-path character-offset plist
511 file-write-date)
512 definition-source
513 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
514 emacs-string &allow-other-keys)
515 plist
516 (cond
517 (emacs-buffer
518 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
519 (pos (if form-path
520 (with-debootstrapping
521 (source-path-string-position form-path emacs-string))
522 character-offset))
523 (snippet (string-path-snippet emacs-string form-path pos)))
524 (make-location `(:buffer ,emacs-buffer)
525 `(:position ,(+ pos emacs-position))
526 `(:snippet ,snippet))))
527 ((not pathname)
528 `(:error ,(format nil "Source of ~A ~A not found"
529 (string-downcase type) name)))
530 (t
531 (let* ((namestring (namestring (translate-logical-pathname pathname)))
532 (pos (source-file-position namestring file-write-date form-path
533 character-offset))
534 (snippet (source-hint-snippet namestring file-write-date pos)))
535 (make-location `(:file ,namestring)
536 `(:position ,pos)
537 `(:snippet ,snippet))))))))
538
539 (defun string-path-snippet (string form-path position)
540 (if form-path
541 ;; If we have a form-path, use it to derive a more accurate
542 ;; snippet, so that we can point to the individual form rather
543 ;; than just the toplevel form.
544 (multiple-value-bind (data end)
545 (let ((*read-suppress* t))
546 (read-from-string string nil nil :start position))
547 (declare (ignore data))
548 (subseq string position end))
549 string))
550
551 (defun source-file-position (filename write-date form-path character-offset)
552 (let ((source (get-source-code filename write-date))
553 (*readtable* (guess-readtable-for-filename filename)))
554 (1+ (with-debootstrapping
555 (if form-path
556 (source-path-string-position form-path source)
557 (or character-offset 0))))))
558
559 (defun source-hint-snippet (filename write-date position)
560 (let ((source (get-source-code filename write-date)))
561 (with-input-from-string (s source)
562 (read-snippet s position))))
563
564 (defun function-source-location (function &optional name)
565 (declare (type function function))
566 (let ((location (sb-introspect:find-definition-source function)))
567 (make-definition-source-location location :function name)))
568
569 (defun safe-function-source-location (fun name)
570 (if *debug-definition-finding*
571 (function-source-location fun name)
572 (handler-case (function-source-location fun name)
573 (error (e)
574 (list :error (format nil "Error: ~A" e))))))
575
576 (defimplementation describe-symbol-for-emacs (symbol)
577 "Return a plist describing SYMBOL.
578 Return NIL if the symbol is unbound."
579 (let ((result '()))
580 (flet ((doc (kind)
581 (or (documentation symbol kind) :not-documented))
582 (maybe-push (property value)
583 (when value
584 (setf result (list* property value result)))))
585 (maybe-push
586 :variable (multiple-value-bind (kind recorded-p)
587 (sb-int:info :variable :kind symbol)
588 (declare (ignore kind))
589 (if (or (boundp symbol) recorded-p)
590 (doc 'variable))))
591 (when (fboundp symbol)
592 (maybe-push
593 (cond ((macro-function symbol) :macro)
594 ((special-operator-p symbol) :special-operator)
595 ((typep (fdefinition symbol) 'generic-function)
596 :generic-function)
597 (t :function))
598 (doc 'function)))
599 (maybe-push
600 :setf (if (or (sb-int:info :setf :inverse symbol)
601 (sb-int:info :setf :expander symbol))
602 (doc 'setf)))
603 (maybe-push
604 :type (if (sb-int:info :type :kind symbol)
605 (doc 'type)))
606 result)))
607
608 (defimplementation describe-definition (symbol type)
609 (case type
610 (:variable
611 (describe symbol))
612 (:function
613 (describe (symbol-function symbol)))
614 (:setf
615 (describe (or (sb-int:info :setf :inverse symbol)
616 (sb-int:info :setf :expander symbol))))
617 (:class
618 (describe (find-class symbol)))
619 (:type
620 (describe (sb-kernel:values-specifier-type symbol)))))
621
622 #+#.(swank-backend::sbcl-with-xref-p)
623 (progn
624 (defmacro defxref (name)
625 `(defimplementation ,name (what)
626 (sanitize-xrefs
627 (mapcar #'source-location-for-xref-data
628 (,(find-symbol (symbol-name name) "SB-INTROSPECT")
629 what)))))
630 (defxref who-calls)
631 (defxref who-binds)
632 (defxref who-sets)
633 (defxref who-references)
634 (defxref who-macroexpands))
635
636 (defun source-location-for-xref-data (xref-data)
637 (let ((name (car xref-data))
638 (source-location (cdr xref-data)))
639 (list name
640 (handler-case (make-definition-source-location source-location
641 'function
642 name)
643 (error (e)
644 (list :error (format nil "Error: ~A" e)))))))
645
646 (defimplementation list-callers (symbol)
647 (let ((fn (fdefinition symbol)))
648 (sanitize-xrefs
649 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
650
651 (defimplementation list-callees (symbol)
652 (let ((fn (fdefinition symbol)))
653 (sanitize-xrefs
654 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
655
656 (defun sanitize-xrefs (xrefs)
657 (remove-duplicates
658 (remove-if (lambda (f)
659 (member f (ignored-xref-function-names)))
660 (loop for entry in xrefs
661 for name = (car entry)
662 collect (if (and (consp name)
663 (member (car name)
664 '(sb-pcl::fast-method
665 sb-pcl::slow-method
666 sb-pcl::method)))
667 (cons (cons 'defmethod (cdr name))
668 (cdr entry))
669 entry))
670 :key #'car)
671 :test (lambda (a b)
672 (and (eq (first a) (first b))
673 (equal (second a) (second b))))))
674
675 (defun ignored-xref-function-names ()
676 #-#.(swank-backend::sbcl-with-new-stepper-p)
677 '(nil sb-c::step-form sb-c::step-values)
678 #+#.(swank-backend::sbcl-with-new-stepper-p)
679 '(nil))
680
681 (defun function-dspec (fn)
682 "Describe where the function FN was defined.
683 Return a list of the form (NAME LOCATION)."
684 (let ((name (sb-kernel:%fun-name fn)))
685 (list name (safe-function-source-location fn name))))
686
687 ;;; macroexpansion
688
689 (defimplementation macroexpand-all (form)
690 (let ((sb-walker:*walk-form-expand-macros-p* t))
691 (sb-walker:walk-form form)))
692
693
694 ;;; Debugging
695
696 (defvar *sldb-stack-top*)
697
698 (defimplementation install-debugger-globally (function)
699 (setq sb-ext:*invoke-debugger-hook* function))
700
701 (defimplementation condition-extras (condition)
702 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
703 ((typep condition 'sb-impl::step-form-condition)
704 `((:show-frame-source 0)))
705 ((typep condition 'sb-int:reference-condition)
706 (let ((refs (sb-int:reference-condition-references condition)))
707 (if refs
708 `((:references ,(externalize-reference refs))))))))
709
710 (defun externalize-reference (ref)
711 (etypecase ref
712 (null nil)
713 (cons (cons (externalize-reference (car ref))
714 (externalize-reference (cdr ref))))
715 ((or string number) ref)
716 (symbol
717 (cond ((eq (symbol-package ref) (symbol-package :test))
718 ref)
719 (t (symbol-name ref))))))
720
721 (defimplementation call-with-debugging-environment (debugger-loop-fn)
722 (declare (type function debugger-loop-fn))
723 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
724 (sb-debug:*stack-top-hint* nil))
725 (handler-bind ((sb-di:debug-condition
726 (lambda (condition)
727 (signal (make-condition
728 'sldb-condition
729 :original-condition condition)))))
730 (funcall debugger-loop-fn))))
731
732 #+#.(swank-backend::sbcl-with-new-stepper-p)
733 (progn
734 (defimplementation activate-stepping (frame)
735 (declare (ignore frame))
736 (sb-impl::enable-stepping))
737 (defimplementation sldb-stepper-condition-p (condition)
738 (typep condition 'sb-ext:step-form-condition))
739 (defimplementation sldb-step-into ()
740 (invoke-restart 'sb-ext:step-into))
741 (defimplementation sldb-step-next ()
742 (invoke-restart 'sb-ext:step-next))
743 (defimplementation sldb-step-out ()
744 (invoke-restart 'sb-ext:step-out)))
745
746 (defimplementation call-with-debugger-hook (hook fun)
747 (let ((sb-ext:*invoke-debugger-hook* hook)
748 #+#.(swank-backend::sbcl-with-new-stepper-p)
749 (sb-ext:*stepper-hook*
750 (lambda (condition)
751 (typecase condition
752 (sb-ext:step-form-condition
753 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
754 (sb-impl::invoke-debugger condition)))))))
755 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
756 (sb-ext:step-condition #'sb-impl::invoke-stepper))
757 (funcall fun))))
758
759 (defun nth-frame (index)
760 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
761 (i index (1- i)))
762 ((zerop i) frame)))
763
764 (defimplementation compute-backtrace (start end)
765 "Return a list of frames starting with frame number START and
766 continuing to frame number END or, if END is nil, the last frame on the
767 stack."
768 (let ((end (or end most-positive-fixnum)))
769 (loop for f = (nth-frame start) then (sb-di:frame-down f)
770 for i from start below end
771 while f
772 collect f)))
773
774 (defimplementation print-frame (frame stream)
775 (sb-debug::print-frame-call frame stream))
776
777 ;;;; Code-location -> source-location translation
778
779 ;;; If debug-block info is avaibale, we determine the file position of
780 ;;; the source-path for a code-location. If the code was compiled
781 ;;; with C-c C-c, we have to search the position in the source string.
782 ;;; If there's no debug-block info, we return the (less precise)
783 ;;; source-location of the corresponding function.
784
785 (defun code-location-source-location (code-location)
786 (let* ((dsource (sb-di:code-location-debug-source code-location))
787 (plist (sb-c::debug-source-plist dsource)))
788 (if (getf plist :emacs-buffer)
789 (emacs-buffer-source-location code-location plist)
790 (ecase (sb-di:debug-source-from dsource)
791 (:file (file-source-location code-location))
792 (:lisp (lisp-source-location code-location))))))
793
794 ;;; FIXME: The naming policy of source-location functions is a bit
795 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
796 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
797 ;;; which returns the source location for a _code-location_.
798 ;;;
799 ;;; Maybe these should be named code-location-file-source-location,
800 ;;; etc, turned into generic functions, or something. In the very
801 ;;; least the names should indicate the main entry point vs. helper
802 ;;; status.
803
804 (defun file-source-location (code-location)
805 (if (code-location-has-debug-block-info-p code-location)
806 (source-file-source-location code-location)
807 (fallback-source-location code-location)))
808
809 (defun fallback-source-location (code-location)
810 (let ((fun (code-location-debug-fun-fun code-location)))
811 (cond (fun (function-source-location fun))
812 (t (error "Cannot find source location for: ~A " code-location)))))
813
814 (defun lisp-source-location (code-location)
815 (let ((source (prin1-to-string
816 (sb-debug::code-location-source-form code-location 100))))
817 (make-location `(:source-form ,source) '(:position 0))))
818
819 (defun emacs-buffer-source-location (code-location plist)
820 (if (code-location-has-debug-block-info-p code-location)
821 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
822 &allow-other-keys)
823 plist
824 (let* ((pos (string-source-position code-location emacs-string))
825 (snipped (with-input-from-string (s emacs-string)
826 (read-snippet s pos))))
827 (make-location `(:buffer ,emacs-buffer)
828 `(:position ,(+ emacs-position pos))
829 `(:snippet ,snipped))))
830 (fallback-source-location code-location)))
831
832 (defun source-file-source-location (code-location)
833 (let* ((code-date (code-location-debug-source-created code-location))
834 (filename (code-location-debug-source-name code-location))
835 (*readtable* (guess-readtable-for-filename filename))
836 (source-code (get-source-code filename code-date)))
837 (with-debootstrapping
838 (with-input-from-string (s source-code)
839 (let* ((pos (stream-source-position code-location s))
840 (snippet (read-snippet s pos)))
841 (make-location `(:file ,filename)
842 `(:position ,(1+ pos))
843 `(:snippet ,snippet)))))))
844
845 (defun code-location-debug-source-name (code-location)
846 (namestring (truename (sb-c::debug-source-name
847 (sb-di::code-location-debug-source code-location)))))
848
849 (defun code-location-debug-source-created (code-location)
850 (sb-c::debug-source-created
851 (sb-di::code-location-debug-source code-location)))
852
853 (defun code-location-debug-fun-fun (code-location)
854 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
855
856 (defun code-location-has-debug-block-info-p (code-location)
857 (handler-case
858 (progn (sb-di:code-location-debug-block code-location)
859 t)
860 (sb-di:no-debug-blocks () nil)))
861
862 (defun stream-source-position (code-location stream)
863 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
864 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
865 (form-number (sb-di::code-location-form-number cloc)))
866 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
867 (let* ((path-table (sb-di::form-number-translations tlf 0))
868 (path (cond ((<= (length path-table) form-number)
869 (warn "inconsistent form-number-translations")
870 (list 0))
871 (t
872 (reverse (cdr (aref path-table form-number)))))))
873 (source-path-source-position path tlf pos-map)))))
874
875 (defun string-source-position (code-location string)
876 (with-input-from-string (s string)
877 (stream-source-position code-location s)))
878
879 ;;; source-path-file-position and friends are in swank-source-path-parser
880
881 (defun safe-source-location-for-emacs (code-location)
882 (if *debug-definition-finding*
883 (code-location-source-location code-location)
884 (handler-case (code-location-source-location code-location)
885 (error (c) (list :error (format nil "~A" c))))))
886
887 (defimplementation frame-source-location-for-emacs (index)
888 (safe-source-location-for-emacs
889 (sb-di:frame-code-location (nth-frame index))))
890
891 (defun frame-debug-vars (frame)
892 "Return a vector of debug-variables in frame."
893 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
894
895 (defun debug-var-value (var frame location)
896 (ecase (sb-di:debug-var-validity var location)
897 (:valid (sb-di:debug-var-value var frame))
898 ((:invalid :unknown) ':<not-available>)))
899
900 (defimplementation frame-locals (index)
901 (let* ((frame (nth-frame index))
902 (loc (sb-di:frame-code-location frame))
903 (vars (frame-debug-vars frame)))
904 (loop for v across vars collect
905 (list :name (sb-di:debug-var-symbol v)
906 :id (sb-di:debug-var-id v)
907 :value (debug-var-value v frame loc)))))
908
909 (defimplementation frame-var-value (frame var)
910 (let* ((frame (nth-frame frame))
911 (dvar (aref (frame-debug-vars frame) var)))
912 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
913
914 (defimplementation frame-catch-tags (index)
915 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
916
917 (defimplementation eval-in-frame (form index)
918 (let ((frame (nth-frame index)))
919 (funcall (the function
920 (sb-di:preprocess-for-eval form
921 (sb-di:frame-code-location frame)))
922 frame)))
923
924 #+#.(swank-backend::sbcl-with-restart-frame)
925 (progn
926 (defimplementation return-from-frame (index form)
927 (let* ((frame (nth-frame index)))
928 (cond ((sb-debug:frame-has-debug-tag-p frame)
929 (let ((values (multiple-value-list (eval-in-frame form index))))
930 (sb-debug:unwind-to-frame-and-call frame
931 (lambda ()
932 (values-list values)))))
933 (t (format nil "Cannot return from frame: ~S" frame)))))
934
935 (defimplementation restart-frame (index)
936 (let* ((frame (nth-frame index)))
937 (cond ((sb-debug:frame-has-debug-tag-p frame)
938 (let* ((call-list (sb-debug::frame-call-as-list frame))
939 (fun (fdefinition (car call-list)))
940 (thunk (lambda ()
941 ;; Ensure that the thunk gets tail-call-optimized
942 (declare (optimize (debug 1)))
943 (apply fun (cdr call-list)))))
944 (sb-debug:unwind-to-frame-and-call frame thunk)))
945 (t (format nil "Cannot restart frame: ~S" frame))))))
946
947 ;; FIXME: this implementation doesn't unwind the stack before
948 ;; re-invoking the function, but it's better than no implementation at
949 ;; all.
950 #-#.(swank-backend::sbcl-with-restart-frame)
951 (progn
952 (defun sb-debug-catch-tag-p (tag)
953 (and (symbolp tag)
954 (not (symbol-package tag))
955 (string= tag :sb-debug-catch-tag)))
956
957 (defimplementation return-from-frame (index form)
958 (let* ((frame (nth-frame index))
959 (probe (assoc-if #'sb-debug-catch-tag-p
960 (sb-di::frame-catches frame))))
961 (cond (probe (throw (car probe) (eval-in-frame form index)))
962 (t (format nil "Cannot return from frame: ~S" frame)))))
963
964 (defimplementation restart-frame (index)
965 (let ((frame (nth-frame index)))
966 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
967
968 ;;;;; reference-conditions
969
970 (defimplementation format-sldb-condition (condition)
971 (let ((sb-int:*print-condition-references* nil))
972 (princ-to-string condition)))
973
974
975 ;;;; Profiling
976
977 (defimplementation profile (fname)
978 (when fname (eval `(sb-profile:profile ,fname))))
979
980 (defimplementation unprofile (fname)
981 (when fname (eval `(sb-profile:unprofile ,fname))))
982
983 (defimplementation unprofile-all ()
984 (sb-profile:unprofile)
985 "All functions unprofiled.")
986
987 (defimplementation profile-report ()
988 (sb-profile:report))
989
990 (defimplementation profile-reset ()
991 (sb-profile:reset)
992 "Reset profiling counters.")
993
994 (defimplementation profiled-functions ()
995 (sb-profile:profile))
996
997 (defimplementation profile-package (package callers methods)
998 (declare (ignore callers methods))
999 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1000
1001
1002 ;;;; Inspector
1003
1004 (defmethod inspect-for-emacs ((o t))
1005 (cond ((sb-di::indirect-value-cell-p o)
1006 (values "A value cell." (label-value-line*
1007 (:value (sb-kernel:value-cell-ref o)))))
1008 (t
1009 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1010 (if label
1011 (values text (loop for (l . v) in parts
1012 append (label-value-line l v)))
1013 (values text (loop for value in parts for i from 0
1014 append (label-value-line i value))))))))
1015
1016 (defmethod inspect-for-emacs ((o function))
1017 (let ((header (sb-kernel:widetag-of o)))
1018 (cond ((= header sb-vm:simple-fun-header-widetag)
1019 (values "A simple-fun."
1020 (label-value-line*
1021 (:name (sb-kernel:%simple-fun-name o))
1022 (:arglist (sb-kernel:%simple-fun-arglist o))
1023 (:self (sb-kernel:%simple-fun-self o))
1024 (:next (sb-kernel:%simple-fun-next o))
1025 (:type (sb-kernel:%simple-fun-type o))
1026 (:code (sb-kernel:fun-code-header o)))))
1027 ((= header sb-vm:closure-header-widetag)
1028 (values "A closure."
1029 (append
1030 (label-value-line :function (sb-kernel:%closure-fun o))
1031 `("Closed over values:" (:newline))
1032 (loop for i below (1- (sb-kernel:get-closure-length o))
1033 append (label-value-line
1034 i (sb-kernel:%closure-index-ref o i))))))
1035 (t (call-next-method o)))))
1036
1037 (defmethod inspect-for-emacs ((o sb-kernel:code-component))
1038 (values (format nil "~A is a code data-block." o)
1039 (append
1040 (label-value-line*
1041 (:code-size (sb-kernel:%code-code-size o))
1042 (:entry-points (sb-kernel:%code-entry-points o))
1043 (:debug-info (sb-kernel:%code-debug-info o))
1044 (:trace-table-offset (sb-kernel:code-header-ref
1045 o sb-vm:code-trace-table-offset-slot)))
1046 `("Constants:" (:newline))
1047 (loop for i from sb-vm:code-constants-offset
1048 below (sb-kernel:get-header-data o)
1049 append (label-value-line i (sb-kernel:code-header-ref o i)))
1050 `("Code:" (:newline)
1051 , (with-output-to-string (s)
1052 (cond ((sb-kernel:%code-debug-info o)
1053 (sb-disassem:disassemble-code-component o :stream s))
1054 (t
1055 (sb-disassem:disassemble-memory
1056 (sb-disassem::align
1057 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1058 sb-vm:lowtag-mask)
1059 (* sb-vm:code-constants-offset
1060 sb-vm:n-word-bytes))
1061 (ash 1 sb-vm:n-lowtag-bits))
1062 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1063 :stream s))))))))
1064
1065 (defmethod inspect-for-emacs ((o sb-ext:weak-pointer))
1066 (values "A weak pointer."
1067 (label-value-line*
1068 (:value (sb-ext:weak-pointer-value o)))))
1069
1070 (defmethod inspect-for-emacs ((o sb-kernel:fdefn))
1071 (values "A fdefn object."
1072 (label-value-line*
1073 (:name (sb-kernel:fdefn-name o))
1074 (:function (sb-kernel:fdefn-fun o)))))
1075
1076 (defmethod inspect-for-emacs :around ((o generic-function))
1077 (multiple-value-bind (title contents) (call-next-method)
1078 (values title
1079 (append
1080 contents
1081 (label-value-line*
1082 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1083 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1084 )))))
1085
1086
1087 ;;;; Multiprocessing
1088
1089 #+(and sb-thread
1090 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1091 (progn
1092 (defvar *thread-id-counter* 0)
1093
1094 (defvar *thread-id-counter-lock*
1095 (sb-thread:make-mutex :name "thread id counter lock"))
1096
1097 (defun next-thread-id ()
1098 (sb-thread:with-mutex (*thread-id-counter-lock*)
1099 (incf *thread-id-counter*)))
1100
1101 (defparameter *thread-id-map* (make-hash-table))
1102
1103 ;; This should be a thread -> id map but as weak keys are not
1104 ;; supported it is id -> map instead.
1105 (defvar *thread-id-map-lock*
1106 (sb-thread:make-mutex :name "thread id map lock"))
1107
1108 (defimplementation spawn (fn &key name)
1109 (sb-thread:make-thread fn :name name))
1110
1111 (defimplementation thread-id (thread)
1112 (block thread-id
1113 (sb-thread:with-mutex (*thread-id-map-lock*)
1114 (loop for id being the hash-key in *thread-id-map*
1115 using (hash-value thread-pointer)
1116 do
1117 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1118 (cond ((null maybe-thread)
1119 ;; the value is gc'd, remove it manually
1120 (remhash id *thread-id-map*))
1121 ((eq thread maybe-thread)
1122 (return-from thread-id id)))))
1123 ;; lazy numbering
1124 (let ((id (next-thread-id)))
1125 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1126 id))))
1127
1128 (defimplementation find-thread (id)
1129 (sb-thread:with-mutex (*thread-id-map-lock*)
1130 (let ((thread-pointer (gethash id *thread-id-map*)))
1131 (if thread-pointer
1132 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1133 (if maybe-thread
1134 maybe-thread
1135 ;; the value is gc'd, remove it manually
1136 (progn
1137 (remhash id *thread-id-map*)
1138 nil)))
1139 nil))))
1140
1141 (defimplementation thread-name (thread)
1142 ;; sometimes the name is not a string (e.g. NIL)
1143 (princ-to-string (sb-thread:thread-name thread)))
1144
1145 (defimplementation thread-status (thread)
1146 (if (sb-thread:thread-alive-p thread)
1147 "RUNNING"
1148 "STOPPED"))
1149
1150 (defimplementation make-lock (&key name)
1151 (sb-thread:make-mutex :name name))
1152
1153 (defimplementation call-with-lock-held (lock function)
1154 (declare (type function function))
1155 (sb-thread:with-mutex (lock) (funcall function)))
1156
1157 (defimplementation make-recursive-lock (&key name)
1158 (sb-thread:make-mutex :name name))
1159
1160 (defimplementation call-with-recursive-lock-held (lock function)
1161 (declare (type function function))
1162 (sb-thread:with-recursive-lock (lock) (funcall function)))
1163
1164 (defimplementation current-thread ()
1165 sb-thread:*current-thread*)
1166
1167 (defimplementation all-threads ()
1168 (sb-thread:list-all-threads))
1169
1170 (defimplementation interrupt-thread (thread fn)
1171 (sb-thread:interrupt-thread thread fn))
1172
1173 (defimplementation kill-thread (thread)
1174 (sb-thread:terminate-thread thread))
1175
1176 (defimplementation thread-alive-p (thread)
1177 (sb-thread:thread-alive-p thread))
1178
1179 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1180 (defvar *mailboxes* (list))
1181 (declaim (type list *mailboxes*))
1182
1183 (defstruct (mailbox (:conc-name mailbox.))
1184 thread
1185 (mutex (sb-thread:make-mutex))
1186 (waitqueue (sb-thread:make-waitqueue))
1187 (queue '() :type list))
1188
1189 (defun mailbox (thread)
1190 "Return THREAD's mailbox."
1191 (sb-thread:with-mutex (*mailbox-lock*)
1192 (or (find thread *mailboxes* :key #'mailbox.thread)
1193 (let ((mb (make-mailbox :thread thread)))
1194 (push mb *mailboxes*)
1195 mb))))
1196
1197 (defimplementation send (thread message)
1198 (let* ((mbox (mailbox thread))
1199 (mutex (mailbox.mutex mbox)))
1200 (sb-thread:with-mutex (mutex)
1201 (setf (mailbox.queue mbox)
1202 (nconc (mailbox.queue mbox) (list message)))
1203 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1204
1205 (defimplementation receive ()
1206 (let* ((mbox (mailbox (current-thread)))
1207 (mutex (mailbox.mutex mbox)))
1208 (sb-thread:with-mutex (mutex)
1209 (loop
1210 (let ((q (mailbox.queue mbox)))
1211 (cond (q (return (pop (mailbox.queue mbox))))
1212 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1213 mutex))))))))
1214
1215
1216 ;; Auto-flush streams
1217
1218 (defvar *auto-flush-interval* 0.15
1219 "How often to flush interactive streams. This valu is passed
1220 directly to cl:sleep.")
1221
1222 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
1223
1224 (defvar *auto-flush-thread* nil)
1225
1226 (defvar *auto-flush-streams* '())
1227
1228 (defimplementation make-stream-interactive (stream)
1229 (call-with-recursive-lock-held
1230 *auto-flush-lock*
1231 (lambda ()
1232 (pushnew stream *auto-flush-streams*)
1233 (unless *auto-flush-thread*
1234 (setq *auto-flush-thread*
1235 (sb-thread:make-thread #'flush-streams
1236 :name "auto-flush-thread"))))))
1237
1238 (defun flush-streams ()
1239 (loop
1240 (call-with-recursive-lock-held
1241 *auto-flush-lock*
1242 (lambda ()
1243 (setq *auto-flush-streams*
1244 (remove-if (lambda (x)
1245 (not (and (open-stream-p x)
1246 (output-stream-p x))))
1247 *auto-flush-streams*))
1248 (mapc #'finish-output *auto-flush-streams*)))
1249 (sleep *auto-flush-interval*)))
1250
1251 )
1252
1253 (defimplementation quit-lisp ()
1254 #+sb-thread
1255 (dolist (thread (remove (current-thread) (all-threads)))
1256 (ignore-errors (sb-thread:interrupt-thread
1257 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1258 (sb-ext:quit))
1259
1260
1261
1262 ;;Trace implementations
1263 ;;In SBCL, we have:
1264 ;; (trace <name>)
1265 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1266 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1267 ;; <name> can be a normal name or a (setf name)
1268
1269 (defun toggle-trace-aux (fspec &rest args)
1270 (cond ((member fspec (eval '(trace)) :test #'equal)
1271 (eval `(untrace ,fspec))
1272 (format nil "~S is now untraced." fspec))
1273 (t
1274 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1275 (format nil "~S is now traced." fspec))))
1276
1277 (defun process-fspec (fspec)
1278 (cond ((consp fspec)
1279 (ecase (first fspec)
1280 ((:defun :defgeneric) (second fspec))
1281 ((:defmethod) `(method ,@(rest fspec)))
1282 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1283 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1284 (t
1285 fspec)))
1286
1287 (defimplementation toggle-trace (spec)
1288 (ecase (car spec)
1289 ((setf)
1290 (toggle-trace-aux spec))
1291 ((:defmethod)
1292 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1293 ((:defgeneric)
1294 (toggle-trace-aux (second spec) :methods t))
1295 ((:call)
1296 (destructuring-bind (caller callee) (cdr spec)
1297 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1298
1299 ;;; Weak datastructures
1300
1301 (defimplementation make-weak-key-hash-table (&rest args)
1302 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1303 (apply #'make-hash-table :weakness :key args)
1304 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1305 (apply #'make-hash-table args))
1306
1307 (defimplementation make-weak-value-hash-table (&rest args)
1308 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1309 (apply #'make-hash-table :weakness :value args)
1310 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1311 (apply #'make-hash-table args))
1312
1313 (defimplementation hash-table-weakness (hashtable)
1314 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1315 (sb-ext:hash-table-weakness hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5