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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5