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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5