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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5