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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.179 - (show annotations)
Thu Aug 23 16:20:11 2007 UTC (6 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.178: +14 -1 lines
	Added arglist display for declaration specifiers and type
	specifiers.

	Examples:

	`(declare (type' will display

	   (declare (type type-specifier &rest vars))

	`(declare (type (float' will display

	   [Typespec] (float &optional lower-limit upper-limit)

	`(declare (optimize' will display

	   (declare (optimize &any (safety 1) (space 1) (speed 1) ...))

	&ANY is a new lambda keyword that is introduced for arglist
	description purpose, and is very similiar to &KEY, but isn't based
	upon plists; they're more based upon *FEATURES* lists. (See the
	comment near the ARGLIST defstruct in `swank.lisp'.)

	* slime.el:
	(slime-to-feature-keyword): Renamed to `slime-keywordify'.
	(slime-eval-feature-conditional): Adapted to use `slime-keywordify'.
	(slime-ensure-list): New utility.
	(slime-sexp-at-point): Now takes an argument that specify how many
	sexps at point should be returned.
	(slime-enclosing-operator-names): Renamed to
	`slime-enclosing-form-specs'.
	(slime-enclosing-form-specs): Returns a list of ``raw form specs''
	instead of what was called ``extended operator names'' before, see
	`swank::parse-form-spec' for more information. This is a
	simplified superset. Additionally as tertiary return value return
	a list of points to let the caller see where each form spec is
	located. Adapted callers accordingly. Extended docstring.
	(slime-parse-extended-operator-name): Adapted to changes in
	`slime-enclosing-form-specs'. Now gets more context, and is such
	more powerful. This was needed to allow parsing DECLARE forms.
	(slime-make-extended-operator-parser/look-ahead): Because the
	protocol for arglist display was simplified, it was possible to
	replace the plethora of parsing function just by this one.
	(slime-extended-operator-name-parser-alist): Use it. Also add
	parser for DECLARE forms.
	(slime-parse-extended-operator/declare): Responsible for parsing
	DECLARE forms.
	(%slime-in-mid-of-typespec-p): Helper function for
	`slime-parse-extended-operator/declare'.
	(slime-incomplete-form-at-point): New. Return the ``raw form
	spec'' near point.
	(slime-complete-form): Use `slime-incomplete-form-at-point'.

	* swank.lisp: New Helper functions.
	(length=, ensure-list, recursively-empty-p): New.
	(maybecall, exactly-one-p): New.

	* swank.lisp (arglist-for-echo-area): Adapted to take ``raw form
	specs'' from Slime.
	(parse-form-spec): New. Takes a ``raw form spec'' and returns a
	``form spec'' for further processing in Swank. Docstring documents
	these two terms.
	(split-form-spec): New. Return relevant information from a form	spec.
	(parse-first-valid-form-spec): Replaces `find-valid-operator-name'.
	(find-valid-operator-name): Removed.
	(operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'.

	(defstruct arglist): Add `any-p' and `any-args' slots to contain
	arguments belonging to the &ANY lambda keyword.
	(print-arglist): Adapted to also print &ANY args.
	(print-decoded-arglist-as-template): Likewise.
	(decode-arglist): Adapted to also decode &ANY args.
	(remove-actual-args): Adapted to also remove &ANY args.
	(remove-&key-args): Split out from `remove-actual-args'.
	(remove-&any-args): New. Removes already provided &ANY args.
	(arglist-from-form-spec): New. Added detailed docstring.
	(arglist-dispatch): Dispatching generic function for
	`arglist-from-form-spec' that does all the work. Renamed from
	prior `form-completion'.
	(arglist-dispatch) Added methods for dealing with declaration and
	type-specifiers.
	(complete-form): Adapted to take ``raw form specs'' from Slime.
	(completions-for-keyword): Likewise.
	(format-arglist-for-echo-area): Removed. Not needed anymore.

	* swank-backend.lisp (declaration-arglist): New generic
	function. Returns the arglist for a given declaration
	identifier. (Backends are supposed to specialize it if they can
	provide additional information.)
	(type-specifier-arglist): New generic function. Returns the
	arglist for a given type-specifier operator. (Backends are
	supposed to specialize it if they can provide additional
	information.)
	(*type-specifier-arglists*): New variable. Contains the arglists
	for the type specifiers in Common Lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5