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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.177 - (show annotations)
Thu Apr 12 19:00:09 2007 UTC (7 years ago) by nsiivola
Branch: MAIN
Changes since 1.176: +3 -1 lines
Accept :emacs-direcory in emacs-buffer-source-location plist.
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
787 &allow-other-keys)
788 plist
789 (let* ((pos (string-source-position code-location emacs-string))
790 (snipped (with-input-from-string (s emacs-string)
791 (read-snippet s pos))))
792 (make-location `(:buffer ,emacs-buffer)
793 `(:position ,(+ emacs-position pos))
794 `(:snippet ,snipped))))
795 (fallback-source-location code-location)))
796
797 (defun source-file-source-location (code-location)
798 (let* ((code-date (code-location-debug-source-created code-location))
799 (filename (code-location-debug-source-name code-location))
800 (source-code (get-source-code filename code-date)))
801 (with-input-from-string (s source-code)
802 (let* ((pos (stream-source-position code-location s))
803 (snippet (read-snippet s pos)))
804 (make-location `(:file ,filename)
805 `(:position ,(1+ pos))
806 `(:snippet ,snippet))))))
807
808 (defun code-location-debug-source-name (code-location)
809 (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
810
811 (defun code-location-debug-source-created (code-location)
812 (sb-c::debug-source-created
813 (sb-di::code-location-debug-source code-location)))
814
815 (defun code-location-debug-fun-fun (code-location)
816 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
817
818 (defun code-location-has-debug-block-info-p (code-location)
819 (handler-case
820 (progn (sb-di:code-location-debug-block code-location)
821 t)
822 (sb-di:no-debug-blocks () nil)))
823
824 (defun stream-source-position (code-location stream)
825 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
826 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
827 (form-number (sb-di::code-location-form-number cloc)))
828 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
829 (let* ((path-table (sb-di::form-number-translations tlf 0))
830 (path (cond ((<= (length path-table) form-number)
831 (warn "inconsistent form-number-translations")
832 (list 0))
833 (t
834 (reverse (cdr (aref path-table form-number)))))))
835 (source-path-source-position path tlf pos-map)))))
836
837 (defun string-source-position (code-location string)
838 (with-input-from-string (s string)
839 (stream-source-position code-location s)))
840
841 ;;; source-path-file-position and friends are in swank-source-path-parser
842
843 (defun safe-source-location-for-emacs (code-location)
844 (if *debug-definition-finding*
845 (code-location-source-location code-location)
846 (handler-case (code-location-source-location code-location)
847 (error (c) (list :error (format nil "~A" c))))))
848
849 (defimplementation frame-source-location-for-emacs (index)
850 (safe-source-location-for-emacs
851 (sb-di:frame-code-location (nth-frame index))))
852
853 (defun frame-debug-vars (frame)
854 "Return a vector of debug-variables in frame."
855 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
856
857 (defun debug-var-value (var frame location)
858 (ecase (sb-di:debug-var-validity var location)
859 (:valid (sb-di:debug-var-value var frame))
860 ((:invalid :unknown) ':<not-available>)))
861
862 (defimplementation frame-locals (index)
863 (let* ((frame (nth-frame index))
864 (loc (sb-di:frame-code-location frame))
865 (vars (frame-debug-vars frame)))
866 (loop for v across vars collect
867 (list :name (sb-di:debug-var-symbol v)
868 :id (sb-di:debug-var-id v)
869 :value (debug-var-value v frame loc)))))
870
871 (defimplementation frame-var-value (frame var)
872 (let* ((frame (nth-frame frame))
873 (dvar (aref (frame-debug-vars frame) var)))
874 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
875
876 (defimplementation frame-catch-tags (index)
877 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
878
879 (defimplementation eval-in-frame (form index)
880 (let ((frame (nth-frame index)))
881 (funcall (the function
882 (sb-di:preprocess-for-eval form
883 (sb-di:frame-code-location frame)))
884 frame)))
885
886 #+#.(swank-backend::sbcl-with-restart-frame)
887 (progn
888 (defimplementation return-from-frame (index form)
889 (let* ((frame (nth-frame index)))
890 (cond ((sb-debug:frame-has-debug-tag-p frame)
891 (let ((values (multiple-value-list (eval-in-frame form index))))
892 (sb-debug:unwind-to-frame-and-call frame
893 (lambda ()
894 (values-list values)))))
895 (t (format nil "Cannot return from frame: ~S" frame)))))
896
897 (defimplementation restart-frame (index)
898 (let* ((frame (nth-frame index)))
899 (cond ((sb-debug:frame-has-debug-tag-p frame)
900 (let* ((call-list (sb-debug::frame-call-as-list frame))
901 (fun (fdefinition (car call-list)))
902 (thunk (lambda ()
903 ;; Ensure that the thunk gets tail-call-optimized
904 (declare (optimize (debug 1)))
905 (apply fun (cdr call-list)))))
906 (sb-debug:unwind-to-frame-and-call frame thunk)))
907 (t (format nil "Cannot restart frame: ~S" frame))))))
908
909 ;; FIXME: this implementation doesn't unwind the stack before
910 ;; re-invoking the function, but it's better than no implementation at
911 ;; all.
912 #-#.(swank-backend::sbcl-with-restart-frame)
913 (progn
914 (defun sb-debug-catch-tag-p (tag)
915 (and (symbolp tag)
916 (not (symbol-package tag))
917 (string= tag :sb-debug-catch-tag)))
918
919 (defimplementation return-from-frame (index form)
920 (let* ((frame (nth-frame index))
921 (probe (assoc-if #'sb-debug-catch-tag-p
922 (sb-di::frame-catches frame))))
923 (cond (probe (throw (car probe) (eval-in-frame form index)))
924 (t (format nil "Cannot return from frame: ~S" frame)))))
925
926 (defimplementation restart-frame (index)
927 (let ((frame (nth-frame index)))
928 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
929
930 ;;;;; reference-conditions
931
932 (defimplementation format-sldb-condition (condition)
933 (let ((sb-int:*print-condition-references* nil))
934 (princ-to-string condition)))
935
936 (defimplementation condition-references (condition)
937 (if (typep condition 'sb-int:reference-condition)
938 (sb-int:reference-condition-references condition)
939 '()))
940
941
942 ;;;; Profiling
943
944 (defimplementation profile (fname)
945 (when fname (eval `(sb-profile:profile ,fname))))
946
947 (defimplementation unprofile (fname)
948 (when fname (eval `(sb-profile:unprofile ,fname))))
949
950 (defimplementation unprofile-all ()
951 (sb-profile:unprofile)
952 "All functions unprofiled.")
953
954 (defimplementation profile-report ()
955 (sb-profile:report))
956
957 (defimplementation profile-reset ()
958 (sb-profile:reset)
959 "Reset profiling counters.")
960
961 (defimplementation profiled-functions ()
962 (sb-profile:profile))
963
964 (defimplementation profile-package (package callers methods)
965 (declare (ignore callers methods))
966 (eval `(sb-profile:profile ,(package-name (find-package package)))))
967
968
969 ;;;; Inspector
970
971 (defclass sbcl-inspector (inspector)
972 ())
973
974 (defimplementation make-default-inspector ()
975 (make-instance 'sbcl-inspector))
976
977 (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
978 (declare (ignore inspector))
979 (cond ((sb-di::indirect-value-cell-p o)
980 (values "A value cell." (label-value-line*
981 (:value (sb-kernel:value-cell-ref o)))))
982 (t
983 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
984 (if label
985 (values text (loop for (l . v) in parts
986 append (label-value-line l v)))
987 (values text (loop for value in parts for i from 0
988 append (label-value-line i value))))))))
989
990 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
991 (declare (ignore inspector))
992 (let ((header (sb-kernel:widetag-of o)))
993 (cond ((= header sb-vm:simple-fun-header-widetag)
994 (values "A simple-fun."
995 (label-value-line*
996 (:name (sb-kernel:%simple-fun-name o))
997 (:arglist (sb-kernel:%simple-fun-arglist o))
998 (:self (sb-kernel:%simple-fun-self o))
999 (:next (sb-kernel:%simple-fun-next o))
1000 (:type (sb-kernel:%simple-fun-type o))
1001 (:code (sb-kernel:fun-code-header o)))))
1002 ((= header sb-vm:closure-header-widetag)
1003 (values "A closure."
1004 (append
1005 (label-value-line :function (sb-kernel:%closure-fun o))
1006 `("Closed over values:" (:newline))
1007 (loop for i below (1- (sb-kernel:get-closure-length o))
1008 append (label-value-line
1009 i (sb-kernel:%closure-index-ref o i))))))
1010 (t (call-next-method o)))))
1011
1012 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
1013 (declare (ignore _))
1014 (values (format nil "~A is a code data-block." o)
1015 (append
1016 (label-value-line*
1017 (:code-size (sb-kernel:%code-code-size o))
1018 (:entry-points (sb-kernel:%code-entry-points o))
1019 (:debug-info (sb-kernel:%code-debug-info o))
1020 (:trace-table-offset (sb-kernel:code-header-ref
1021 o sb-vm:code-trace-table-offset-slot)))
1022 `("Constants:" (:newline))
1023 (loop for i from sb-vm:code-constants-offset
1024 below (sb-kernel:get-header-data o)
1025 append (label-value-line i (sb-kernel:code-header-ref o i)))
1026 `("Code:" (:newline)
1027 , (with-output-to-string (s)
1028 (cond ((sb-kernel:%code-debug-info o)
1029 (sb-disassem:disassemble-code-component o :stream s))
1030 (t
1031 (sb-disassem:disassemble-memory
1032 (sb-disassem::align
1033 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1034 sb-vm:lowtag-mask)
1035 (* sb-vm:code-constants-offset
1036 sb-vm:n-word-bytes))
1037 (ash 1 sb-vm:n-lowtag-bits))
1038 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1039 :stream s))))))))
1040
1041 (defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector sbcl-inspector))
1042 (declare (ignore inspector))
1043 (values "A weak pointer."
1044 (label-value-line*
1045 (:value (sb-ext:weak-pointer-value o)))))
1046
1047 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
1048 (declare (ignore inspector))
1049 (values "A fdefn object."
1050 (label-value-line*
1051 (:name (sb-kernel:fdefn-name o))
1052 (:function (sb-kernel:fdefn-fun o)))))
1053
1054 (defmethod inspect-for-emacs :around ((o generic-function)
1055 (inspector sbcl-inspector))
1056 (declare (ignore inspector))
1057 (multiple-value-bind (title contents) (call-next-method)
1058 (values title
1059 (append
1060 contents
1061 (label-value-line*
1062 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1063 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1064 )))))
1065
1066
1067 ;;;; Multiprocessing
1068
1069 #+(and sb-thread
1070 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1071 (progn
1072 (defvar *thread-id-counter* 0)
1073
1074 (defvar *thread-id-counter-lock*
1075 (sb-thread:make-mutex :name "thread id counter lock"))
1076
1077 (defun next-thread-id ()
1078 (sb-thread:with-mutex (*thread-id-counter-lock*)
1079 (incf *thread-id-counter*)))
1080
1081 (defparameter *thread-id-map* (make-hash-table))
1082
1083 ;; This should be a thread -> id map but as weak keys are not
1084 ;; supported it is id -> map instead.
1085 (defvar *thread-id-map-lock*
1086 (sb-thread:make-mutex :name "thread id map lock"))
1087
1088 (defimplementation spawn (fn &key name)
1089 (sb-thread:make-thread fn :name name))
1090
1091 (defimplementation thread-id (thread)
1092 (block thread-id
1093 (sb-thread:with-mutex (*thread-id-map-lock*)
1094 (loop for id being the hash-key in *thread-id-map*
1095 using (hash-value thread-pointer)
1096 do
1097 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1098 (cond ((null maybe-thread)
1099 ;; the value is gc'd, remove it manually
1100 (remhash id *thread-id-map*))
1101 ((eq thread maybe-thread)
1102 (return-from thread-id id)))))
1103 ;; lazy numbering
1104 (let ((id (next-thread-id)))
1105 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1106 id))))
1107
1108 (defimplementation find-thread (id)
1109 (sb-thread:with-mutex (*thread-id-map-lock*)
1110 (let ((thread-pointer (gethash id *thread-id-map*)))
1111 (if thread-pointer
1112 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1113 (if maybe-thread
1114 maybe-thread
1115 ;; the value is gc'd, remove it manually
1116 (progn
1117 (remhash id *thread-id-map*)
1118 nil)))
1119 nil))))
1120
1121 (defimplementation thread-name (thread)
1122 ;; sometimes the name is not a string (e.g. NIL)
1123 (princ-to-string (sb-thread:thread-name thread)))
1124
1125 (defimplementation thread-status (thread)
1126 (if (sb-thread:thread-alive-p thread)
1127 "RUNNING"
1128 "STOPPED"))
1129
1130 (defimplementation make-lock (&key name)
1131 (sb-thread:make-mutex :name name))
1132
1133 (defimplementation call-with-lock-held (lock function)
1134 (declare (type function function))
1135 (sb-thread:with-mutex (lock) (funcall function)))
1136
1137 (defimplementation make-recursive-lock (&key name)
1138 (sb-thread:make-mutex :name name))
1139
1140 (defimplementation call-with-recursive-lock-held (lock function)
1141 (declare (type function function))
1142 (sb-thread:with-recursive-lock (lock) (funcall function)))
1143
1144 (defimplementation current-thread ()
1145 sb-thread:*current-thread*)
1146
1147 (defimplementation all-threads ()
1148 (sb-thread:list-all-threads))
1149
1150 (defimplementation interrupt-thread (thread fn)
1151 (sb-thread:interrupt-thread thread fn))
1152
1153 (defimplementation kill-thread (thread)
1154 (sb-thread:terminate-thread thread))
1155
1156 (defimplementation thread-alive-p (thread)
1157 (sb-thread:thread-alive-p thread))
1158
1159 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1160 (defvar *mailboxes* (list))
1161 (declaim (type list *mailboxes*))
1162
1163 (defstruct (mailbox (:conc-name mailbox.))
1164 thread
1165 (mutex (sb-thread:make-mutex))
1166 (waitqueue (sb-thread:make-waitqueue))
1167 (queue '() :type list))
1168
1169 (defun mailbox (thread)
1170 "Return THREAD's mailbox."
1171 (sb-thread:with-mutex (*mailbox-lock*)
1172 (or (find thread *mailboxes* :key #'mailbox.thread)
1173 (let ((mb (make-mailbox :thread thread)))
1174 (push mb *mailboxes*)
1175 mb))))
1176
1177 (defimplementation send (thread message)
1178 (let* ((mbox (mailbox thread))
1179 (mutex (mailbox.mutex mbox)))
1180 (sb-thread:with-mutex (mutex)
1181 (setf (mailbox.queue mbox)
1182 (nconc (mailbox.queue mbox) (list message)))
1183 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1184
1185 (defimplementation receive ()
1186 (let* ((mbox (mailbox (current-thread)))
1187 (mutex (mailbox.mutex mbox)))
1188 (sb-thread:with-mutex (mutex)
1189 (loop
1190 (let ((q (mailbox.queue mbox)))
1191 (cond (q (return (pop (mailbox.queue mbox))))
1192 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1193 mutex))))))))
1194
1195
1196 ;;; Auto-flush streams
1197
1198 ;; XXX race conditions
1199 (defvar *auto-flush-streams* '())
1200
1201 (defvar *auto-flush-thread* nil)
1202
1203 (defimplementation make-stream-interactive (stream)
1204 (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
1205 (unless *auto-flush-thread*
1206 (setq *auto-flush-thread*
1207 (sb-thread:make-thread #'flush-streams
1208 :name "auto-flush-thread"))))
1209
1210 (defun flush-streams ()
1211 (loop
1212 (setq *auto-flush-streams*
1213 (remove-if (lambda (x)
1214 (not (and (open-stream-p x)
1215 (output-stream-p x))))
1216 *auto-flush-streams*))
1217 (mapc #'finish-output *auto-flush-streams*)
1218 (sleep 0.15)))
1219
1220 )
1221
1222 (defimplementation quit-lisp ()
1223 #+sb-thread
1224 (dolist (thread (remove (current-thread) (all-threads)))
1225 (ignore-errors (sb-thread:interrupt-thread
1226 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1227 (sb-ext:quit))
1228
1229
1230
1231 ;;Trace implementations
1232 ;;In SBCL, we have:
1233 ;; (trace <name>)
1234 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1235 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1236 ;; <name> can be a normal name or a (setf name)
1237
1238 (defun toggle-trace-aux (fspec &rest args)
1239 (cond ((member fspec (eval '(trace)) :test #'equal)
1240 (eval `(untrace ,fspec))
1241 (format nil "~S is now untraced." fspec))
1242 (t
1243 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1244 (format nil "~S is now traced." fspec))))
1245
1246 (defun process-fspec (fspec)
1247 (cond ((consp fspec)
1248 (ecase (first fspec)
1249 ((:defun :defgeneric) (second fspec))
1250 ((:defmethod) `(method ,@(rest fspec)))
1251 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1252 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1253 (t
1254 fspec)))
1255
1256 (defimplementation toggle-trace (spec)
1257 (ecase (car spec)
1258 ((setf)
1259 (toggle-trace-aux spec))
1260 ((:defmethod)
1261 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1262 ((:defgeneric)
1263 (toggle-trace-aux (second spec) :methods t))
1264 ((:call)
1265 (destructuring-bind (caller callee) (cdr spec)
1266 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1267
1268 ;;; Weak datastructures
1269
1270 (defimplementation make-weak-key-hash-table (&rest args)
1271 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1272 (apply #'make-hash-table :weakness :key args)
1273 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1274 (apply #'make-hash-table args))
1275
1276 (defimplementation make-weak-value-hash-table (&rest args)
1277 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1278 (apply #'make-hash-table :weakness :value args)
1279 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1280 (apply #'make-hash-table args))
1281
1282 (defimplementation hash-table-weakness (hashtable)
1283 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1284 (sb-ext:hash-table-weakness hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5