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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.185 - (show annotations)
Tue Sep 11 19:31:03 2007 UTC (6 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.184: +1 -0 lines
* swank-loader.lisp: Aways compile-file `contrib/swank-asdf.lisp'
  on SBCL. This fixes "Undefined function" style-warnings when using
  `slime-asdf' in combination with SBCL. Reported by Cyrus Harmon.

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

  ViewVC Help
Powered by ViewVC 1.1.5