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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.102 - (show annotations)
Tue Sep 14 16:01:06 2004 UTC (9 years, 7 months ago) by mbaringer
Branch: MAIN
Changes since 1.101: +80 -60 lines
2004-09-14  Marco Baringer  <mb@bese.it>

	* swank-backend.lisp (inspector, make-default-inspector): Add an
	INSPECTOR object argument to the inspector protocol. This allows
	implementations to provide more information regarding cretain
	objects which can't be, or simply aren't, inspected using the
	generic inspector implementation. also export inspect-for-emacs
	and related symbols from the backend package.
	(make-default-inspector): New function.

	* swank.lisp (inspected-parts): Rename to inspect-for-emacs and
	add an inspector argument. Move inspect-for-emacs to
	swank-backend.lisp, leave only the default implementations.

	* swank-openml.lisp, swank-sbcl.lisp, swank-allegro.lisp,
	swank-cmucl.lisp, swank-lispworks.lisp (inspected-parts): Rename
	and change argument list. Many of the inspected-parts methods were
	being clobbered by the inspected-parts in swank.lisp, now that
	they're being used the return values have been updated for the new
	inspect-for-emacs API.
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 `("Self: " (:value ,(sb-kernel:%simple-fun-self o))
696 (:newline)
697 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
698 (:newline)
699 "Name: " (:value ,(sb-kernel:%simple-fun-name o))
700 (:newline)
701 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
702 (:newline)
703 "Type: " (:value ,(sb-kernel:%simple-fun-type o))
704 (:newline)
705 "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
706 ((= header sb-vm:closure-header-widetag)
707 (values "A closure."
708 `("Function: " (:value ,(sb-kernel:%closure-fun o))
709 (:newline)
710 "Closed over values:"
711 (:newline)
712 ,@(loop for i from 0
713 below (- (sb-kernel:get-closure-length o)
714 (1- sb-vm:closure-info-offset))
715 collect (princ-to-string i)
716 collect " = "
717 collect `(:value ,(sb-kernel:%closure-index-ref o i))
718 collect '(:newline)))))
719 (t (call-next-method o)))))
720
721 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (inspector sbcl-inspector))
722 (declare (ignore inspector))
723 (values "A code data-block."
724 `("First entry point: " (:value ,(sb-kernel:%code-entry-points o))
725 (:newline)
726 "Constants: " (:newline)
727 ,@(loop
728 for i from sb-vm:code-constants-offset
729 below (sb-kernel:get-header-data o)
730 collect (princ-to-string i)
731 collect " = "
732 collect `(:value ,(sb-kernel:code-header-ref o i))
733 collect '(:newline))
734 "Debug info: " (:value ,(sb-kernel:%code-debug-info o))
735 "Instructions: " (:value ,(sb-kernel:code-instructions o)))))
736
737 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
738 (declare (ignore sbcl-inspector))
739 (values "A fdefn object."
740 `("Name: " (:value ,(sb-kernel:fdefn-name o))
741 (:newline)
742 "Function" (:value,(sb-kernel:fdefn-fun o)))))
743
744 (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))
745 (declare (ignore inspector))
746 (multiple-value-bind (title contents)
747 (call-next-method)
748 (values title
749 (append contents
750 `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))
751 (:newline)
752 "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods o)))))))
753
754
755 ;;;; Support for SBCL syntax
756
757 (defun feature-in-list-p (feature list)
758 (etypecase feature
759 (symbol (member feature list :test #'eq))
760 (cons (flet ((subfeature-in-list-p (subfeature)
761 (feature-in-list-p subfeature list)))
762 (ecase (first feature)
763 (:or (some #'subfeature-in-list-p (rest feature)))
764 (:and (every #'subfeature-in-list-p (rest feature)))
765 (:not (let ((rest (cdr feature)))
766 (if (or (null (car rest)) (cdr rest))
767 (error "wrong number of terms in compound feature ~S"
768 feature)
769 (not (subfeature-in-list-p (second feature)))))))))))
770
771 (defun shebang-reader (stream sub-character infix-parameter)
772 (declare (ignore sub-character))
773 (when infix-parameter
774 (error "illegal read syntax: #~D!" infix-parameter))
775 (let ((next-char (read-char stream)))
776 (unless (find next-char "+-")
777 (error "illegal read syntax: #!~C" next-char))
778 ;; When test is not satisfied
779 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
780 ;; would become "unless test is satisfied"..
781 (when (let* ((*package* (find-package "KEYWORD"))
782 (*read-suppress* nil)
783 (not-p (char= next-char #\-))
784 (feature (read stream)))
785 (if (feature-in-list-p feature *features*)
786 not-p
787 (not not-p)))
788 ;; Read (and discard) a form from input.
789 (let ((*read-suppress* t))
790 (read stream t nil t))))
791 (values))
792
793 (defvar *shebang-readtable*
794 (let ((*readtable* (copy-readtable nil)))
795 (set-dispatch-macro-character #\# #\!
796 (lambda (s c n) (shebang-reader s c n))
797 *readtable*)
798 *readtable*))
799
800 (defun shebang-readtable ()
801 *shebang-readtable*)
802
803 (defun sbcl-package-p (package)
804 (let ((name (package-name package)))
805 (eql (mismatch "SB-" name) 3)))
806
807 (defvar *debootstrap-packages* t)
808
809 (defmacro with-debootstrapping (&body body)
810 (let ((not-found (find-symbol "BOOTSTRAP-PACKAGE-NOT-FOUND" "SB-INT"))
811 (debootstrap (find-symbol "DEBOOTSTRAP-PACKAGE" "SB-INT")))
812 (if (and not-found debootstrap)
813 `(handler-bind ((,not-found #',debootstrap)) ,@body)
814 `(progn ,@body))))
815
816 (defimplementation call-with-syntax-hooks (fn)
817 (cond ((and *debootstrap-packages*
818 (sbcl-package-p *package*))
819 (with-debootstrapping (funcall fn)))
820 (t
821 (funcall fn))))
822
823 (defimplementation default-readtable-alist ()
824 (let ((readtable (shebang-readtable)))
825 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
826 collect (cons (package-name p) readtable))))
827
828
829 ;;;; Multiprocessing
830
831 #+sb-thread
832 (progn
833 (defimplementation spawn (fn &key name)
834 (declare (ignore name))
835 (sb-thread:make-thread fn))
836
837 (defimplementation startup-multiprocessing ())
838
839 (defimplementation thread-id (thread)
840 thread)
841
842 (defimplementation find-thread (id)
843 (if (member id (all-threads))
844 id))
845
846 (defimplementation thread-name (thread)
847 (format nil "Thread ~D" thread))
848
849 (defimplementation thread-status (thread)
850 (declare (ignore thread))
851 "???")
852
853 (defimplementation make-lock (&key name)
854 (sb-thread:make-mutex :name name))
855
856 (defimplementation call-with-lock-held (lock function)
857 (declare (type function function))
858 (sb-thread:with-mutex (lock) (funcall function)))
859
860 (defimplementation current-thread ()
861 (sb-thread:current-thread-id))
862
863 (defimplementation all-threads ()
864 (sb-thread::mapcar-threads
865 (lambda (sap)
866 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
867 sb-vm::thread-pid-slot)))))
868
869 (defimplementation interrupt-thread (thread fn)
870 (sb-thread:interrupt-thread thread fn))
871
872 (defimplementation kill-thread (thread)
873 (sb-thread:terminate-thread thread))
874
875 ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
876
877 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
878 (defvar *mailboxes* (list))
879 (declaim (type list *mailboxes*))
880
881 (defstruct (mailbox (:conc-name mailbox.))
882 thread
883 (mutex (sb-thread:make-mutex))
884 (waitqueue (sb-thread:make-waitqueue))
885 (queue '() :type list))
886
887 (defun mailbox (thread)
888 "Return THREAD's mailbox."
889 (sb-thread:with-mutex (*mailbox-lock*)
890 (or (find thread *mailboxes* :key #'mailbox.thread)
891 (let ((mb (make-mailbox :thread thread)))
892 (push mb *mailboxes*)
893 mb))))
894
895 (defimplementation send (thread message)
896 (let* ((mbox (mailbox thread))
897 (mutex (mailbox.mutex mbox)))
898 (sb-thread:with-mutex (mutex)
899 (setf (mailbox.queue mbox)
900 (nconc (mailbox.queue mbox) (list message)))
901 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
902
903 (defimplementation receive ()
904 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
905 (mutex (mailbox.mutex mbox)))
906 (sb-thread:with-mutex (mutex)
907 (loop
908 (let ((q (mailbox.queue mbox)))
909 (cond (q (return (pop (mailbox.queue mbox))))
910 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
911 mutex))))))))
912
913 )

  ViewVC Help
Powered by ViewVC 1.1.5