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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5