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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (hide annotations)
Sun Nov 30 08:09:44 2003 UTC (10 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.29: +172 -125 lines
Use the format for source locations.
(find-function-locations): New function.  Replaces
function-source-location-for-emacs.  Returns a list of
source-locations.

(resolve-note-location): Renamed from resolve-location.  Simplified.
(brief-compiler-message-for-emacs): Print the source context (that's
the thing after ==>).

(who-xxxx): Take strings, not symbols, as arguments.
(function-callees, function-callers): Use the same format as the
who-xxx functions.  Support for byte-compiled stuff.

(code-location-stream-position): Try to be clever is the source path
doesn't match the form.

(call-with-debugging-environment): Bind *print-readably* to nil.
1 lgorrie 1.24 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2 dbarlow 1.1
3     (declaim (optimize debug))
4    
5     (in-package :swank)
6    
7 lgorrie 1.25 ;; Turn on xref. [should we?]
8     (setf c:*record-xref-info* t)
9    
10 heller 1.22 (defun without-interrupts* (body)
11     (sys:without-interrupts (funcall body)))
12    
13 dbarlow 1.1 (defun set-fd-non-blocking (fd)
14     (flet ((fcntl (fd cmd arg)
15     (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
16     (or flags
17     (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
18     (let ((flags (fcntl fd unix:F-GETFL 0)))
19     (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
20    
21 lgorrie 1.25
22     ;;;; TCP server.
23    
24 heller 1.28 (defun resolve-hostname (name)
25     (let* ((hostent (ext:lookup-host-entry name))
26     (address (car (ext:host-entry-addr-list hostent))))
27     (ext:htonl address)))
28    
29 lgorrie 1.25 (defun create-swank-server (port &key reuse-address (address "localhost"))
30     "Create a SWANK TCP server."
31 heller 1.28 (let* ((ip (resolve-hostname address))
32     (fd (ext:create-inet-listener port :stream
33     :reuse-address reuse-address
34     :host ip)))
35     (system:add-fd-handler fd :input #'accept-connection)
36     (nth-value 1 (ext::get-socket-host-and-port fd))))
37 lgorrie 1.25
38     (defun accept-connection (socket)
39     "Accept one Swank TCP connection on SOCKET and then close it."
40     (setup-request-handler (ext:accept-tcp-connection socket))
41     (sys:invalidate-descriptor socket)
42     (unix:unix-close socket))
43    
44 heller 1.28 (defun open-stream-to-emacs ()
45     "Return an output-stream to Emacs' output buffer."
46     (let* ((ip (resolve-hostname "localhost"))
47     (listener (ext:create-inet-listener 0 :stream :host ip))
48     (port (nth-value 1 (ext::get-socket-host-and-port listener))))
49     (unwind-protect
50     (progn
51     (eval-in-emacs `(slime-open-stream-to-lisp ,port))
52     (let ((fd (ext:accept-tcp-connection listener)))
53     (sys:make-fd-stream fd :output t)))
54     (ext:close-socket listener))))
55    
56     (defvar *use-dedicated-output-stream* t)
57    
58 lgorrie 1.25 (defun setup-request-handler (socket)
59     "Setup request handling for SOCKET."
60     (let* ((stream (sys:make-fd-stream socket
61     :input t :output t
62     :element-type 'base-char))
63     (input (make-slime-input-stream))
64 heller 1.28 (output (if *use-dedicated-output-stream*
65     (let ((*emacs-io* stream)) (open-stream-to-emacs))
66     (make-slime-output-stream)))
67 lgorrie 1.25 (io (make-two-way-stream input output)))
68     (system:add-fd-handler socket
69     :input (lambda (fd)
70     (declare (ignore fd))
71     (serve-request stream output input io)))))
72    
73     (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
74     "Read and process a request from a SWANK client.
75     The request is read from the socket as a sexp and then evaluated."
76     (catch 'slime-toplevel
77     (with-simple-restart (abort "Return to Slime toplevel.")
78     (handler-case (read-from-emacs)
79     (slime-read-error (e)
80     (when *swank-debug-p*
81     (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
82     (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
83     (close *emacs-io*)))))
84     (sys:scrub-control-stack))
85 dbarlow 1.1
86 lgorrie 1.25
87     ;;;; Stream handling
88 dbarlow 1.1
89     (defstruct (slime-output-stream
90 heller 1.16 (:include lisp::lisp-stream
91     (lisp::misc #'sos/misc)
92     (lisp::out #'sos/out)
93     (lisp::sout #'sos/sout))
94 heller 1.17 (:conc-name sos.)
95     (:print-function %print-slime-output-stream))
96 heller 1.16 (buffer (make-string 512) :type string)
97     (index 0 :type kernel:index)
98     (column 0 :type kernel:index))
99    
100 heller 1.17 (defun %print-slime-output-stream (s stream d)
101     (declare (ignore d))
102     (print-unreadable-object (s stream :type t :identity t)))
103    
104 heller 1.16 (defun sos/out (stream char)
105     (let ((buffer (sos.buffer stream))
106     (index (sos.index stream)))
107     (setf (schar buffer index) char)
108     (setf (sos.index stream) (1+ index))
109     (incf (sos.column stream))
110 heller 1.21 (when (char= #\newline char)
111     (setf (sos.column stream) 0))
112     (when (= index (1- (length buffer)))
113     (force-output stream)))
114 heller 1.16 char)
115    
116     (defun sos/sout (stream string start end)
117     (loop for i from start below end
118     do (sos/out stream (aref string i))))
119    
120     (defun sos/misc (stream operation &optional arg1 arg2)
121     (declare (ignore arg1 arg2))
122 dbarlow 1.1 (case operation
123 heller 1.17 ((:force-output :finish-output)
124 heller 1.16 (let ((end (sos.index stream)))
125     (unless (zerop end)
126     (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end)))
127     (setf (sos.index stream) 0))))
128     (:charpos (sos.column stream))
129     (:line-length 75)
130 dbarlow 1.1 (:file-position nil)
131 heller 1.16 (:element-type 'base-char)
132     (:get-command nil)
133 heller 1.22 (:close nil)
134 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
135 dbarlow 1.1
136 heller 1.9 (defstruct (slime-input-stream
137 heller 1.16 (:include string-stream
138     (lisp::in #'sis/in)
139     (lisp::misc #'sis/misc))
140 heller 1.17 (:conc-name sis.)
141     (:print-function %print-slime-output-stream))
142 heller 1.16 (buffer "" :type string)
143     (index 0 :type kernel:index))
144    
145     (defun sis/in (stream eof-errorp eof-value)
146 heller 1.18 (declare (ignore eof-errorp eof-value))
147 heller 1.16 (let ((index (sis.index stream))
148     (buffer (sis.buffer stream)))
149     (when (= index (length buffer))
150     (setf buffer (slime-read-string))
151     (setf (sis.buffer stream) buffer)
152     (setf index 0))
153     (prog1 (aref buffer index)
154     (setf (sis.index stream) (1+ index)))))
155 heller 1.9
156 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
157 heller 1.14 (declare (ignore arg2))
158 heller 1.15 (ecase operation
159     (:file-position nil)
160 heller 1.16 (:file-length nil)
161     (:unread (setf (aref (sis.buffer stream)
162     (decf (sis.index stream)))
163     arg1))
164     (:clear-input (setf (sis.index stream) 0
165     (sis.buffer stream) ""))
166     (:listen (< (sis.index stream) (length (sis.buffer stream))))
167     (:charpos nil)
168     (:line-length nil)
169     (:get-command nil)
170 heller 1.22 (:element-type 'base-char)
171     (:close nil)))
172 heller 1.16
173 lgorrie 1.25
174 dbarlow 1.1 ;;;; Compilation Commands
175    
176 heller 1.19 (defvar *swank-source-info* nil
177     "Bound to a SOURCE-INFO object during compilation.")
178 dbarlow 1.1
179 lgorrie 1.24 (defvar *previous-compiler-condition* nil
180     "Used to detect duplicates.")
181    
182     (defvar *previous-context* nil
183     "Previous compiler error context.")
184    
185     (defvar *compiler-notes* '()
186     "List of compiler notes for the last compilation unit.")
187    
188 heller 1.30 (defvar *buffer-name* nil)
189     (defvar *buffer-start-position* nil)
190     (defvar *buffer-substring* nil)
191     (defvar *compile-filename* nil)
192    
193 lgorrie 1.25
194 lgorrie 1.24 ;;;;; Trapping notes
195    
196     (defun handle-notification-condition (condition)
197 dbarlow 1.1 "Handle a condition caused by a compiler warning.
198     This traps all compiler conditions at a lower-level than using
199     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
200     craft our own error messages, which can omit a lot of redundant
201     information."
202     (unless (eq condition *previous-compiler-condition*)
203     (let ((context (or (c::find-error-context nil) *previous-context*)))
204     (setq *previous-compiler-condition* condition)
205     (setq *previous-context* context)
206 lgorrie 1.24 (signal-compiler-condition condition context))))
207    
208     (defun signal-compiler-condition (condition context)
209     (signal (make-condition
210     'compiler-condition
211     :original-condition condition
212     :severity (severity-for-emacs condition)
213     :message (brief-compiler-message-for-emacs condition context)
214     :location (compiler-note-location context))))
215    
216     (defun severity-for-emacs (condition)
217     "Return the severity of CONDITION."
218     (etypecase condition
219     (c::compiler-error :error)
220     (c::style-warning :note)
221     (c::warning :warning)))
222    
223     (defun brief-compiler-message-for-emacs (condition error-context)
224     "Briefly describe a compiler error for Emacs.
225     When Emacs presents the message it already has the source popped up
226     and the source form highlighted. This makes much of the information in
227     the error-context redundant."
228     (declare (type (or c::compiler-error-context null) error-context))
229 heller 1.30 (multiple-value-bind (enclosing source)
230     (if error-context
231     (values (c::compiler-error-context-enclosing-source error-context)
232     (c::compiler-error-context-source error-context)))
233     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
234     enclosing source condition)))
235    
236     (defun compiler-note-location (context)
237     (cond (context
238     (resolve-note-location
239     *buffer-name*
240     (c::compiler-error-context-file-name context)
241     (c::compiler-error-context-file-position context)
242     (reverse (c::compiler-error-context-original-source-path context))
243     (c::compiler-error-context-original-source context)))
244     (t
245     (resolve-note-location *buffer-name* nil nil nil nil))))
246    
247     (defgeneric resolve-note-location (buffer file-name file-position
248     source-path source))
249    
250     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
251     (make-location
252     `(:file ,(unix-truename f))
253     `(:position ,(1+ (source-path-file-position path f)))))
254    
255     (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
256     (make-location
257     `(:buffer ,b)
258     `(:position ,(+ *buffer-start-position*
259     (source-path-string-position path *buffer-substring*)))))
260    
261     (defmethod resolve-note-location (buffer
262     (file (eql nil))
263     (pos (eql nil))
264     (path (eql nil))
265     (source (eql nil)))
266     (cond (buffer
267     (make-location (list :buffer buffer)
268     (list :position *buffer-start-position*)))
269     (*compile-file-truename*
270     (make-location (list :file (namestring *compile-file-truename*))
271     (list :position 0)))
272     (*compile-filename*
273     (make-location (list :file *compile-filename*) (list :position 0)))
274     (t
275     (list :error "No error location available"))))
276 dbarlow 1.1
277 lgorrie 1.24 (defmacro with-compilation-hooks (() &body body)
278 lgorrie 1.25 "Execute BODY and record the set of compiler notes."
279 lgorrie 1.24 `(let ((*previous-compiler-condition* nil)
280 heller 1.30 (*previous-context* nil)
281     (*print-readably* nil))
282 lgorrie 1.24 (handler-bind ((c::compiler-error #'handle-notification-condition)
283     (c::style-warning #'handle-notification-condition)
284     (c::warning #'handle-notification-condition))
285     ,@body)))
286    
287     (defmethod compile-file-for-emacs (filename load-p)
288     (clear-xref-info filename)
289     (with-compilation-hooks ()
290 heller 1.30 (let ((*buffer-name* nil)
291     (*compile-filename* filename))
292     (compile-file filename :load load-p))))
293 lgorrie 1.24
294     (defmethod compile-string-for-emacs (string &key buffer position)
295     (with-compilation-hooks ()
296     (let ((*package* *buffer-package*)
297 heller 1.30 (*compile-filename* nil)
298     (*buffer-name* buffer)
299     (*buffer-start-position* position)
300     (*buffer-substring* string))
301 lgorrie 1.24 (with-input-from-string (stream string)
302     (ext:compile-from-stream
303     stream
304     :source-info `(:emacs-buffer ,buffer
305     :emacs-buffer-offset ,position
306     :emacs-buffer-string ,string))))))
307 dbarlow 1.1
308 lgorrie 1.25
309     ;;;; XREF
310 dbarlow 1.1
311 heller 1.30 (defun lookup-xrefs (finder name)
312     (xref-results-for-emacs (funcall finder (from-string name))))
313    
314 dbarlow 1.1 (defslimefun who-calls (function-name)
315     "Return the places where FUNCTION-NAME is called."
316 heller 1.30 (lookup-xrefs #'xref:who-calls function-name))
317 dbarlow 1.1
318     (defslimefun who-references (variable)
319     "Return the places where the global variable VARIABLE is referenced."
320 heller 1.30 (lookup-xrefs #'xref:who-references variable))
321 dbarlow 1.1
322     (defslimefun who-binds (variable)
323     "Return the places where the global variable VARIABLE is bound."
324 heller 1.30 (lookup-xrefs #'xref:who-binds variable))
325 dbarlow 1.1
326     (defslimefun who-sets (variable)
327     "Return the places where the global variable VARIABLE is set."
328 heller 1.30 (lookup-xrefs #'xref:who-sets variable))
329 dbarlow 1.1
330 lgorrie 1.10 #+cmu19
331 dbarlow 1.1 (defslimefun who-macroexpands (macro)
332     "Return the places where MACRO is expanded."
333 heller 1.30 (lookup-xrefs #'xref:who-macroexpands macro))
334    
335     (defun resolve-xref-location (xref)
336     (let ((name (xref:xref-context-name xref))
337     (file (xref:xref-context-file xref))
338     (source-path (xref:xref-context-source-path xref)))
339     (cond ((and file source-path)
340     (let ((position (source-path-file-position source-path file)))
341     (make-location (list :file (unix-truename file))
342     (list :position (1+ position)))))
343     (file
344     (make-location (list :file (unix-truename file))
345     (list :function-name (string name))))
346     (t
347     `(:error ,(format nil "Unkown source location: ~S ~S ~S "
348     name file source-path))))))
349    
350 dbarlow 1.1
351     (defun xref-results-for-emacs (contexts)
352     "Prepare a list of xref contexts for Emacs.
353 heller 1.29 The result is a list of xrefs:
354     group ::= (FILENAME . ({reference}+))
355     reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)"
356     (let ((xrefs '()))
357     (dolist (cxt contexts)
358 heller 1.30 (let ((name (xref:xref-context-name cxt)))
359 heller 1.29 (push (cons (to-string name)
360 heller 1.30 (resolve-xref-location cxt))
361 heller 1.29 xrefs)))
362     (group-xrefs xrefs)))
363    
364    
365     (defun location-buffer= (location1 location2)
366     (equalp location1 location2))
367    
368 dbarlow 1.1 (defun file-xrefs-for-emacs (unix-filename contexts)
369     "Return a summary of the references from a particular file.
370     The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))"
371     (list unix-filename
372     (loop for context in (sort-contexts-by-source-path contexts)
373     collect (list (let ((*print-pretty* nil))
374     (to-string (xref:xref-context-name context)))
375     (xref:xref-context-source-path context)))))
376    
377     (defun sort-contexts-by-source-path (contexts)
378     "Sort xref contexts by lexical position of source-paths.
379     It is assumed that all contexts belong to the same file."
380     (sort contexts #'source-path< :key #'xref:xref-context-source-path))
381    
382     (defun source-path< (path1 path2)
383     "Return true if PATH1 is lexically before PATH2."
384     (and (every #'< path1 path2)
385     (< (length path1) (length path2))))
386    
387 lgorrie 1.25 (defun clear-xref-info (namestring)
388     "Clear XREF notes pertaining to FILENAME.
389     This is a workaround for a CMUCL bug: XREF records are cumulative."
390     (let ((filename (parse-namestring namestring)))
391     (when c:*record-xref-info*
392     (dolist (db (list xref::*who-calls*
393     #+cmu19 xref::*who-is-called*
394     #+cmu19 xref::*who-macroexpands*
395     xref::*who-references*
396     xref::*who-binds*
397     xref::*who-sets*))
398     (maphash (lambda (target contexts)
399     (setf (gethash target db)
400     (delete-if
401     (lambda (ctx)
402     (xref-context-derived-from-p ctx filename))
403     contexts)))
404     db)))))
405    
406     (defun xref-context-derived-from-p (context filename)
407     (let ((xref-file (xref:xref-context-file context)))
408     (and xref-file (pathname= filename xref-file))))
409    
410     (defun pathname= (&rest pathnames)
411     "True if PATHNAMES refer to the same file."
412     (apply #'string= (mapcar #'unix-truename pathnames)))
413    
414     (defun unix-truename (pathname)
415     (ext:unix-namestring (truename pathname)))
416    
417    
418     ;;;; Find callers and callees
419    
420 dbarlow 1.1 ;;; Find callers and callees by looking at the constant pool of
421     ;;; compiled code objects. We assume every fdefn object in the
422     ;;; constant pool corresponds to a call to that function. A better
423     ;;; strategy would be to use the disassembler to find actual
424     ;;; call-sites.
425    
426     (declaim (inline map-code-constants))
427     (defun map-code-constants (code fn)
428     "Call FN for each constant in CODE's constant pool."
429     (check-type code kernel:code-component)
430     (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
431     do (funcall fn (kernel:code-header-ref code i))))
432    
433     (defun function-callees (function)
434 heller 1.30 "Return FUNCTION's callees as a list of functions."
435 dbarlow 1.1 (let ((callees '()))
436     (map-code-constants
437     (vm::find-code-object function)
438     (lambda (obj)
439     (when (kernel:fdefn-p obj)
440 heller 1.30 (push (kernel:fdefn-function obj) callees))))
441 dbarlow 1.1 callees))
442    
443 heller 1.19 (declaim (ext:maybe-inline map-allocated-code-components))
444 dbarlow 1.1 (defun map-allocated-code-components (spaces fn)
445     "Call FN for each allocated code component in one of SPACES. FN
446 heller 1.19 receives the object as argument. SPACES should be a list of the
447     symbols :dynamic, :static, or :read-only."
448 dbarlow 1.1 (dolist (space spaces)
449 heller 1.18 (declare (inline vm::map-allocated-objects))
450 dbarlow 1.1 (vm::map-allocated-objects
451     (lambda (obj header size)
452 heller 1.19 (declare (type fixnum size) (ignore size))
453 dbarlow 1.1 (when (= vm:code-header-type header)
454 heller 1.19 (funcall fn obj)))
455 dbarlow 1.1 space)))
456    
457 heller 1.19 (declaim (ext:maybe-inline map-caller-code-components))
458 dbarlow 1.1 (defun map-caller-code-components (function spaces fn)
459     "Call FN for each code component with a fdefn for FUNCTION in its
460     constant pool."
461     (let ((function (coerce function 'function)))
462 heller 1.19 (declare (inline map-allocated-code-components))
463 dbarlow 1.1 (map-allocated-code-components
464     spaces
465 heller 1.19 (lambda (obj)
466 dbarlow 1.1 (map-code-constants
467     obj
468     (lambda (constant)
469     (when (and (kernel:fdefn-p constant)
470     (eq (kernel:fdefn-function constant)
471     function))
472     (funcall fn obj))))))))
473    
474     (defun function-callers (function &optional (spaces '(:read-only :static
475     :dynamic)))
476 heller 1.30 "Return FUNCTION's callers. The result is a list of code-objects."
477 dbarlow 1.1 (let ((referrers '()))
478 heller 1.19 (declare (inline map-caller-code-components))
479 heller 1.30 (ext:gc :full t)
480     (map-caller-code-components function spaces
481     (lambda (code) (push code referrers)))
482 dbarlow 1.1 referrers))
483 heller 1.30
484     (defun debug-info-definitions (debug-info)
485     "Return the defintions for a debug-info. This should only be used
486     for code-object without entry points, i.e., byte compiled
487     code (are theree others?)"
488     ;; This mess has only been tested with #'ext::skip-whitespace, a
489     ;; byte-compiled caller of #'read-char .
490     (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
491     (let ((name (c::debug-info-name debug-info))
492     (source (c::debug-info-source debug-info)))
493     (destructuring-bind (first) source
494     (ecase (c::debug-source-from first)
495     (:file
496     (list
497     (cons name
498     (make-location
499     (list :file (unix-truename (c::debug-source-name first)))
500     (list :function-name name)))))))))
501    
502     (defun code-component-entry-points (code)
503     "Return a list ((NAME . LOCATION) ...) of function definitons for
504     the code omponent CODE."
505     (delete-duplicates
506     (loop for e = (kernel:%code-entry-points code)
507     then (kernel::%function-next e)
508     while e
509     collect (cons (to-string (kernel:%function-name e))
510     (function-source-location e)))
511     :test #'equal))
512 dbarlow 1.1
513     (defslimefun list-callers (symbol-name)
514 heller 1.30 "Return a list ((FILE . ((NAME . LOCATION) ...)) ...) of callers."
515     (let ((components (function-callers (from-string symbol-name)))
516     (xrefs '()))
517     (dolist (code components)
518     (let* ((entry (kernel:%code-entry-points code))
519     (defs (if entry
520     (code-component-entry-points code)
521     ;; byte compiled stuff
522     (debug-info-definitions
523     (kernel:%code-debug-info code)))))
524     (setq xrefs (nconc defs xrefs))))
525     (group-xrefs xrefs)))
526 dbarlow 1.1
527 heller 1.18
528 dbarlow 1.1 (defslimefun list-callees (symbol-name)
529 heller 1.30 (let ((fns (function-callees (from-string symbol-name))))
530     (group-xrefs (mapcar (lambda (fn)
531     (cons (to-string (kernel:%function-name fn))
532     (function-source-location fn)))
533     fns))))
534 dbarlow 1.1
535     ;;;; Definitions
536    
537 heller 1.29 (defvar *debug-definition-finding* t
538 dbarlow 1.1 "When true don't handle errors while looking for definitions.
539     This is useful when debugging the definition-finding code.")
540    
541 heller 1.29 (defmacro safe-definition-finding (&body body)
542     "Execute BODY ignoring errors. Return a the source location
543     returned by BODY or if an error occurs a description of the error.
544     The second return value is the condition or nil."
545     `(flet ((body () ,@body))
546     (if *debug-definition-finding*
547     (body)
548     (handler-case (values (progn ,@body) nil)
549     (error (c) (values (list :error (princ-to-string c)) c))))))
550    
551 dbarlow 1.1 (defun function-first-code-location (function)
552     (and (function-has-debug-function-p function)
553     (di:debug-function-start-location
554     (di:function-debug-function function))))
555    
556     (defun function-has-debug-function-p (function)
557     (di:function-debug-function function))
558    
559     (defun function-code-object= (closure function)
560     (and (eq (vm::find-code-object closure)
561     (vm::find-code-object function))
562     (not (eq closure function))))
563    
564 heller 1.4 (defun struct-closure-p (function)
565     (or (function-code-object= function #'kernel::structure-slot-accessor)
566     (function-code-object= function #'kernel::structure-slot-setter)
567     (function-code-object= function #'kernel::%defstruct)))
568 dbarlow 1.1
569 heller 1.4 (defun struct-closure-dd (function)
570 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
571 heller 1.4 (flet ((find-layout (function)
572     (sys:find-if-in-closure
573     (lambda (x)
574 heller 1.18 (let ((value (if (di::indirect-value-cell-p x)
575     (c:value-cell-ref x)
576     x)))
577     (when (kernel::layout-p value)
578     (return-from find-layout value))))
579 heller 1.4 function)))
580     (kernel:layout-info (find-layout function))))
581    
582 dbarlow 1.1 (defun dd-source-location (dd)
583     (let ((constructor (or (kernel:dd-default-constructor dd)
584     (car (kernel::dd-constructors dd)))))
585     (cond (constructor
586     (function-source-location
587     (coerce (if (consp constructor) (car constructor) constructor)
588     'function)))
589     (t (error "Cannot locate struct without constructor: ~S"
590     (kernel::dd-name dd))))))
591    
592 heller 1.27 (defun genericp (fn)
593     (typep fn 'generic-function))
594    
595     (defun gf-definition-location (gf)
596     (flet ((guess-source-file (faslfile)
597     (unix-truename
598     (merge-pathnames (make-pathname :type "lisp")
599     faslfile))))
600     (let ((def-source (pcl::definition-source gf))
601     (name (string (pcl:generic-function-name gf))))
602     (etypecase def-source
603 heller 1.30 (pathname (make-location
604     `(:file ,(guess-source-file def-source))
605     `(:function-name ,name)))
606 heller 1.27 (cons
607     (destructuring-bind ((dg name) pathname) def-source
608     (declare (ignore dg))
609 heller 1.30 (etypecase pathname
610     (pathname
611     (make-location `(:file ,(guess-source-file pathname))
612     `(:function-name ,(string name)))))))))))
613 heller 1.27
614     (defun method-source-location (method)
615     (function-source-location (or (pcl::method-fast-function method)
616     (pcl:method-function method))))
617    
618     (defun gf-method-locations (gf)
619     (let ((ms (pcl::generic-function-methods gf)))
620     (mapcar #'method-source-location ms)))
621    
622     (defun gf-source-locations (gf)
623     (list* (gf-definition-location gf)
624     (gf-method-locations gf)))
625    
626 heller 1.29 (defun function-source-locations (function)
627     "Return a list of source locations for FUNCTION."
628 dbarlow 1.1 ;; First test if FUNCTION is a closure created by defstruct; if so
629     ;; extract the defstruct-description (dd) from the closure and find
630     ;; the constructor for the struct. Defstruct creates a defun for
631     ;; the default constructor and we use that as an approximation to
632     ;; the source location of the defstruct.
633     ;;
634     ;; For an ordinary function we return the source location of the
635     ;; first code-location we find.
636 heller 1.4 (cond ((struct-closure-p function)
637 heller 1.29 (list
638     (safe-definition-finding
639     (dd-source-location (struct-closure-dd function)))))
640 heller 1.27 ((genericp function)
641 heller 1.29 (gf-source-locations function))
642 heller 1.27 (t
643 heller 1.29 (list
644     (multiple-value-bind (code-location error)
645     (safe-definition-finding (function-first-code-location function))
646     (cond (error (list :error (princ-to-string error)))
647     (t (code-location-source-location code-location))))))))
648    
649     (defun function-source-location (function)
650     (destructuring-bind (first) (function-source-locations function)
651     first))
652 dbarlow 1.1
653 heller 1.30 (defslimefun find-function-locations (symbol-name)
654 heller 1.29 "Return a list of source-locations for SYMBOL-NAME's functions."
655     (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
656     (cond ((not foundp)
657     (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
658     ((macro-function symbol)
659     (function-source-locations (macro-function symbol)))
660     ((special-operator-p symbol)
661     (list (list :error (format nil "~A is special-operator" symbol))))
662     ((fboundp symbol)
663     (function-source-locations (coerce symbol 'function)))
664     (t (list (list :error
665     (format nil "Symbol not fbound: ~A" symbol-name))))
666     )))
667    
668 lgorrie 1.25
669     ;;;; Documentation.
670 dbarlow 1.1
671 lgorrie 1.24 (defmethod describe-symbol-for-emacs (symbol)
672 dbarlow 1.1 (let ((result '()))
673 lgorrie 1.24 (flet ((doc (kind)
674     (or (documentation symbol kind) :not-documented))
675     (maybe-push (property value)
676     (when value
677     (setf result (list* property value result)))))
678 dbarlow 1.1 (maybe-push
679     :variable (multiple-value-bind (kind recorded-p)
680     (ext:info variable kind symbol)
681     (declare (ignore kind))
682     (if (or (boundp symbol) recorded-p)
683     (doc 'variable))))
684     (maybe-push
685 heller 1.27 :generic-function
686     (if (and (fboundp symbol)
687     (typep (fdefinition symbol) 'generic-function))
688     (doc 'function)))
689     (maybe-push
690     :function (if (and (fboundp symbol)
691     (not (typep (fdefinition symbol) 'generic-function)))
692     (doc 'function)))
693 dbarlow 1.1 (maybe-push
694     :setf (if (or (ext:info setf inverse symbol)
695     (ext:info setf expander symbol))
696     (doc 'setf)))
697     (maybe-push
698     :type (if (ext:info type kind symbol)
699     (doc 'type)))
700     (maybe-push
701     :class (if (find-class symbol nil)
702     (doc 'class)))
703 heller 1.18 (maybe-push
704     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
705     (doc 'alien-type)))
706     (maybe-push
707     :alien-struct (if (ext:info alien-type struct symbol)
708     (doc nil)))
709     (maybe-push
710     :alien-union (if (ext:info alien-type union symbol)
711     (doc nil)))
712     (maybe-push
713     :alien-enum (if (ext:info alien-type enum symbol)
714     (doc nil)))
715 lgorrie 1.24 result)))
716 dbarlow 1.1
717     (defslimefun describe-setf-function (symbol-name)
718 dbarlow 1.3 (print-description-to-string
719 dbarlow 1.1 (or (ext:info setf inverse (from-string symbol-name))
720     (ext:info setf expander (from-string symbol-name)))))
721    
722     (defslimefun describe-type (symbol-name)
723 dbarlow 1.3 (print-description-to-string
724 dbarlow 1.1 (kernel:values-specifier-type (from-string symbol-name))))
725    
726     (defslimefun describe-class (symbol-name)
727 dbarlow 1.3 (print-description-to-string (find-class (from-string symbol-name) nil)))
728 dbarlow 1.1
729 heller 1.18 (defslimefun describe-alien-type (symbol-name)
730     (let ((name (from-string symbol-name)))
731     (ecase (ext:info :alien-type :kind name)
732     (:primitive
733     (print-description-to-string
734     (let ((alien::*values-type-okay* t))
735     (funcall (ext:info :alien-type :translator name) (list name)))))
736     ((:defined)
737     (print-description-to-string (ext:info :alien-type :definition name)))
738     (:unknown
739     (format nil "Unkown alien type: ~A" symbol-name)))))
740    
741     (defmacro %describe-alien (symbol-name namespace)
742     `(print-description-to-string
743     (ext:info :alien-type ,namespace (from-string ,symbol-name))))
744    
745     (defslimefun describe-alien-struct (symbol-name)
746     (%describe-alien symbol-name :struct))
747    
748     (defslimefun describe-alien-union (symbol-name)
749     (%describe-alien symbol-name :union))
750    
751     (defslimefun describe-alien-enum (symbol-name)
752     (%describe-alien symbol-name :enum))
753    
754 lgorrie 1.25 (defmethod arglist-string (fname)
755     "Return a string describing the argument list for FNAME.
756     The result has the format \"(...)\"."
757     (declare (type string fname))
758     (multiple-value-bind (function condition)
759     (ignore-errors (values (find-symbol-designator fname *buffer-package*)))
760     (when condition
761     (return-from arglist-string (format nil "(-- ~A)" condition)))
762     (let ((arglist
763     (if (not (or (fboundp function)
764     (functionp function)))
765     "(-- <Unknown-Function>)"
766     (let* ((fun (or (macro-function function)
767     (symbol-function function)))
768     (df (di::function-debug-function fun))
769     (arglist (kernel:%function-arglist fun)))
770     (cond ((eval:interpreted-function-p fun)
771     (eval:interpreted-function-arglist fun))
772     ((pcl::generic-function-p fun)
773     (pcl::gf-pretty-arglist fun))
774     (arglist arglist)
775     ;; this should work both for
776     ;; compiled-debug-function and for
777     ;; interpreted-debug-function
778     (df (di::debug-function-lambda-list df))
779     (t "(<arglist-unavailable>)"))))))
780     (if (stringp arglist)
781     arglist
782     (to-string arglist)))))
783    
784    
785     ;;;; Miscellaneous.
786 dbarlow 1.1
787 lgorrie 1.24 (defmethod macroexpand-all (form)
788     (walker:macroexpand-all form))
789 dbarlow 1.1
790     (defun tracedp (fname)
791     (gethash (debug::trace-fdefinition fname)
792     debug::*traced-functions*))
793    
794     (defslimefun toggle-trace-fdefinition (fname-string)
795     (let ((fname (from-string fname-string)))
796     (cond ((tracedp fname)
797     (debug::untrace-1 fname)
798     (format nil "~S is now untraced." fname))
799     (t
800     (debug::trace-1 fname (debug::make-trace-info))
801     (format nil "~S is now traced." fname)))))
802 lgorrie 1.25
803     (defslimefun set-default-directory (directory)
804     (setf (ext:default-directory) (namestring directory))
805     ;; Setting *default-pathname-defaults* to an absolute directory
806     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
807     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
808     (namestring (ext:default-directory)))
809    
810 heller 1.19
811 lgorrie 1.25 ;;;; Source-paths
812 heller 1.19
813 lgorrie 1.25 ;;; CMUCL uses a data structure called "source-path" to locate
814     ;;; subforms. The compiler assigns a source-path to each form in a
815     ;;; compilation unit. Compiler notes usually contain the source-path
816     ;;; of the error location.
817     ;;;
818     ;;; Compiled code objects don't contain source paths, only the
819     ;;; "toplevel-form-number" and the (sub-) "form-number". To get from
820     ;;; the form-number to the source-path we need the entire toplevel-form
821     ;;; (i.e. we have to read the source code). CMUCL has already some
822     ;;; utilities to do this translation, but we use some extended
823     ;;; versions, because we need more exact position info. Apparently
824     ;;; Hemlock is happy with the position of the toplevel-form; we also
825     ;;; need the position of subforms.
826     ;;;
827     ;;; We use a special readtable to get the positions of the subforms.
828     ;;; The readtable stores the start and end position for each subform in
829     ;;; hashtable for later retrieval.
830 heller 1.19
831     (defun make-source-recorder (fn source-map)
832     "Return a macro character function that does the same as FN, but
833     additionally stores the result together with the stream positions
834     before and after of calling FN in the hashtable SOURCE-MAP."
835     (lambda (stream char)
836     (let ((start (file-position stream))
837     (values (multiple-value-list (funcall fn stream char)))
838     (end (file-position stream)))
839     #+(or) (format t "~&[~D ~{~A~^, ~} ~D]~%" start values end)
840     (unless (null values)
841     (push (cons start end) (gethash (car values) source-map)))
842     (values-list values))))
843    
844     (defun make-source-recording-readtable (readtable source-map)
845     "Return a source position recording copy of READTABLE.
846     The source locations are stored in SOURCE-MAP."
847     (let* ((tab (copy-readtable readtable))
848     (*readtable* tab))
849     (dotimes (code char-code-limit)
850     (let ((char (code-char code)))
851     (multiple-value-bind (fn term) (get-macro-character char tab)
852     (when fn
853     (set-macro-character char (make-source-recorder fn source-map)
854     term tab)))))
855     tab))
856    
857     (defun make-source-map ()
858     (make-hash-table :test #'eq))
859    
860     (defvar *source-map* (make-source-map)
861     "The hashtable table used for source position recording.")
862    
863     (defvar *recording-readtable-cache* '()
864     "An alist of (READTABLE . RECORDING-READTABLE) pairs.")
865    
866     (defun lookup-recording-readtable (readtable)
867     "Find a cached or create a new recording readtable for READTABLE."
868     (or (cdr (assoc readtable *recording-readtable-cache*))
869     (let ((table (make-source-recording-readtable readtable *source-map*)))
870     (push (cons readtable table) *recording-readtable-cache*)
871     table)))
872    
873     (defun read-and-record-source-map (stream)
874     "Read the next object from STREAM.
875     Return the object together with a hashtable that maps
876     subexpressions of the object to stream positions."
877     (let ((*readtable* (lookup-recording-readtable *readtable*)))
878     (clrhash *source-map*)
879     (values (read stream) *source-map*)))
880    
881     (defun source-path-stream-position (path stream)
882     "Search the source-path PATH in STREAM and return its position."
883     (destructuring-bind (tlf-number . path) path
884     (let ((*read-suppress* t))
885     (dotimes (i tlf-number) (read stream))
886     (multiple-value-bind (form source-map)
887     (read-and-record-source-map stream)
888     (source-path-source-position (cons 0 path) form source-map)))))
889    
890     (defun source-path-string-position (path string)
891     (with-input-from-string (s string)
892     (source-path-stream-position path s)))
893    
894     (defun source-path-file-position (path filename)
895     (with-open-file (file filename)
896     (source-path-stream-position path file)))
897    
898     (defun source-path-source-position (path form source-map)
899     "Return the start position of PATH form FORM and SOURCE-MAP. All
900     subforms along the path are considered and the start and end position
901     of deepest (i.e. smallest) possible form is returned."
902     ;; compute all subforms along path
903     (let ((forms (loop for n in path
904     for f = form then (nth n f)
905     collect f)))
906     ;; select the first subform present in source-map
907     (loop for form in (reverse forms)
908     for positions = (gethash form source-map)
909     until positions
910     finally (destructuring-bind ((start . end)) positions
911     (return (values (1- start) end))))))
912    
913     (defun code-location-stream-position (code-location stream)
914     "Return the byte offset of CODE-LOCATION in STREAM. Extract the
915     toplevel-form-number and form-number from CODE-LOCATION and use that
916     to find the position of the corresponding form."
917     (let* ((location (debug::maybe-block-start-location code-location))
918     (tlf-offset (di:code-location-top-level-form-offset location))
919     (form-number (di:code-location-form-number location))
920     (*read-suppress* t))
921     (dotimes (i tlf-offset) (read stream))
922     (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
923     (let* ((path-table (di:form-number-translations tlf 0))
924 heller 1.30 (source-path
925     (if (<= (length path-table) form-number) ; source out of sync?
926     (list 0) ; should probably signal a condition
927     (reverse (cdr (aref path-table form-number))))))
928 heller 1.19 (source-path-source-position source-path tlf position-map)))))
929    
930     (defun code-location-string-offset (code-location string)
931     (with-input-from-string (s string)
932     (code-location-stream-position code-location s)))
933    
934     (defun code-location-file-position (code-location filename)
935     (with-open-file (s filename :direction :input)
936     (code-location-stream-position code-location s)))
937    
938     (defun make-file-location (pathname code-location)
939 heller 1.30 (make-location
940     `(:file ,(unix-truename pathname))
941     `(:position ,(1+ (code-location-file-position code-location pathname)))))
942 heller 1.19
943     (defun make-buffer-location (buffer start string code-location)
944 heller 1.30 (make-location
945     `(:buffer ,buffer)
946     `(:position ,(+ start (code-location-string-offset code-location string)))))
947 heller 1.19
948     (defun debug-source-info-from-emacs-buffer-p (debug-source)
949     (let ((info (c::debug-source-info debug-source)))
950     (and info
951     (consp info)
952     (eq :emacs-buffer (car info)))))
953    
954 heller 1.30 (defun source-location-from-code-location (code-location)
955 heller 1.29 "Return the source location for CODE-LOCATION."
956 heller 1.30 (let ((debug-fun (di:code-location-debug-function code-location)))
957     (when (di::bogus-debug-function-p debug-fun)
958     (error "Bogus debug function: ~A" debug-fun)))
959 heller 1.19 (let* ((debug-source (di:code-location-debug-source code-location))
960 heller 1.30 (from (di:debug-source-from debug-source))
961     (name (di:debug-source-name debug-source)))
962 heller 1.19 (ecase from
963     (:file (make-file-location name code-location))
964     (:stream
965     (assert (debug-source-info-from-emacs-buffer-p debug-source))
966     (let ((info (c::debug-source-info debug-source)))
967 heller 1.30 (make-buffer-location (getf info :emacs-buffer)
968     (getf info :emacs-buffer-offset)
969     (getf info :emacs-buffer-string)
970     code-location)))
971 heller 1.19 (:lisp
972     `(:sexp , (with-output-to-string (*standard-output*)
973 heller 1.30 (debug::print-code-location-source-form
974     code-location 100 t)))))))
975 heller 1.19
976 heller 1.29 (defun code-location-source-location (code-location)
977     "Safe wrapper around `code-location-from-source-location'."
978     (safe-definition-finding
979 heller 1.30 (source-location-from-code-location code-location)))
980 dbarlow 1.1
981 lgorrie 1.25 (defslimefun getpid ()
982     (unix:unix-getpid))
983    
984 dbarlow 1.1
985 lgorrie 1.25 ;;;; Debugging
986 dbarlow 1.1
987     (defvar *sldb-stack-top*)
988     (defvar *sldb-restarts*)
989    
990 lgorrie 1.25 (defmethod call-with-debugging-environment (debugger-loop-fn)
991 dbarlow 1.1 (unix:unix-sigsetmask 0)
992 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
993 dbarlow 1.1 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
994     (debug:*stack-top-hint* nil)
995     (*debugger-hook* nil)
996     (*readtable* (or debug:*debug-readtable* *readtable*))
997     (*print-level* debug:*debug-print-level*)
998 heller 1.30 (*print-length* debug:*debug-print-length*)
999     (*print-readably* nil))
1000 dbarlow 1.1 (handler-bind ((di:debug-condition
1001     (lambda (condition)
1002 lgorrie 1.25 (signal (make-condition
1003     'sldb-condition
1004     :original-condition condition)))))
1005     (funcall debugger-loop-fn))))
1006 dbarlow 1.1
1007     (defun format-restarts-for-emacs ()
1008     "Return a list of restarts for *swank-debugger-condition* in a
1009     format suitable for Emacs."
1010     (loop for restart in *sldb-restarts*
1011     collect (list (princ-to-string (restart-name restart))
1012     (princ-to-string restart))))
1013    
1014     (defun format-condition-for-emacs ()
1015     (format nil "~A~% [Condition of type ~S]"
1016     (debug::safe-condition-message *swank-debugger-condition*)
1017     (type-of *swank-debugger-condition*)))
1018    
1019     (defun nth-frame (index)
1020     (do ((frame *sldb-stack-top* (di:frame-down frame))
1021     (i index (1- i)))
1022     ((zerop i) frame)))
1023    
1024     (defun nth-restart (index)
1025     (nth index *sldb-restarts*))
1026    
1027     (defun format-frame-for-emacs (frame)
1028     (list (di:frame-number frame)
1029     (with-output-to-string (*standard-output*)
1030 heller 1.23 (let ((*print-pretty* *sldb-pprint-frames*))
1031 dbarlow 1.1 (debug::print-frame-call frame :verbosity 1 :number t)))))
1032    
1033     (defun compute-backtrace (start end)
1034     "Return a list of frames starting with frame number START and
1035     continuing to frame number END or, if END is nil, the last frame on the
1036     stack."
1037     (let ((end (or end most-positive-fixnum)))
1038     (loop for f = (nth-frame start) then (di:frame-down f)
1039     for i from start below end
1040     while f
1041     collect f)))
1042    
1043 lgorrie 1.26 (defmethod backtrace (start end)
1044 dbarlow 1.1 (mapcar #'format-frame-for-emacs (compute-backtrace start end)))
1045    
1046 lgorrie 1.25 (defmethod debugger-info-for-emacs (start end)
1047 dbarlow 1.1 (list (format-condition-for-emacs)
1048     (format-restarts-for-emacs)
1049 lgorrie 1.26 (backtrace start end)))
1050 dbarlow 1.1
1051 lgorrie 1.26 (defmethod frame-source-location-for-emacs (index)
1052 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1053 dbarlow 1.1
1054 lgorrie 1.26 (defmethod eval-in-frame (form index)
1055     (di:eval-in-frame (nth-frame index) form))
1056 heller 1.19
1057     (defslimefun pprint-eval-string-in-frame (string index)
1058 heller 1.23 (swank-pprint
1059     (multiple-value-list
1060     (di:eval-in-frame (nth-frame index) (from-string string)))))
1061 dbarlow 1.1
1062 heller 1.13 (defslimefun inspect-in-frame (string index)
1063     (reset-inspector)
1064     (inspect-object (di:eval-in-frame (nth-frame index) (from-string string))))
1065    
1066 lgorrie 1.26 (defmethod frame-locals (index)
1067 dbarlow 1.1 (let* ((frame (nth-frame index))
1068     (location (di:frame-code-location frame))
1069     (debug-function (di:frame-debug-function frame))
1070     (debug-variables (di::debug-function-debug-variables debug-function)))
1071     (loop for v across debug-variables
1072     collect (list
1073     :symbol (di:debug-variable-symbol v)
1074     :id (di:debug-variable-id v)
1075     :value-string
1076     (if (eq (di:debug-variable-validity v location)
1077     :valid)
1078     (to-string (di:debug-variable-value v frame))
1079     "<not-available>")))))
1080    
1081 lgorrie 1.26 (defmethod frame-catch-tags (index)
1082 dbarlow 1.1 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
1083 heller 1.29 collect `(,tag . ,(code-location-source-location code-location))))
1084 dbarlow 1.1
1085     (defslimefun invoke-nth-restart (index)
1086     (invoke-restart (nth-restart index)))
1087    
1088     (defslimefun sldb-abort ()
1089     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1090    
1091    
1092 lgorrie 1.25 ;;;; Inspecting
1093 dbarlow 1.1
1094     (defvar *inspectee*)
1095     (defvar *inspectee-parts*)
1096     (defvar *inspector-stack* '())
1097     (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1098     (defvar *inspect-length* 30)
1099    
1100     (defun reset-inspector ()
1101     (setq *inspectee* nil)
1102     (setq *inspectee-parts* nil)
1103     (setq *inspector-stack* nil)
1104     (setf (fill-pointer *inspector-history*) 0))
1105    
1106     (defslimefun init-inspector (string)
1107     (reset-inspector)
1108     (inspect-object (eval (from-string string))))
1109    
1110     (defun print-part-to-string (value)
1111     (let ((*print-pretty* nil))
1112     (let ((string (to-string value))
1113     (pos (position value *inspector-history*)))
1114     (if pos
1115     (format nil "#~D=~A" pos string)
1116     string))))
1117    
1118     (defun inspect-object (object)
1119     (push (setq *inspectee* object) *inspector-stack*)
1120     (unless (find object *inspector-history*)
1121     (vector-push-extend object *inspector-history*))
1122     (multiple-value-bind (text parts) (inspected-parts object)
1123     (setq *inspectee-parts* parts)
1124     (list :text text
1125     :type (to-string (type-of object))
1126     :primitive-type (describe-primitive-type object)
1127     :parts (loop for (label . value) in parts
1128     collect (cons label
1129     (print-part-to-string value))))))
1130     (defconstant +lowtag-symbols+
1131     '(vm:even-fixnum-type
1132     vm:function-pointer-type
1133     vm:other-immediate-0-type
1134     vm:list-pointer-type
1135     vm:odd-fixnum-type
1136     vm:instance-pointer-type
1137     vm:other-immediate-1-type
1138     vm:other-pointer-type))
1139    
1140     (defconstant +header-type-symbols+
1141     ;; Is there a convinient place for all those constants?
1142     (flet ((tail-comp (string tail)
1143     (and (>= (length string) (length tail))
1144     (string= string tail :start1 (- (length string)
1145     (length tail))))))
1146     (remove-if-not
1147     (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1148     (not (member x +lowtag-symbols+))
1149     (boundp x)
1150     (typep (symbol-value x) 'fixnum)))
1151     (append (apropos-list "-TYPE" "VM" t)
1152     (apropos-list "-TYPE" "BIGNUM" t)))))
1153    
1154     (defun describe-primitive-type (object)
1155     (with-output-to-string (*standard-output*)
1156     (let* ((lowtag (kernel:get-lowtag object))
1157     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1158     (format t "[lowtag: ~A" lowtag-symbol)
1159     (cond ((member lowtag (list vm:other-pointer-type
1160     vm:function-pointer-type
1161     vm:other-immediate-0-type
1162     vm:other-immediate-1-type
1163     ))
1164     (let* ((type (kernel:get-type object))
1165     (type-symbol (find type +header-type-symbols+
1166     :key #'symbol-value)))
1167     (format t ", type: ~A]" type-symbol)))
1168     (t (format t "]"))))))
1169    
1170     (defun nth-part (index)
1171     (cdr (nth index *inspectee-parts*)))
1172    
1173     (defslimefun inspect-nth-part (index)
1174     (inspect-object (nth-part index)))
1175    
1176     (defslimefun inspector-pop ()
1177     "Drop the inspector stack and inspect the second element. Return
1178     nil if there's no second element."
1179     (cond ((cdr *inspector-stack*)
1180     (pop *inspector-stack*)
1181     (inspect-object (pop *inspector-stack*)))
1182     (t nil)))
1183    
1184     (defslimefun inspector-next ()
1185     "Inspect the next element in the *inspector-history*."
1186     (let ((position (position *inspectee* *inspector-history*)))
1187     (cond ((= (1+ position) (length *inspector-history*))
1188     nil)
1189     (t (inspect-object (aref *inspector-history* (1+ position)))))))
1190    
1191     (defslimefun quit-inspector ()
1192     (reset-inspector)
1193     nil)
1194    
1195     (defslimefun describe-inspectee ()
1196     "Describe the currently inspected object."
1197 heller 1.4 (print-description-to-string *inspectee*))
1198 dbarlow 1.1
1199     (defgeneric inspected-parts (object)
1200     (:documentation
1201     "Return a short description and a list of (label . value) pairs."))
1202    
1203     (defmethod inspected-parts (o)
1204     (cond ((di::indirect-value-cell-p o)
1205     (inspected-parts-of-value-cell o))
1206     (t
1207     (destructuring-bind (text labeledp . parts)
1208     (inspect::describe-parts o)
1209     (let ((parts (if labeledp
1210     (loop for (label . value) in parts
1211     collect (cons (string label) value))
1212     (loop for value in parts
1213     for i from 0
1214     collect (cons (format nil "~D" i) value)))))
1215     (values text parts))))))
1216    
1217     (defun inspected-parts-of-value-cell (o)
1218     (values (format nil "~A~% is a value cell." o)
1219     (list (cons "Value" (c:value-cell-ref o)))))
1220    
1221     ;; borrowed from sbcl
1222     (defmethod inspected-parts ((object cons))
1223     (if (consp (cdr object))
1224     (inspected-parts-of-nontrivial-list object)
1225     (inspected-parts-of-simple-cons object)))
1226    
1227     (defun inspected-parts-of-simple-cons (object)
1228     (values "The object is a CONS."
1229     (list (cons (string 'car) (car object))
1230     (cons (string 'cdr) (cdr object)))))
1231    
1232     (defun inspected-parts-of-nontrivial-list (object)
1233     (let ((length 0)
1234     (in-list object)
1235     (reversed-elements nil))
1236     (flet ((done (description-format)
1237     (return-from inspected-parts-of-nontrivial-list
1238     (values (format nil description-format length)
1239     (nreverse reversed-elements)))))
1240     (loop
1241     (cond ((null in-list)
1242     (done "The object is a proper list of length ~S.~%"))
1243     ((>= length *inspect-length*)
1244     (push (cons (string 'rest) in-list) reversed-elements)
1245     (done "The object is a long list (more than ~S elements).~%"))
1246     ((consp in-list)
1247     (push (cons (format nil "~D" length) (pop in-list))
1248     reversed-elements)
1249     (incf length))
1250     (t
1251     (push (cons (string 'rest) in-list) reversed-elements)
1252     (done "The object is an improper list of length ~S.~%")))))))
1253    
1254     (defmethod inspected-parts ((o function))
1255     (let ((header (kernel:get-type o)))
1256     (cond ((= header vm:function-header-type)
1257     (values
1258     (format nil "~A~% is a function." o)
1259     (list (cons "Self" (kernel:%function-self o))
1260     (cons "Next" (kernel:%function-next o))
1261     (cons "Name" (kernel:%function-name o))
1262     (cons "Arglist" (kernel:%function-arglist o))
1263     (cons "Type" (kernel:%function-type o))
1264     (cons "Code Object" (kernel:function-code-header o)))))
1265     ((= header vm:closure-header-type)
1266     (values (format nil "~A~% is a closure." o)
1267     (list*
1268     (cons "Function" (kernel:%closure-function o))
1269     (loop for i from 0 below (- (kernel:get-closure-length o)
1270     (1- vm:closure-info-offset))
1271     collect (cons (format nil "~D" i)
1272     (kernel:%closure-index-ref o i))))))
1273     (t (call-next-method o)))))
1274    
1275     (defmethod inspected-parts ((o kernel:code-component))
1276     (values (format nil "~A~% is a code data-block." o)
1277     `(("First entry point" . ,(kernel:%code-entry-points o))
1278     ,@(loop for i from vm:code-constants-offset
1279     below (kernel:get-header-data o)
1280     collect (cons (format nil "Constant#~D" i)
1281     (kernel:code-header-ref o i)))
1282     ("Debug info" . ,(kernel:%code-debug-info o))
1283     ("Instructions" . ,(kernel:code-instructions o)))))
1284    
1285     (defmethod inspected-parts ((o kernel:fdefn))
1286     (values (format nil "~A~% is a fdefn object." o)
1287     `(("Name" . ,(kernel:fdefn-name o))
1288     ("Function" . ,(kernel:fdefn-function o)))))
1289    
1290     ;;; Local Variables:
1291     ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1292     ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5