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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5