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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5