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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5