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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5