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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5