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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5