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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5