402 lines
12 KiB
Scheme
402 lines
12 KiB
Scheme
|
; Copyright (c) 1993, 1994 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.
|
||
|
|
|
||
|
|
; Eventually, integrate this better with the command processor.
|
||
|
|
|
||
|
|
; Inspector state:
|
||
|
|
; thing = (focus-object)
|
||
|
|
; menu = (prepare-menu thing)
|
||
|
|
; start = position within menu; modified by M (more) command
|
||
|
|
; stack = list of other things
|
||
|
|
|
||
|
|
(define *menu-limit* 15)
|
||
|
|
(define *write-depth* 3)
|
||
|
|
(define *write-length* 5)
|
||
|
|
|
||
|
|
(define (with-limited-output thunk)
|
||
|
|
(let-fluids $write-depth *write-depth*
|
||
|
|
$write-length *write-length*
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (make-inspector-state menu position stack)
|
||
|
|
(cons (cons position menu) stack))
|
||
|
|
(define $inspector-state (make-fluid (make-inspector-state '() 0 '())))
|
||
|
|
|
||
|
|
(define-command-syntax 'inspect "[<exp>]" "invoke the inspector"
|
||
|
|
'(&opt form))
|
||
|
|
|
||
|
|
(define-command-syntax 'debug "" "inspect the current continuation" '())
|
||
|
|
|
||
|
|
(define (debug)
|
||
|
|
(showing-focus-object
|
||
|
|
(lambda ()
|
||
|
|
(set-focus-object! (command-continuation))))
|
||
|
|
(inspect))
|
||
|
|
|
||
|
|
(define (inspect . maybe-exp)
|
||
|
|
(if (not (null? maybe-exp))
|
||
|
|
(with-limited-output
|
||
|
|
(lambda ()
|
||
|
|
(showing-focus-object
|
||
|
|
(lambda ()
|
||
|
|
(evaluate-and-select (car maybe-exp)
|
||
|
|
(environment-for-commands)))))))
|
||
|
|
(let-fluid $inspector-state
|
||
|
|
(make-inspector-state (prepare-menu (focus-object)) 0 '())
|
||
|
|
(lambda ()
|
||
|
|
(present-menu)
|
||
|
|
(let loop ()
|
||
|
|
(let ((command (read-command-carefully "inspect: "
|
||
|
|
#f ;command preferred
|
||
|
|
(command-input)
|
||
|
|
inspector-commands)))
|
||
|
|
(cond ((eof-object? command)
|
||
|
|
(newline (command-output))
|
||
|
|
(unspecific))
|
||
|
|
((not command) ; read command error
|
||
|
|
(loop))
|
||
|
|
(else
|
||
|
|
(with-limited-output
|
||
|
|
(lambda ()
|
||
|
|
(execute-inspector-command command)))
|
||
|
|
(loop))))))))
|
||
|
|
|
||
|
|
(define (present-menu)
|
||
|
|
(let ((pos+menu (car (fluid $inspector-state))))
|
||
|
|
(display-menu (cdr pos+menu)
|
||
|
|
(car pos+menu)
|
||
|
|
(command-output))))
|
||
|
|
|
||
|
|
(define (new-selection thing stack)
|
||
|
|
(set-fluid! $inspector-state
|
||
|
|
(make-inspector-state (prepare-menu thing) 0 stack)))
|
||
|
|
|
||
|
|
(define (read-selection-command port)
|
||
|
|
(let ((x (read port)))
|
||
|
|
(if (or (integer? x)
|
||
|
|
(memq x '(u d t)))
|
||
|
|
x
|
||
|
|
(read-command-error port "invalid selection command" x))))
|
||
|
|
|
||
|
|
(define selection-command-syntax (list '&rest read-selection-command))
|
||
|
|
|
||
|
|
(define (inspector-commands name)
|
||
|
|
(if (integer? name)
|
||
|
|
selection-command-syntax
|
||
|
|
(case name
|
||
|
|
((? m q) '()) ; no arguments
|
||
|
|
((u d t) selection-command-syntax)
|
||
|
|
(else #f))))
|
||
|
|
|
||
|
|
(define (execute-inspector-command command)
|
||
|
|
(let ((result-before (focus-object))
|
||
|
|
(state-before (fluid $inspector-state)))
|
||
|
|
|
||
|
|
(showing-focus-object
|
||
|
|
(lambda ()
|
||
|
|
|
||
|
|
(let ((name (car command)))
|
||
|
|
(if (integer? name)
|
||
|
|
(execute-selection-command command)
|
||
|
|
(case name
|
||
|
|
((u d t)
|
||
|
|
(execute-selection-command command))
|
||
|
|
((m) (inspect-more))
|
||
|
|
((q) (abort-to-command-level (car (fluid $command-levels))))
|
||
|
|
((?) (inspect-help))
|
||
|
|
(else (execute-command command)))))))
|
||
|
|
|
||
|
|
(let ((result-after (focus-object))
|
||
|
|
(state-after (fluid $inspector-state)))
|
||
|
|
;; Prepare & display a new menu if we're looking at
|
||
|
|
;; a new thing. Push old thing on stack only if
|
||
|
|
;; no one's been futzing with the stack.
|
||
|
|
(if (not (eq? result-after result-before))
|
||
|
|
(begin (if (eq? state-after state-before)
|
||
|
|
(new-selection result-after
|
||
|
|
(cons result-before
|
||
|
|
(cdr state-before))))
|
||
|
|
(present-menu))))))
|
||
|
|
|
||
|
|
(define (execute-selection-command command)
|
||
|
|
(if (not (null? command))
|
||
|
|
(let ((name (car command)))
|
||
|
|
(if (integer? name)
|
||
|
|
(let ((menu (cdar (fluid $inspector-state))))
|
||
|
|
(if (and (>= name 0)
|
||
|
|
(< name (length menu)))
|
||
|
|
(move-to-object! (menu-ref menu name))
|
||
|
|
(write-line "Invalid choice." (command-output))))
|
||
|
|
(case name
|
||
|
|
((u) (pop-inspector-stack))
|
||
|
|
((d) (inspect-next-continuation))
|
||
|
|
((t) (select-template))
|
||
|
|
(else (error "bad selection command" name))))
|
||
|
|
(execute-selection-command (cdr command)))))
|
||
|
|
|
||
|
|
(define (move-to-object! object)
|
||
|
|
(new-selection object
|
||
|
|
(cons (focus-object)
|
||
|
|
(cdr (fluid $inspector-state))))
|
||
|
|
(set-focus-object! object))
|
||
|
|
|
||
|
|
(define (pop-inspector-stack)
|
||
|
|
(let ((stack (cdr (fluid $inspector-state))))
|
||
|
|
(if (pair? stack)
|
||
|
|
(begin (new-selection (car stack) (cdr stack))
|
||
|
|
(set-focus-object! (car stack)))
|
||
|
|
(write-line "Can't go up from here." (command-output)))))
|
||
|
|
|
||
|
|
(define (inspect-next-continuation)
|
||
|
|
(if (continuation? (focus-object))
|
||
|
|
(move-to-object! (continuation-parent (focus-object)))
|
||
|
|
(write-line "Can't go down from a non-continuation." (command-output))))
|
||
|
|
|
||
|
|
(define (inspect-more)
|
||
|
|
(let* ((state (fluid $inspector-state))
|
||
|
|
(pos+menu (car state))
|
||
|
|
(menu (cdr pos+menu))
|
||
|
|
(position (car pos+menu)))
|
||
|
|
(if (> (length menu) (+ *menu-limit* position))
|
||
|
|
(let ((position (- (+ position *menu-limit*) 1)))
|
||
|
|
(set-car! pos+menu position)
|
||
|
|
(present-menu))
|
||
|
|
(write-line "There is no more." (command-output)))))
|
||
|
|
|
||
|
|
(define (select-template)
|
||
|
|
(move-to-object! (coerce-to-template (focus-object))))
|
||
|
|
|
||
|
|
(define (inspect-help)
|
||
|
|
(let ((o-port (command-output)))
|
||
|
|
(for-each (lambda (s) (display s o-port) (newline o-port))
|
||
|
|
'("q quit"
|
||
|
|
"u up stack (= go to previous object)"
|
||
|
|
"d down stack"
|
||
|
|
"t template"
|
||
|
|
"<form> evaluate a form (## is current object)"
|
||
|
|
"<integer> menu item"
|
||
|
|
"or any command processor command"
|
||
|
|
"multiple u d t <integer> commands can be put on one line"))))
|
||
|
|
|
||
|
|
|
||
|
|
(define (menu-ref menu n)
|
||
|
|
(cadr (list-ref menu n)))
|
||
|
|
|
||
|
|
|
||
|
|
; Menus.
|
||
|
|
|
||
|
|
(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)))
|
||
|
|
|
||
|
|
((template? thing)
|
||
|
|
(prepare-menu (template->list thing)))
|
||
|
|
|
||
|
|
((continuation? thing)
|
||
|
|
(prepare-continuation-menu thing))
|
||
|
|
|
||
|
|
((record? thing)
|
||
|
|
(prepare-record-menu thing))
|
||
|
|
|
||
|
|
((location? thing)
|
||
|
|
`((id ,(location-id thing))
|
||
|
|
(contents ,(contents thing))))
|
||
|
|
|
||
|
|
((weak-pointer? thing)
|
||
|
|
`((ref ,(weak-pointer-ref thing))))
|
||
|
|
|
||
|
|
(else '())))
|
||
|
|
|
||
|
|
(define (template->list template)
|
||
|
|
(do ((i (- (template-length template) 1) (- i 1))
|
||
|
|
(r '() (cons (template-ref template i) r)))
|
||
|
|
((< i 0) r)))
|
||
|
|
|
||
|
|
(define (prepare-continuation-menu thing)
|
||
|
|
(let ((dd (continuation-debug-data thing))
|
||
|
|
(next (continuation-parent thing)))
|
||
|
|
`(,@(let recur ((c thing))
|
||
|
|
(if (eq? c next)
|
||
|
|
'()
|
||
|
|
(let ((z (continuation-arg-count c)))
|
||
|
|
(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 (continuation-debug-data thing)
|
||
|
|
(template-debug-data (continuation-template 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-type-field-names rt)) (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 (prepare-environment-menu env shape)
|
||
|
|
(if (vector? env)
|
||
|
|
(let ((values (rib-values 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))))
|
||
|
|
'()))
|
||
|
|
|
||
|
|
(define (rib-values env)
|
||
|
|
(let ((z (vector-length env)))
|
||
|
|
(do ((i 1 (+ i 1))
|
||
|
|
(l '() (cons (if (vector-unassigned? env i)
|
||
|
|
'unassigned
|
||
|
|
(vector-ref env i))
|
||
|
|
l)))
|
||
|
|
((>= i z) l))))
|
||
|
|
|
||
|
|
; 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)))))
|
||
|
|
'()))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
; Information display
|
||
|
|
|
||
|
|
(define (display-menu menu start port)
|
||
|
|
(newline port)
|
||
|
|
(let ((thing (focus-object)))
|
||
|
|
(if (continuation? thing)
|
||
|
|
(let ((dd (continuation-debug-data thing)))
|
||
|
|
(if dd
|
||
|
|
(let ((source (assoc (continuation-pc thing)
|
||
|
|
(debug-data-source dd))))
|
||
|
|
(if source
|
||
|
|
(display-source-info (cdr source))))))))
|
||
|
|
(let ((menu (list-tail menu start))
|
||
|
|
(limit (+ start *menu-limit*)))
|
||
|
|
(let loop ((i start) (menu menu))
|
||
|
|
(with-limited-output
|
||
|
|
(lambda ()
|
||
|
|
(cond ((null? menu))
|
||
|
|
((and (>= i limit)
|
||
|
|
(not (null? (cdr menu))))
|
||
|
|
(display " [m] more..." port) (newline port))
|
||
|
|
(else
|
||
|
|
(let ((item (car menu)))
|
||
|
|
(display " [" port)
|
||
|
|
(write i port)
|
||
|
|
(if (car item)
|
||
|
|
(begin (display ": " port)
|
||
|
|
(write-carefully (car item) port)))
|
||
|
|
(display "] " port)
|
||
|
|
(write-carefully
|
||
|
|
(value->expression (cadr item))
|
||
|
|
port)
|
||
|
|
(newline port)
|
||
|
|
(loop (+ i 1) (cdr menu))))))))))
|
||
|
|
|
||
|
|
(define (display-source-info info)
|
||
|
|
(if (pair? info)
|
||
|
|
(let ((o-port (command-output))
|
||
|
|
(i (car info))
|
||
|
|
(exp (cdr info)))
|
||
|
|
(if (and (integer? i) (list? exp))
|
||
|
|
(begin
|
||
|
|
(display "Waiting for " o-port)
|
||
|
|
(limited-write (list-ref exp i) o-port
|
||
|
|
*write-depth* *write-length*)
|
||
|
|
(newline o-port)
|
||
|
|
(display " in " o-port)
|
||
|
|
(limited-write (append (sublist exp 0 i)
|
||
|
|
(list '^^^)
|
||
|
|
(list-tail exp (+ i 1)))
|
||
|
|
o-port
|
||
|
|
*write-depth* *write-length*)
|
||
|
|
(newline o-port))))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define (where-defined thing)
|
||
|
|
(let loop ((dd (template-debug-data (closure-template thing))))
|
||
|
|
(if (debug-data? dd)
|
||
|
|
(if (string? (debug-data-name dd))
|
||
|
|
(debug-data-name dd)
|
||
|
|
(loop (debug-data-parent dd)))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(define-command-syntax 'where "[<procedure>]"
|
||
|
|
"show procedure's source file name"
|
||
|
|
'(&opt expression))
|
||
|
|
|
||
|
|
(define (where . maybe-exp)
|
||
|
|
(let ((proc (if (null? maybe-exp)
|
||
|
|
(focus-object)
|
||
|
|
(evaluate (car maybe-exp) (environment-for-commands))))
|
||
|
|
(port (command-output)))
|
||
|
|
(if (procedure? proc)
|
||
|
|
(let ((probe (where-defined proc)))
|
||
|
|
(if probe
|
||
|
|
(display probe port)
|
||
|
|
(display "Source file not recorded" port)))
|
||
|
|
(display "Not a procedure" port))
|
||
|
|
(newline port)))
|
||
|
|
|
||
|
|
|
||
|
|
(define (coerce-to-template obj) ;utility for various commands
|
||
|
|
(cond ((template? obj) obj)
|
||
|
|
((closure? obj) (closure-template obj))
|
||
|
|
((continuation? obj) (continuation-template obj))
|
||
|
|
(else (error "expected a procedure or continuation" obj))))
|