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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5