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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.103 - (show annotations)
Wed Sep 15 17:31:58 2004 UTC (9 years, 7 months ago) by mbaringer
Branch: MAIN
Changes since 1.102: +12 -5 lines
(inspect-for-emacs): Insert function object's
documentation when it's available.
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 ;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later
11 ;;; for the SB-INTROSPECT contrib
12
13
14 ;;; Administrivia
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (require 'sb-bsd-sockets)
18 (require 'sb-introspect)
19 (require 'sb-posix)
20 )
21
22 (declaim (optimize (debug 3)))
23 (in-package :swank-backend)
24
25 (import
26 '(sb-gray:fundamental-character-output-stream
27 sb-gray:stream-write-char
28 sb-gray:stream-line-length
29 sb-gray:stream-force-output
30 sb-gray:fundamental-character-input-stream
31 sb-gray:stream-read-char
32 sb-gray:stream-listen
33 sb-gray:stream-unread-char
34 sb-gray:stream-clear-input
35 sb-gray:stream-line-column
36 sb-gray:stream-line-length))
37
38 ;;; swank-mop
39
40 (import-to-swank-mop
41 '( ;; classes
42 cl:standard-generic-function
43 sb-mop::standard-slot-definition
44 cl:method
45 cl:standard-class
46 ;; standard-class readers
47 sb-mop:class-default-initargs
48 sb-mop:class-direct-default-initargs
49 sb-mop:class-direct-slots
50 sb-mop:class-direct-subclasses
51 sb-mop:class-direct-superclasses
52 sb-mop:class-finalized-p
53 cl:class-name
54 sb-mop:class-precedence-list
55 sb-mop:class-prototype
56 sb-mop:class-slots
57 ;; generic function readers
58 sb-mop:generic-function-argument-precedence-order
59 sb-mop:generic-function-declarations
60 sb-mop:generic-function-lambda-list
61 sb-mop:generic-function-methods
62 sb-mop:generic-function-method-class
63 sb-mop:generic-function-method-combination
64 sb-mop:generic-function-name
65 ;; method readers
66 sb-mop:method-generic-function
67 sb-mop:method-function
68 sb-mop:method-lambda-list
69 sb-mop:method-specializers
70 sb-mop:method-qualifiers
71 ;; slot readers
72 sb-mop:slot-definition-allocation
73 sb-mop:slot-definition-initargs
74 sb-mop:slot-definition-initform
75 sb-mop:slot-definition-initfunction
76 sb-mop:slot-definition-name
77 sb-mop:slot-definition-type
78 sb-mop:slot-definition-readers
79 sb-mop:slot-definition-writers))
80
81 (defun swank-mop:slot-definition-documentation (slot)
82 (sb-pcl::documentation slot t))
83
84 ;;; TCP Server
85
86 (defimplementation preferred-communication-style ()
87 (if (and (sb-int:featurep :sb-thread)
88 (sb-int:featurep :sb-futex))
89 :spawn
90 :fd-handler))
91
92 (defun resolve-hostname (name)
93 (car (sb-bsd-sockets:host-ent-addresses
94 (sb-bsd-sockets:get-host-by-name name))))
95
96 (defimplementation create-socket (host port)
97 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
98 :type :stream
99 :protocol :tcp)))
100 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
101 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
102 (sb-bsd-sockets:socket-listen socket 5)
103 socket))
104
105 (defimplementation local-port (socket)
106 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
107
108 (defimplementation close-socket (socket)
109 (sb-sys:invalidate-descriptor (socket-fd socket))
110 (sb-bsd-sockets:socket-close socket))
111
112 (defimplementation accept-connection (socket)
113 (make-socket-io-stream (accept socket)))
114
115 (defvar *sigio-handlers* '()
116 "List of (key . fn) pairs to be called on SIGIO.")
117
118 (defun sigio-handler (signal code scp)
119 (declare (ignore signal code scp))
120 (mapc (lambda (handler)
121 (funcall (the function (cdr handler))))
122 *sigio-handlers*))
123
124 (defun set-sigio-handler ()
125 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
126 (sigio-handler signal code scp))))
127
128 (defun enable-sigio-on-fd (fd)
129 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
130 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
131
132 (defimplementation add-sigio-handler (socket fn)
133 (set-sigio-handler)
134 (let ((fd (socket-fd socket)))
135 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
136 (enable-sigio-on-fd fd)
137 (push (cons fd fn) *sigio-handlers*)))
138
139 (defimplementation remove-sigio-handlers (socket)
140 (let ((fd (socket-fd socket)))
141 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
142 (sb-sys:invalidate-descriptor fd))
143 (close socket))
144
145 (defimplementation add-fd-handler (socket fn)
146 (declare (type function fn))
147 (let ((fd (socket-fd socket)))
148 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
149 (sb-sys:add-fd-handler fd :input (lambda (_)
150 _
151 (funcall fn)))))
152
153 (defimplementation remove-fd-handlers (socket)
154 (sb-sys:invalidate-descriptor (socket-fd socket)))
155
156 (defun socket-fd (socket)
157 (etypecase socket
158 (fixnum socket)
159 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
160 (file-stream (sb-sys:fd-stream-fd socket))))
161
162 (defun make-socket-io-stream (socket)
163 (sb-bsd-sockets:socket-make-stream socket
164 :output t
165 :input t
166 :element-type 'base-char))
167
168 (defun accept (socket)
169 "Like socket-accept, but retry on EAGAIN."
170 (loop (handler-case
171 (return (sb-bsd-sockets:socket-accept socket))
172 (sb-bsd-sockets:interrupted-error ()))))
173
174 (defimplementation emacs-connected (stream)
175 (declare (ignore stream))
176 (setq sb-ext:*invoke-debugger-hook*
177 (find-symbol (string :swank-debugger-hook) (find-package :swank))))
178
179 (defmethod call-without-interrupts (fn)
180 (declare (type function fn))
181 (sb-sys:without-interrupts (funcall fn)))
182
183 (defimplementation getpid ()
184 (sb-posix:getpid))
185
186 (defimplementation lisp-implementation-type-name ()
187 "sbcl")
188
189 (defimplementation quit-lisp ()
190 (sb-ext:quit))
191
192 ;;; Utilities
193
194 (defvar *swank-debugger-stack-frame*)
195
196 (defimplementation arglist ((fname t))
197 (sb-introspect:function-arglist fname))
198
199 (defimplementation function-name ((f function))
200 (sb-impl::%fun-name f))
201
202 (defvar *buffer-name* nil)
203 (defvar *buffer-offset*)
204 (defvar *buffer-substring* nil)
205
206 (defvar *previous-compiler-condition* nil
207 "Used to detect duplicates.")
208
209 (defun handle-notification-condition (condition)
210 "Handle a condition caused by a compiler warning.
211 This traps all compiler conditions at a lower-level than using
212 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
213 craft our own error messages, which can omit a lot of redundant
214 information."
215 (let ((context (sb-c::find-error-context nil)))
216 (unless (eq condition *previous-compiler-condition*)
217 (setq *previous-compiler-condition* condition)
218 (signal-compiler-condition condition context))))
219
220 (defun signal-compiler-condition (condition context)
221 (signal (make-condition
222 'compiler-condition
223 :original-condition condition
224 :severity (etypecase condition
225 (sb-c:compiler-error :error)
226 (sb-ext:compiler-note :note)
227 (style-warning :style-warning)
228 (warning :warning)
229 (error :error))
230 :short-message (brief-compiler-message-for-emacs condition)
231 :references
232 ;; FIXME: delete the reader conditionaloid after sbcl
233 ;; 0.8.13 is released.
234 #+#.(cl:if (cl:find-symbol "ENCAPSULATED-CONDITION" "SB-INT")
235 '(and) '(or))
236 (let ((c (if (typep condition 'sb-int:encapsulated-condition)
237 (sb-int:encapsulated-condition condition)
238 condition)))
239 (when (typep c 'sb-int:reference-condition)
240 (sb-int:reference-condition-references c)))
241 #-#.(cl:if (cl:find-symbol "ENCAPSULATED-CONDITION" "SB-INT")
242 '(and) '(or))
243 (when (typep condition 'sb-int:reference-condition)
244 (sb-int:reference-condition-references condition))
245 :message (long-compiler-message-for-emacs condition context)
246 :location (compiler-note-location context))))
247
248 (defun compiler-note-location (context)
249 (cond (context
250 (resolve-note-location
251 *buffer-name*
252 (sb-c::compiler-error-context-file-name context)
253 (sb-c::compiler-error-context-file-position context)
254 (current-compiler-error-source-path context)
255 (sb-c::compiler-error-context-original-source context)))
256 (t
257 (resolve-note-location *buffer-name* nil nil nil nil))))
258
259 (defgeneric resolve-note-location (buffer file-name file-position
260 source-path source))
261
262 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
263 (make-location
264 `(:file ,(namestring (truename f)))
265 `(:position ,(1+ (source-path-file-position path f)))))
266
267 ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here
268 (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)
269 ;; Remove the surrounding lambda from the path (was added by
270 ;; swank-compile-string)
271 (destructuring-bind (_ form &rest rest) path
272 (declare (ignore _))
273 (make-location
274 `(:buffer ,b)
275 `(:position ,(+ *buffer-offset*
276 (source-path-string-position (list* (- form 2) rest)
277 *buffer-substring*))))))
278
279 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
280 (make-location
281 `(:source-form ,source)
282 `(:position 1)))
283
284 (defmethod resolve-note-location (buffer
285 (file (eql nil))
286 (pos (eql nil))
287 (path (eql nil))
288 (source (eql nil)))
289 (list :error "No error location available"))
290
291 (defun brief-compiler-message-for-emacs (condition)
292 "Briefly describe a compiler error for Emacs.
293 When Emacs presents the message it already has the source popped up
294 and the source form highlighted. This makes much of the information in
295 the error-context redundant."
296 (let ((sb-int:*print-condition-references* nil))
297 (princ-to-string condition)))
298
299 (defun long-compiler-message-for-emacs (condition error-context)
300 "Describe a compiler error for Emacs including context information."
301 (declare (type (or sb-c::compiler-error-context null) error-context))
302 (multiple-value-bind (enclosing source)
303 (if error-context
304 (values (sb-c::compiler-error-context-enclosing-source error-context)
305 (sb-c::compiler-error-context-source error-context)))
306 (let ((sb-int:*print-condition-references* nil))
307 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
308 enclosing source condition))))
309
310 (defun current-compiler-error-source-path (context)
311 "Return the source-path for the current compiler error.
312 Returns NIL if this cannot be determined by examining internal
313 compiler state."
314 (cond ((sb-c::node-p context)
315 (reverse
316 (sb-c::source-path-original-source
317 (sb-c::node-source-path context))))
318 ((sb-c::compiler-error-context-p context)
319 (reverse
320 (sb-c::compiler-error-context-original-source-path context)))))
321
322 (defimplementation call-with-compilation-hooks (function)
323 (declare (type function function))
324 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
325 (sb-c:compiler-error #'handle-notification-condition)
326 (sb-ext:compiler-note #'handle-notification-condition)
327 (style-warning #'handle-notification-condition)
328 (warning #'handle-notification-condition))
329 (funcall function)))
330
331 (defun handle-file-compiler-termination (condition)
332 "Handle a condition that caused the file compiler to terminate."
333 (handle-notification-condition
334 (sb-int:encapsulated-condition condition)))
335
336 (defvar *trap-load-time-warnings* nil)
337
338 (defimplementation swank-compile-file (filename load-p)
339 (handler-case
340 (let ((output-file (with-compilation-hooks ()
341 (compile-file filename))))
342 (when (and load-p output-file)
343 (load output-file)))
344 (sb-c:fatal-compiler-error () nil)))
345
346 (defimplementation swank-compile-string (string &key buffer position directory)
347 (declare (ignore directory))
348 (let ((form (read-from-string (format nil "(~S () ~A)" 'lambda string))))
349 (flet ((compileit (cont)
350 (with-compilation-hooks ()
351 (let ((*buffer-name* buffer)
352 (*buffer-offset* position)
353 (*buffer-substring* string))
354 (funcall cont (compile nil form))))))
355 (cond (*trap-load-time-warnings*
356 (compileit #'funcall))
357 (t
358 (funcall (compileit #'identity)))))))
359
360 ;;;; Definitions
361
362 (defvar *debug-definition-finding* nil
363 "When true don't handle errors while looking for definitions.
364 This is useful when debugging the definition-finding code.")
365
366 ;;; FIXME we don't handle the compiled-interactively case yet. That
367 ;;; should have NIL :filename & :position, and non-NIL :source-form
368 (defun function-source-location (function &optional name)
369 "Try to find the canonical source location of FUNCTION."
370 (let* ((def (sb-introspect:find-definition-source function))
371 (pathname (sb-introspect:definition-source-pathname def))
372 (path (sb-introspect:definition-source-form-path def))
373 (position (sb-introspect:definition-source-character-offset def)))
374 (unless pathname
375 (return-from function-source-location
376 (list :error (format nil "No filename for: ~S" function))))
377 (multiple-value-bind (truename condition)
378 (ignore-errors (truename pathname))
379 (when condition
380 (return-from function-source-location
381 (list :error (format nil "~A" condition))))
382 (make-location
383 (list :file (namestring truename))
384 ;; source-paths depend on the file having been compiled with
385 ;; lotsa debugging. If not present, return the function name
386 ;; for emacs to attempt to find with a regex
387 (cond (path (list :source-path path position))
388 (t (list :function-name
389 (or (and name (string name))
390 (string (sb-kernel:%fun-name function))))))))))
391
392 (defun safe-function-source-location (fun name)
393 (if *debug-definition-finding*
394 (function-source-location fun name)
395 (handler-case (function-source-location fun name)
396 (error (e)
397 (list (list :error (format nil "Error: ~A" e)))))))
398
399 (defun method-definitions (gf)
400 (let ((methods (sb-mop:generic-function-methods gf))
401 (name (sb-mop:generic-function-name gf)))
402 (loop for method in methods
403 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
404 (safe-function-source-location method name)))))
405
406 (defun function-definitions (name)
407 (flet ((loc (fn name) (safe-function-source-location fn name)))
408 (cond ((and (symbolp name) (macro-function name))
409 (list (list `(defmacro ,name)
410 (loc (macro-function name) name))))
411 ((fboundp name)
412 (let ((fn (fdefinition name)))
413 (typecase fn
414 (generic-function
415 (cons (list `(defgeneric ,name) (loc fn name))
416 (method-definitions fn)))
417 (t
418 (list (list `(function ,name) (loc fn name))))))))))
419
420 (defimplementation find-definitions (name)
421 (function-definitions name))
422
423 (defimplementation describe-symbol-for-emacs (symbol)
424 "Return a plist describing SYMBOL.
425 Return NIL if the symbol is unbound."
426 (let ((result '()))
427 (labels ((doc (kind)
428 (or (documentation symbol kind) :not-documented))
429 (maybe-push (property value)
430 (when value
431 (setf result (list* property value result)))))
432 (maybe-push
433 :variable (multiple-value-bind (kind recorded-p)
434 (sb-int:info :variable :kind symbol)
435 (declare (ignore kind))
436 (if (or (boundp symbol) recorded-p)
437 (doc 'variable))))
438 (maybe-push
439 :function (if (fboundp symbol)
440 (doc 'function)))
441 (maybe-push
442 :setf (if (or (sb-int:info :setf :inverse symbol)
443 (sb-int:info :setf :expander symbol))
444 (doc 'setf)))
445 (maybe-push
446 :type (if (sb-int:info :type :kind symbol)
447 (doc 'type)))
448 result)))
449
450 (defimplementation describe-definition (symbol type)
451 (case type
452 (:variable
453 (describe symbol))
454 (:function
455 (describe (symbol-function symbol)))
456 (:setf
457 (describe (or (sb-int:info :setf :inverse symbol)
458 (sb-int:info :setf :expander symbol))))
459 (:class
460 (describe (find-class symbol)))
461 (:type
462 (describe (sb-kernel:values-specifier-type symbol)))))
463
464 (defun function-dspec (fn)
465 "Describe where the function FN was defined.
466 Return a list of the form (NAME LOCATION)."
467 (let ((name (sb-kernel:%fun-name fn)))
468 (list name (safe-function-source-location fn name))))
469
470 (defimplementation list-callers (symbol)
471 (let ((fn (fdefinition symbol)))
472 (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
473
474 (defimplementation list-callees (symbol)
475 (let ((fn (fdefinition symbol)))
476 (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
477
478 ;;; macroexpansion
479
480 (defimplementation macroexpand-all (form)
481 (let ((sb-walker:*walk-form-expand-macros-p* t))
482 (sb-walker:walk-form form)))
483
484
485 ;;; Debugging
486
487 (defvar *sldb-stack-top*)
488
489 (defimplementation call-with-debugging-environment (debugger-loop-fn)
490 (declare (type function debugger-loop-fn))
491 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
492 (sb-debug:*stack-top-hint* nil))
493 (handler-bind ((sb-di:debug-condition
494 (lambda (condition)
495 (signal (make-condition
496 'sldb-condition
497 :original-condition condition)))))
498 (funcall debugger-loop-fn))))
499
500 (defun nth-frame (index)
501 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
502 (i index (1- i)))
503 ((zerop i) frame)))
504
505 (defimplementation compute-backtrace (start end)
506 "Return a list of frames starting with frame number START and
507 continuing to frame number END or, if END is nil, the last frame on the
508 stack."
509 (let ((end (or end most-positive-fixnum)))
510 (loop for f = (nth-frame start) then (sb-di:frame-down f)
511 for i from start below end
512 while f
513 collect f)))
514
515 (defimplementation print-frame (frame stream)
516 (let ((*standard-output* stream))
517 (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
518
519 (defun code-location-source-path (code-location)
520 (let* ((location (sb-debug::maybe-block-start-location code-location))
521 (form-num (sb-di:code-location-form-number location)))
522 (let ((translations (sb-debug::get-toplevel-form location)))
523 (unless (< form-num (length translations))
524 (error "Source path no longer exists."))
525 (reverse (cdr (svref translations form-num))))))
526
527 (defun code-location-file-position (code-location)
528 (let* ((debug-source (sb-di:code-location-debug-source code-location))
529 (filename (sb-di:debug-source-name debug-source))
530 (path (code-location-source-path code-location)))
531 (source-path-file-position path filename)))
532
533 ;;; source-path-file-position and friends are in swank-source-path-parser
534
535 (defun debug-source-info-from-emacs-buffer-p (debug-source)
536 (let ((info (sb-c::debug-source-info debug-source)))
537 (and info
538 (consp info)
539 (eq :emacs-buffer (car info)))))
540
541 (defun source-location-for-emacs (code-location)
542 (let* ((debug-source (sb-di:code-location-debug-source code-location))
543 (from (sb-di:debug-source-from debug-source))
544 (name (sb-di:debug-source-name debug-source)))
545 (ecase from
546 (:file
547 (let ((source-path (ignore-errors
548 (code-location-source-path code-location))))
549 (cond (source-path
550 ;; XXX: code-location-source-path reads the source !!
551 (let ((position (code-location-file-position code-location)))
552 (make-location
553 (list :file (namestring (truename name)))
554 (list :source-path source-path position))))
555 (t
556 (let* ((dfn (sb-di:code-location-debug-fun code-location))
557 (fn (sb-di:debug-fun-fun dfn)))
558 (unless fn
559 (error "Cannot find source location for: ~A "
560 code-location))
561 (function-source-location
562 fn (sb-di:debug-fun-name dfn)))))))
563
564 (:lisp
565 (make-location
566 (list :source-form (with-output-to-string (*standard-output*)
567 (sb-debug::print-code-location-source-form
568 code-location 100)))
569 (list :position 0))))))
570
571 (defun safe-source-location-for-emacs (code-location)
572 (handler-case (source-location-for-emacs code-location)
573 (error (c) (list :error (format nil "~A" c)))))
574
575 (defimplementation frame-source-location-for-emacs (index)
576 (safe-source-location-for-emacs
577 (sb-di:frame-code-location (nth-frame index))))
578
579 (defun frame-debug-vars (frame)
580 "Return a vector of debug-variables in frame."
581 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
582
583 (defun debug-var-value (var frame location)
584 (ecase (sb-di:debug-var-validity var location)
585 (:valid (sb-di:debug-var-value var frame))
586 ((:invalid :unknown) ':<not-available>)))
587
588 (defimplementation frame-locals (index)
589 (let* ((frame (nth-frame index))
590 (loc (sb-di:frame-code-location frame))
591 (vars (frame-debug-vars frame)))
592 (loop for v across vars collect
593 (list :name (sb-di:debug-var-symbol v)
594 :id (sb-di:debug-var-id v)
595 :value (debug-var-value v frame loc)))))
596
597 (defimplementation frame-var-value (frame var)
598 (let* ((frame (nth-frame frame))
599 (dvar (aref (frame-debug-vars frame) var)))
600 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
601
602 (defimplementation frame-catch-tags (index)
603 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
604
605 (defimplementation eval-in-frame (form index)
606 (let ((frame (nth-frame index)))
607 (funcall (the function
608 (sb-di:preprocess-for-eval form
609 (sb-di:frame-code-location frame)))
610 frame)))
611
612 (defun sb-debug-catch-tag-p (tag)
613 (and (symbolp tag)
614 (not (symbol-package tag))
615 (string= tag :sb-debug-catch-tag)))
616
617 (defimplementation return-from-frame (index form)
618 (let* ((frame (nth-frame index))
619 (probe (assoc-if #'sb-debug-catch-tag-p
620 (sb-di::frame-catches frame))))
621 (cond (probe (throw (car probe) (eval-in-frame form index)))
622 (t (format nil "Cannot return from frame: ~S" frame)))))
623
624 ;;;;; reference-conditions
625
626 (defimplementation format-sldb-condition (condition)
627 (let ((sb-int:*print-condition-references* nil))
628 (princ-to-string condition)))
629
630 (defimplementation condition-references (condition)
631 (if (typep condition 'sb-int:reference-condition)
632 (sb-int:reference-condition-references condition)
633 '()))
634
635
636 ;;;; Profiling
637
638 (defimplementation profile (fname)
639 (when fname (eval `(sb-profile:profile ,fname))))
640
641 (defimplementation unprofile (fname)
642 (when fname (eval `(sb-profile:unprofile ,fname))))
643
644 (defimplementation unprofile-all ()
645 (sb-profile:unprofile)
646 "All functions unprofiled.")
647
648 (defimplementation profile-report ()
649 (sb-profile:report))
650
651 (defimplementation profile-reset ()
652 (sb-profile:reset)
653 "Reset profiling counters.")
654
655 (defimplementation profiled-functions ()
656 (sb-profile:profile))
657
658
659 ;;;; Inspector
660
661 (defclass sbcl-inspector (inspector)
662 ())
663
664 (defimplementation make-default-inspector ()
665 (make-instance 'sbcl-inspector))
666
667 (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
668 (declare (ignore inspector))
669 (cond ((sb-di::indirect-value-cell-p o)
670 (values "A value cell."
671 `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))
672 (t
673 (multiple-value-bind (text labeledp parts)
674 (sb-impl::inspected-parts o)
675 (if labeledp
676 (values text
677 (loop for (label . value) in parts
678 collect `(:value ,label)
679 collect " = "
680 collect `(:value ,value)
681 collect '(:newline)))
682 (values text
683 (loop for value in parts
684 for i from 0
685 collect (princ-to-string i)
686 collect " = "
687 collect `(:value ,value)
688 collect '(:newline))))))))
689
690 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
691 (declare (ignore inspector))
692 (let ((header (sb-kernel:widetag-of o)))
693 (cond ((= header sb-vm:simple-fun-header-widetag)
694 (values "A simple-fun."
695 `("Name: " (:value ,(sb-kernel:%simple-fun-name o))
696 (:newline)
697 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
698 (:newline)
699 ,@(when (documentation o t)
700 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
701 "Self: " (:value ,(sb-kernel:%simple-fun-self o))
702 (:newline)
703 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
704 (:newline)
705 "Type: " (:value ,(sb-kernel:%simple-fun-type o))
706 (:newline)
707 "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
708 ((= header sb-vm:closure-header-widetag)
709 (values "A closure."
710 `("Function: " (:value ,(sb-kernel:%closure-fun o))
711 (:newline)
712 ,@(when (documentation o t)
713 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
714 "Closed over values:"
715 (:newline)
716 ,@(loop for i from 0
717 below (- (sb-kernel:get-closure-length o)
718 (1- sb-vm:closure-info-offset))
719 collect (princ-to-string i)
720 collect " = "
721 collect `(:value ,(sb-kernel:%closure-index-ref o i))
722 collect '(:newline)))))
723 (t (call-next-method o)))))
724
725 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (inspector sbcl-inspector))
726 (declare (ignore inspector))
727 (values "A code data-block."
728 `("First entry point: " (:value ,(sb-kernel:%code-entry-points o))
729 (:newline)
730 "Constants: " (:newline)
731 ,@(loop
732 for i from sb-vm:code-constants-offset
733 below (sb-kernel:get-header-data o)
734 collect (princ-to-string i)
735 collect " = "
736 collect `(:value ,(sb-kernel:code-header-ref o i))
737 collect '(:newline))
738 "Debug info: " (:value ,(sb-kernel:%code-debug-info o))
739 "Instructions: " (:value ,(sb-kernel:code-instructions o)))))
740
741 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
742 (declare (ignore sbcl-inspector))
743 (values "A fdefn object."
744 `("Name: " (:value ,(sb-kernel:fdefn-name o))
745 (:newline)
746 "Function" (:value,(sb-kernel:fdefn-fun o))
747 (:newline)
748 ,@(when (documentation o t)
749 `("Documentation: " (:newline) ,(documentation o t) (:newline))))))
750
751 (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))
752 (declare (ignore inspector))
753 (multiple-value-bind (title contents)
754 (call-next-method)
755 (values title
756 (append contents
757 `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))
758 (:newline)
759 "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods o)))))))
760
761
762 ;;;; Support for SBCL syntax
763
764 (defun feature-in-list-p (feature list)
765 (etypecase feature
766 (symbol (member feature list :test #'eq))
767 (cons (flet ((subfeature-in-list-p (subfeature)
768 (feature-in-list-p subfeature list)))
769 (ecase (first feature)
770 (:or (some #'subfeature-in-list-p (rest feature)))
771 (:and (every #'subfeature-in-list-p (rest feature)))
772 (:not (let ((rest (cdr feature)))
773 (if (or (null (car rest)) (cdr rest))
774 (error "wrong number of terms in compound feature ~S"
775 feature)
776 (not (subfeature-in-list-p (second feature)))))))))))
777
778 (defun shebang-reader (stream sub-character infix-parameter)
779 (declare (ignore sub-character))
780 (when infix-parameter
781 (error "illegal read syntax: #~D!" infix-parameter))
782 (let ((next-char (read-char stream)))
783 (unless (find next-char "+-")
784 (error "illegal read syntax: #!~C" next-char))
785 ;; When test is not satisfied
786 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
787 ;; would become "unless test is satisfied"..
788 (when (let* ((*package* (find-package "KEYWORD"))
789 (*read-suppress* nil)
790 (not-p (char= next-char #\-))
791 (feature (read stream)))
792 (if (feature-in-list-p feature *features*)
793 not-p
794 (not not-p)))
795 ;; Read (and discard) a form from input.
796 (let ((*read-suppress* t))
797 (read stream t nil t))))
798 (values))
799
800 (defvar *shebang-readtable*
801 (let ((*readtable* (copy-readtable nil)))
802 (set-dispatch-macro-character #\# #\!
803 (lambda (s c n) (shebang-reader s c n))
804 *readtable*)
805 *readtable*))
806
807 (defun shebang-readtable ()
808 *shebang-readtable*)
809
810 (defun sbcl-package-p (package)
811 (let ((name (package-name package)))
812 (eql (mismatch "SB-" name) 3)))
813
814 (defvar *debootstrap-packages* t)
815
816 (defmacro with-debootstrapping (&body body)
817 (let ((not-found (find-symbol "BOOTSTRAP-PACKAGE-NOT-FOUND" "SB-INT"))
818 (debootstrap (find-symbol "DEBOOTSTRAP-PACKAGE" "SB-INT")))
819 (if (and not-found debootstrap)
820 `(handler-bind ((,not-found #',debootstrap)) ,@body)
821 `(progn ,@body))))
822
823 (defimplementation call-with-syntax-hooks (fn)
824 (cond ((and *debootstrap-packages*
825 (sbcl-package-p *package*))
826 (with-debootstrapping (funcall fn)))
827 (t
828 (funcall fn))))
829
830 (defimplementation default-readtable-alist ()
831 (let ((readtable (shebang-readtable)))
832 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
833 collect (cons (package-name p) readtable))))
834
835
836 ;;;; Multiprocessing
837
838 #+sb-thread
839 (progn
840 (defimplementation spawn (fn &key name)
841 (declare (ignore name))
842 (sb-thread:make-thread fn))
843
844 (defimplementation startup-multiprocessing ())
845
846 (defimplementation thread-id (thread)
847 thread)
848
849 (defimplementation find-thread (id)
850 (if (member id (all-threads))
851 id))
852
853 (defimplementation thread-name (thread)
854 (format nil "Thread ~D" thread))
855
856 (defimplementation thread-status (thread)
857 (declare (ignore thread))
858 "???")
859
860 (defimplementation make-lock (&key name)
861 (sb-thread:make-mutex :name name))
862
863 (defimplementation call-with-lock-held (lock function)
864 (declare (type function function))
865 (sb-thread:with-mutex (lock) (funcall function)))
866
867 (defimplementation current-thread ()
868 (sb-thread:current-thread-id))
869
870 (defimplementation all-threads ()
871 (sb-thread::mapcar-threads
872 (lambda (sap)
873 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
874 sb-vm::thread-pid-slot)))))
875
876 (defimplementation interrupt-thread (thread fn)
877 (sb-thread:interrupt-thread thread fn))
878
879 (defimplementation kill-thread (thread)
880 (sb-thread:terminate-thread thread))
881
882 ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
883
884 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
885 (defvar *mailboxes* (list))
886 (declaim (type list *mailboxes*))
887
888 (defstruct (mailbox (:conc-name mailbox.))
889 thread
890 (mutex (sb-thread:make-mutex))
891 (waitqueue (sb-thread:make-waitqueue))
892 (queue '() :type list))
893
894 (defun mailbox (thread)
895 "Return THREAD's mailbox."
896 (sb-thread:with-mutex (*mailbox-lock*)
897 (or (find thread *mailboxes* :key #'mailbox.thread)
898 (let ((mb (make-mailbox :thread thread)))
899 (push mb *mailboxes*)
900 mb))))
901
902 (defimplementation send (thread message)
903 (let* ((mbox (mailbox thread))
904 (mutex (mailbox.mutex mbox)))
905 (sb-thread:with-mutex (mutex)
906 (setf (mailbox.queue mbox)
907 (nconc (mailbox.queue mbox) (list message)))
908 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
909
910 (defimplementation receive ()
911 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
912 (mutex (mailbox.mutex mbox)))
913 (sb-thread:with-mutex (mutex)
914 (loop
915 (let ((q (mailbox.queue mbox)))
916 (cond (q (return (pop (mailbox.queue mbox))))
917 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
918 mutex))))))))
919
920 )

  ViewVC Help
Powered by ViewVC 1.1.5