home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
s
/
s48.zip
/
MISC
/
INSPECT.SCM
< prev
next >
Wrap
Text File
|
1992-06-18
|
7KB
|
235 lines
; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees. See file COPYING.
; A dirty little inspector.
; This breaks abstractions left and right.
; Look and feel shamelessly plagiarized from the Lucid Lisp inspector.
; Fortunately, I have no assets.
; Eventually, integrate this with the command processor (maybe a
; "colon mode" or "command preferred mode").
; If they aren't already in the system, the following incantation will
; make the :inspect <thing> and :debug commands available at the
; Scheme48 command processor:
;
; :enable
; :load misc/inspect.scm
; :disable
(define *menu-limit* 15)
(define (inspect thing)
(let ((i-port (current-input-port)))
(let new ((thing thing) (stack '()))
(let-fluid $abbreviate-depth 5
(lambda ()
(print-command-result thing)))
(let ((menu (prepare-menu thing)))
(let more ((start 0))
(display-menu menu start)
(let loop ()
(display "inspect: ")
(let ((command (read-form i-port))
(lose (lambda ()
(display "?") (newline) (loop))))
(if (char=? (peek-char i-port) #\newline)
(read-char i-port))
(cond ((eof-object? command) (unspecified)) ;quit
((symbol? command)
(case command
((q) (unspecified))
((u) ;Up (pop stack)
(if (pair? stack)
(new (car stack)
(cdr stack))
(lose)))
((d) ;Down stack
(if (continuation? thing)
(new (next-ripe-continuation thing)
(cons thing stack))
(lose)))
((m) ;More
(if (> (length menu) (+ *menu-limit* start))
(more (+ start *menu-limit*))
(lose)))
((dis)
(disassemble thing)
(loop))
((tem) ;Template
(cond ((closure? thing)
(new (closure-template thing)
(cons thing stack)))
((continuation? thing)
(new (continuation-template thing)
(cons thing stack)))
(else (lose))))
((?)
(inspect-help)
(loop))
(else (lose))))
((and (integer? command)
(>= command 0)
(< command (length menu)))
(new (menu-ref menu command)
(cons thing stack)))
((pair? command)
(let ((foo (eval command (fluid $package-for-commands))))
(if (eq? foo (unspecified))
(loop)
(new foo (cons thing stack)))))
(else (lose))))))))))
(define (inspect-help)
(for-each (lambda (s) (display s) (newline))
'("q quit"
"u up stack (= go to previous object)"
"d down stack"
"dis disassemble"
"tem template"
"<form> evaluate a form (## is current object)")))
(define (menu-ref menu n)
(cadr (list-ref menu n)))
(define (prepare-menu thing)
(cond ((list? thing)
(map (lambda (x) (list #f x))
thing))
((pair? thing)
`((car ,(car thing)) (cdr ,(cdr thing))))
((vector? thing)
(prepare-menu (vector->list thing)))
((closure? thing)
(prepare-environment-menu
(closure-env thing)
(get-shape (template-debug-data (closure-template thing))
0)))
((continuation? thing)
(prepare-continuation-menu thing))
((record? thing)
(prepare-record-menu thing))
((location? thing)
`((id ,(location-id thing))
(contents ,(contents thing))))
(else '())))
(define (prepare-continuation-menu thing)
(let ((dd (template-debug-data (continuation-template thing)))
(next (next-ripe-continuation thing)))
(if dd
(let ((source (assoc (continuation-pc thing)
(debug-data-source dd))))
(if source
;; Gross. We really shouldn't be doing output during
;; menu preparation.
(begin (newline)
(display "Source: ")
(write (cdr source))))))
`(,@(let recur ((c thing))
(if (eq? c next)
'()
(let ((z (- (continuation-length c) continuation-overhead)))
(do ((i (- z 1) (- i 1))
(l (recur (continuation-cont c))
(cons (list #f (continuation-arg c i)) l)))
((< i 0) l)))))
,@(prepare-environment-menu
(continuation-env thing)
(get-shape dd (continuation-pc thing))))))
(define (prepare-record-menu thing)
(let ((rt (record-type thing))
(z (record-length thing)))
(if (record-type? rt)
(do ((i (- z 1) (- i 1))
(f (reverse (record-ref rt 3)) (cdr f))
(l '() (cons (list (car f) (record-ref thing i)) l)))
((< i 1) l))
(do ((i (- z 1) (- i 1))
(l '() (cons (list #f (record-ref thing i)) l)))
((< i 0) l)))))
(define (display-menu menu start)
(let-fluid $abbreviate-depth 5
(lambda ()
(let ((menu (list-tail menu start))
(limit (+ start *menu-limit*)))
(if (not (null? menu))
(newline))
(let loop ((i start) (menu menu))
(cond ((null? menu))
((>= i limit) (display "[m] more...") (newline))
(else
(let ((item (car menu)))
(display "[")
(write i)
(if (car item)
(begin (display ": ")
(write (car item))))
(display "] ")
(write (value->expression (abbreviate (cadr item))))
(newline)
(loop (+ i 1) (cdr menu))))))))))
(define-command 'inspect "<exp>" "inspector (? for help)"
'(value) inspect)
(define (debug)
(inspect (command-loop-continuation)))
(define-command 'debug "" "inspect the stack"
'() debug)
(define (prepare-environment-menu env shape)
(if (vector? env)
(let ((values (reverse (cdr (vector->list env)))))
(if (pair? shape)
(append (map list (car shape) values)
(prepare-environment-menu (vector-ref env 0)
(cdr shape)))
(append (map (lambda (x) (list #f x)) values)
(prepare-environment-menu (vector-ref env 0) shape))))
'()))
; Returns a list of proper lists describing the environment in effect
; at the given pc with the given template's code vector.
;
; Entries in the environment-maps table (one per template) have the form
; #(parent-uid pc-in-parent (env-map ...))
;
; Each environment map (one per let or lambda-expression) has the form
; #(pc-before pc-after (var ...) (env-map ...))
;
; Cf. procedure (note-environment vars segment) in comp.scm.
(define (get-shape dd pc)
(if dd
(let loop ((emaps (debug-data-env-maps dd))
(shape (get-shape (get-debug-data
(debug-data-parent dd))
(debug-data-pc-in-parent dd))))
(if (null? emaps)
shape
(let ((pc-before (vector-ref (car emaps) 0))
(pc-after (vector-ref (car emaps) 1))
(vars (vector-ref (car emaps) 2))
(more-maps (vector-ref (car emaps) 3)))
(if (and (>= pc pc-before)
(< pc pc-after))
(loop more-maps
(cons (vector->list vars) shape))
(loop (cdr emaps) shape)))))
'()))