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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5