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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show 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 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2
3 (declaim (optimize debug))
4
5 (in-package :swank)
6
7 ;; Turn on xref. [should we?]
8 (setf c:*record-xref-info* t)
9
10 (defun without-interrupts* (body)
11 (sys:without-interrupts (funcall body)))
12
13 (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
22 ;;;; TCP server.
23
24 (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 (defun create-swank-server (port &key reuse-address (address "localhost"))
30 "Create a SWANK TCP server."
31 (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
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 (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 (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 (output (if *use-dedicated-output-stream*
65 (let ((*emacs-io* stream)) (open-stream-to-emacs))
66 (make-slime-output-stream)))
67 (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
86
87 ;;;; Stream handling
88
89 (defstruct (slime-output-stream
90 (:include lisp::lisp-stream
91 (lisp::misc #'sos/misc)
92 (lisp::out #'sos/out)
93 (lisp::sout #'sos/sout))
94 (:conc-name sos.)
95 (:print-function %print-slime-output-stream))
96 (buffer (make-string 512) :type string)
97 (index 0 :type kernel:index)
98 (column 0 :type kernel:index))
99
100 (defun %print-slime-output-stream (s stream d)
101 (declare (ignore d))
102 (print-unreadable-object (s stream :type t :identity t)))
103
104 (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 (when (char= #\newline char)
111 (setf (sos.column stream) 0))
112 (when (= index (1- (length buffer)))
113 (force-output stream)))
114 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 (case operation
123 ((:force-output :finish-output)
124 (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 (:file-position nil)
131 (:element-type 'base-char)
132 (:get-command nil)
133 (:close nil)
134 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
135
136 (defstruct (slime-input-stream
137 (:include string-stream
138 (lisp::in #'sis/in)
139 (lisp::misc #'sis/misc))
140 (:conc-name sis.)
141 (:print-function %print-slime-output-stream))
142 (buffer "" :type string)
143 (index 0 :type kernel:index))
144
145 (defun sis/in (stream eof-errorp eof-value)
146 (declare (ignore eof-errorp eof-value))
147 (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
156 (defun sis/misc (stream operation &optional arg1 arg2)
157 (declare (ignore arg2))
158 (ecase operation
159 (:file-position nil)
160 (: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 (:element-type 'base-char)
171 (:close nil)))
172
173
174 ;;;; Compilation Commands
175
176 (defvar *swank-source-info* nil
177 "Bound to a SOURCE-INFO object during compilation.")
178
179 (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 (defvar *buffer-name* nil)
189 (defvar *buffer-start-position* nil)
190 (defvar *buffer-substring* nil)
191 (defvar *compile-filename* nil)
192
193
194 ;;;;; Trapping notes
195
196 (defun handle-notification-condition (condition)
197 "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 (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 (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
277 (defmacro with-compilation-hooks (() &body body)
278 "Execute BODY and record the set of compiler notes."
279 `(let ((*previous-compiler-condition* nil)
280 (*previous-context* nil)
281 (*print-readably* nil))
282 (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 (let ((*buffer-name* nil)
291 (*compile-filename* filename))
292 (compile-file filename :load load-p))))
293
294 (defmethod compile-string-for-emacs (string &key buffer position)
295 (with-compilation-hooks ()
296 (let ((*package* *buffer-package*)
297 (*compile-filename* nil)
298 (*buffer-name* buffer)
299 (*buffer-start-position* position)
300 (*buffer-substring* string))
301 (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
308
309 ;;;; XREF
310
311 (defun lookup-xrefs (finder name)
312 (xref-results-for-emacs (funcall finder (from-string name))))
313
314 (defslimefun who-calls (function-name)
315 "Return the places where FUNCTION-NAME is called."
316 (lookup-xrefs #'xref:who-calls function-name))
317
318 (defslimefun who-references (variable)
319 "Return the places where the global variable VARIABLE is referenced."
320 (lookup-xrefs #'xref:who-references variable))
321
322 (defslimefun who-binds (variable)
323 "Return the places where the global variable VARIABLE is bound."
324 (lookup-xrefs #'xref:who-binds variable))
325
326 (defslimefun who-sets (variable)
327 "Return the places where the global variable VARIABLE is set."
328 (lookup-xrefs #'xref:who-sets variable))
329
330 #+cmu19
331 (defslimefun who-macroexpands (macro)
332 "Return the places where MACRO is expanded."
333 (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
351 (defun xref-results-for-emacs (contexts)
352 "Prepare a list of xref contexts for Emacs.
353 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 (let ((name (xref:xref-context-name cxt)))
359 (push (cons (to-string name)
360 (resolve-xref-location cxt))
361 xrefs)))
362 (group-xrefs xrefs)))
363
364
365 (defun location-buffer= (location1 location2)
366 (equalp location1 location2))
367
368 (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 (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 ;;; 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 "Return FUNCTION's callees as a list of functions."
435 (let ((callees '()))
436 (map-code-constants
437 (vm::find-code-object function)
438 (lambda (obj)
439 (when (kernel:fdefn-p obj)
440 (push (kernel:fdefn-function obj) callees))))
441 callees))
442
443 (declaim (ext:maybe-inline map-allocated-code-components))
444 (defun map-allocated-code-components (spaces fn)
445 "Call FN for each allocated code component in one of SPACES. FN
446 receives the object as argument. SPACES should be a list of the
447 symbols :dynamic, :static, or :read-only."
448 (dolist (space spaces)
449 (declare (inline vm::map-allocated-objects))
450 (vm::map-allocated-objects
451 (lambda (obj header size)
452 (declare (type fixnum size) (ignore size))
453 (when (= vm:code-header-type header)
454 (funcall fn obj)))
455 space)))
456
457 (declaim (ext:maybe-inline map-caller-code-components))
458 (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 (declare (inline map-allocated-code-components))
463 (map-allocated-code-components
464 spaces
465 (lambda (obj)
466 (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 "Return FUNCTION's callers. The result is a list of code-objects."
477 (let ((referrers '()))
478 (declare (inline map-caller-code-components))
479 (ext:gc :full t)
480 (map-caller-code-components function spaces
481 (lambda (code) (push code referrers)))
482 referrers))
483
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
513 (defslimefun list-callers (symbol-name)
514 "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
527
528 (defslimefun list-callees (symbol-name)
529 (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
535 ;;;; Definitions
536
537 (defvar *debug-definition-finding* t
538 "When true don't handle errors while looking for definitions.
539 This is useful when debugging the definition-finding code.")
540
541 (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 (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 (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
569 (defun struct-closure-dd (function)
570 (assert (= (kernel:get-type function) vm:closure-header-type))
571 (flet ((find-layout (function)
572 (sys:find-if-in-closure
573 (lambda (x)
574 (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 function)))
580 (kernel:layout-info (find-layout function))))
581
582 (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 (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 (pathname (make-location
604 `(:file ,(guess-source-file def-source))
605 `(:function-name ,name)))
606 (cons
607 (destructuring-bind ((dg name) pathname) def-source
608 (declare (ignore dg))
609 (etypecase pathname
610 (pathname
611 (make-location `(:file ,(guess-source-file pathname))
612 `(:function-name ,(string name)))))))))))
613
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 (defun function-source-locations (function)
627 "Return a list of source locations for FUNCTION."
628 ;; 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 (cond ((struct-closure-p function)
637 (list
638 (safe-definition-finding
639 (dd-source-location (struct-closure-dd function)))))
640 ((genericp function)
641 (gf-source-locations function))
642 (t
643 (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
653 (defslimefun find-function-locations (symbol-name)
654 "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
669 ;;;; Documentation.
670
671 (defmethod describe-symbol-for-emacs (symbol)
672 (let ((result '()))
673 (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 (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 :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 (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 (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 result)))
716
717 (defslimefun describe-setf-function (symbol-name)
718 (print-description-to-string
719 (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 (print-description-to-string
724 (kernel:values-specifier-type (from-string symbol-name))))
725
726 (defslimefun describe-class (symbol-name)
727 (print-description-to-string (find-class (from-string symbol-name) nil)))
728
729 (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 (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
787 (defmethod macroexpand-all (form)
788 (walker:macroexpand-all form))
789
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
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
811 ;;;; Source-paths
812
813 ;;; 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
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 (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 (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 (make-location
940 `(:file ,(unix-truename pathname))
941 `(:position ,(1+ (code-location-file-position code-location pathname)))))
942
943 (defun make-buffer-location (buffer start string code-location)
944 (make-location
945 `(:buffer ,buffer)
946 `(:position ,(+ start (code-location-string-offset code-location string)))))
947
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 (defun source-location-from-code-location (code-location)
955 "Return the source location for CODE-LOCATION."
956 (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 (let* ((debug-source (di:code-location-debug-source code-location))
960 (from (di:debug-source-from debug-source))
961 (name (di:debug-source-name debug-source)))
962 (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 (make-buffer-location (getf info :emacs-buffer)
968 (getf info :emacs-buffer-offset)
969 (getf info :emacs-buffer-string)
970 code-location)))
971 (:lisp
972 `(:sexp , (with-output-to-string (*standard-output*)
973 (debug::print-code-location-source-form
974 code-location 100 t)))))))
975
976 (defun code-location-source-location (code-location)
977 "Safe wrapper around `code-location-from-source-location'."
978 (safe-definition-finding
979 (source-location-from-code-location code-location)))
980
981 (defslimefun getpid ()
982 (unix:unix-getpid))
983
984
985 ;;;; Debugging
986
987 (defvar *sldb-stack-top*)
988 (defvar *sldb-restarts*)
989
990 (defmethod call-with-debugging-environment (debugger-loop-fn)
991 (unix:unix-sigsetmask 0)
992 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
993 (*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 (*print-length* debug:*debug-print-length*)
999 (*print-readably* nil))
1000 (handler-bind ((di:debug-condition
1001 (lambda (condition)
1002 (signal (make-condition
1003 'sldb-condition
1004 :original-condition condition)))))
1005 (funcall debugger-loop-fn))))
1006
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 (let ((*print-pretty* *sldb-pprint-frames*))
1031 (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 (defmethod backtrace (start end)
1044 (mapcar #'format-frame-for-emacs (compute-backtrace start end)))
1045
1046 (defmethod debugger-info-for-emacs (start end)
1047 (list (format-condition-for-emacs)
1048 (format-restarts-for-emacs)
1049 (backtrace start end)))
1050
1051 (defmethod frame-source-location-for-emacs (index)
1052 (code-location-source-location (di:frame-code-location (nth-frame index))))
1053
1054 (defmethod eval-in-frame (form index)
1055 (di:eval-in-frame (nth-frame index) form))
1056
1057 (defslimefun pprint-eval-string-in-frame (string index)
1058 (swank-pprint
1059 (multiple-value-list
1060 (di:eval-in-frame (nth-frame index) (from-string string)))))
1061
1062 (defslimefun inspect-in-frame (string index)
1063 (reset-inspector)
1064 (inspect-object (di:eval-in-frame (nth-frame index) (from-string string))))
1065
1066 (defmethod frame-locals (index)
1067 (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 (defmethod frame-catch-tags (index)
1082 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
1083 collect `(,tag . ,(code-location-source-location code-location))))
1084
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 ;;;; Inspecting
1093
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 (print-description-to-string *inspectee*))
1198
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