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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.96 - (hide 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 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 lgorrie 1.96 (warning :warning)
180     (error :error))
181 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
182 crhodes 1.95 :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 heller 1.66 :message (long-compiler-message-for-emacs condition context)
197 lgorrie 1.24 :location (compiler-note-location context))))
198    
199     (defun compiler-note-location (context)
200 dbarlow 1.42 (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 dbarlow 1.43 `(:file ,(namestring (truename f)))
216 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
217    
218 heller 1.85 #+(or)
219 dbarlow 1.42 (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 heller 1.85 ;; 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 heller 1.88 ;; Remove the surrounding lambda from the path (was added by
228 heller 1.85 ;; 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 dbarlow 1.42 (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 heller 1.82 (list :error "No error location available"))
248 dbarlow 1.42
249 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
250 dbarlow 1.1 "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 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
255     (princ-to-string condition)))
256 heller 1.66
257     (defun long-compiler-message-for-emacs (condition error-context)
258     "Describe a compiler error for Emacs including context information."
259 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
260 heller 1.66 (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 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
265     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
266     enclosing source condition))))
267 dbarlow 1.1
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 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
281 heller 1.58 (declare (type function function))
282 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
283     (sb-c:compiler-error #'handle-notification-condition)
284 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
285     (style-warning #'handle-notification-condition)
286     (warning #'handle-notification-condition))
287     (funcall function)))
288 lgorrie 1.24
289 lgorrie 1.96 (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 heller 1.91 (defvar *trap-load-time-warnings* nil)
295    
296 heller 1.74 (defimplementation swank-compile-file (filename load-p)
297 lgorrie 1.96 (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 lgorrie 1.24
304 heller 1.74 (defimplementation swank-compile-string (string &key buffer position)
305 heller 1.91 (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 dbarlow 1.1
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 heller 1.36 (defun function-source-location (function &optional name)
326 dbarlow 1.1 "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 heller 1.32 (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 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
334 heller 1.32 (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 heller 1.36 (t (list :function-name
346     (or (and name (string name))
347 heller 1.74 (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 heller 1.75 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
361 heller 1.74 (safe-function-source-location method name)))))
362    
363 heller 1.81 (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 heller 1.74
377 heller 1.81 (defimplementation find-definitions (name)
378     (function-definitions name))
379 lgorrie 1.24
380 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
381 dbarlow 1.1 "Return a plist describing SYMBOL.
382     Return NIL if the symbol is unbound."
383     (let ((result '()))
384 lgorrie 1.24 (labels ((doc (kind)
385     (or (documentation symbol kind) :not-documented))
386 dbarlow 1.1 (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 lgorrie 1.24 result)))
406 dbarlow 1.1
407 heller 1.74 (defimplementation describe-definition (symbol type)
408 lgorrie 1.54 (case type
409     (:variable
410 heller 1.74 (describe symbol))
411     (:function
412     (describe (symbol-function symbol)))
413 lgorrie 1.54 (:setf
414 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
415     (sb-int:info :setf :expander symbol))))
416 lgorrie 1.54 (:class
417 heller 1.74 (describe (find-class symbol)))
418 lgorrie 1.54 (:type
419 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
420 dbarlow 1.1
421 dbarlow 1.4 ;;; macroexpansion
422 dbarlow 1.1
423 lgorrie 1.54 (defimplementation macroexpand-all (form)
424 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
425     (sb-walker:walk-form form)))
426 lgorrie 1.25
427 dbarlow 1.1
428     ;;; Debugging
429    
430     (defvar *sldb-stack-top*)
431    
432 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
433 heller 1.58 (declare (type function debugger-loop-fn))
434 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
435 heller 1.71 (sb-debug:*stack-top-hint* nil))
436 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
437     (lambda (condition)
438 lgorrie 1.25 (signal (make-condition
439     'sldb-condition
440     :original-condition condition)))))
441     (funcall debugger-loop-fn))))
442 dbarlow 1.1
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 heller 1.74 (defimplementation compute-backtrace (start end)
449 dbarlow 1.1 "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 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
454     for i from start below end
455     while f
456 heller 1.74 collect f)))
457 dbarlow 1.1
458 heller 1.74 (defimplementation print-frame (frame stream)
459     (let ((*standard-output* stream))
460     (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
461 dbarlow 1.1
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 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
477 dbarlow 1.1
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 heller 1.32 (ecase from
489     (:file
490 heller 1.36 (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 heller 1.32 (: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 dbarlow 1.1
514     (defun safe-source-location-for-emacs (code-location)
515     (handler-case (source-location-for-emacs code-location)
516 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
517    
518 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
519 heller 1.22 (safe-source-location-for-emacs
520     (sb-di:frame-code-location (nth-frame index))))
521 dbarlow 1.1
522 heller 1.92 (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 lgorrie 1.54 (defimplementation frame-locals (index)
532 dbarlow 1.1 (let* ((frame (nth-frame index))
533 heller 1.92 (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 dbarlow 1.1
545 lgorrie 1.54 (defimplementation frame-catch-tags (index)
546 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
547 lgorrie 1.50
548 heller 1.56 (defimplementation eval-in-frame (form index)
549     (let ((frame (nth-frame index)))
550 heller 1.58 (funcall (the function
551     (sb-di:preprocess-for-eval form
552     (sb-di:frame-code-location frame)))
553 heller 1.56 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 lgorrie 1.87 ;;;;; 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 heller 1.57
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 heller 1.64 ;;;; Inspector
603 heller 1.63
604 heller 1.64 (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 heller 1.88
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 heller 1.92 (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 heller 1.88 (defimplementation call-with-syntax-hooks (fn)
740 heller 1.89 (cond ((and *debootstrap-packages*
741 heller 1.88 (sbcl-package-p *package*))
742 heller 1.92 (with-debootstrapping (funcall fn)))
743 heller 1.88 (t
744     (funcall fn))))
745 heller 1.63
746 heller 1.90 (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 heller 1.63
752 lgorrie 1.50 ;;;; Multiprocessing
753    
754 heller 1.81 #+sb-thread
755 lgorrie 1.50 (progn
756 lgorrie 1.54 (defimplementation spawn (fn &key name)
757 lgorrie 1.50 (declare (ignore name))
758     (sb-thread:make-thread fn))
759    
760 heller 1.85 (defimplementation startup-multiprocessing ())
761 lgorrie 1.50
762 heller 1.93 (defimplementation thread-id (thread)
763     thread)
764    
765     (defimplementation find-thread (id)
766     (if (member id (all-threads))
767     id))
768    
769 heller 1.63 (defimplementation thread-name (thread)
770     (format nil "Thread ~D" thread))
771 lgorrie 1.50
772 heller 1.63 (defimplementation thread-status (thread)
773     (declare (ignore thread))
774     "???")
775 lgorrie 1.50
776 lgorrie 1.54 (defimplementation make-lock (&key name)
777 lgorrie 1.50 (sb-thread:make-mutex :name name))
778    
779 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
780 heller 1.58 (declare (type function function))
781 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
782 heller 1.59
783     (defimplementation current-thread ()
784     (sb-thread:current-thread-id))
785    
786 heller 1.63 (defimplementation all-threads ()
787 heller 1.59 (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 heller 1.70 (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 heller 1.59
800     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
801     (defvar *mailboxes* (list))
802 heller 1.60 (declaim (type list *mailboxes*))
803 heller 1.59
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