conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/newpcs/pinspect.s

368 lines
11 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

; -*- Mode: Lisp -*- Filename: pinspect.s
; Last Revision: 12-Nov-85 1400ct
;--------------------------------------------------------------------------;
; ;
; TI SCHEME -- PCS Compiler ;
; Copyright 1985 (c) Texas Instruments ;
; ;
; David Bartley ;
; ;
; The Inspector and %PCS-EDIT-BINDING ;
; ;
;--------------------------------------------------------------------------;
(define %inspect ; %INSPECT
(lambda (cur-env)
(cond ((environment? cur-env)
(%inspector '() '() '()
cur-env
(%reify-stack (+ (%reify-stack -1) 6))
0))
((closure? cur-env)
(%inspect (procedure-environment cur-env)))
(else
(display "Invalid operand to INSPECT: ")
(display cur-env)))))
(define %inspector ; %inspector
(letrec
((table
'((1 . "All") ; ctrl-A
(2 . "Backtrace calls") ; ctrl-B
(3 . "Current environment frame") ; ctrl-C
(4 . "Down to callee") ; ctrl-D
(5 . "Edit: ") ; ctrl-E
(7 . "Go") ; ctrl-G
(9 . "Inspect: ") ; ctrl-I
(12 . "List Procedure") ; ctrl-L
(13 . "Repeat Breakpoint Message") ; ctrl-M
(16 . "`Parent' environment frame") ; ctrl-P
(17 . "Quit") ; ctrl-Q
(18 . "Return with the value: ") ; ctrl-R
(19 . "`Son' environment frame") ; ctrl-S
(21 . "Up to caller") ; ctrl-U
(22 . "Value of: ") ; ctrl-V
(23 . "Where am I?") ; ctrl-W
(#\SPACE . "Value of: ")
(#\! . "Reinitialize INSPECT!")
(#\? . "?")))
(repl
(lambda ()
(pcs-clear-registers)
(fresh-line)
(newline)
(display "[Inspect] ")
(flush-input)
(let* ((ch (read-char))
(key (if (memv ch '(#\SPACE #\! #\?))
ch
(char->integer ch)))
(entry (assv key table)))
(when entry
(display (cdr entry)))
(case key
(1 (all cur-env 0)(repl)) ; ctrl-A
(2 (newline)(where stk-index) ; ctrl-B
(backtrace stk-index)(repl))
(3 (newline) ; ctrl-C
(current cur-env 0 #!true)
(repl))
(4 (newline) ; ctrl-D
(down)(repl))
(5 (let ((ans ; ctrl-E
(%pcs-edit-binding '() (read) cur-env)))
(when (string? ans)(display ans))
(repl)))
((7 18) ; ctrl-G, ctrl-R
(leave key))
(12 (newline) ; ctrl-L
(pp (%reify-stack (+ stk-index 15)))
(repl))
(13 (newline) ; ctrl-M
(display kind)
(when kind
(when msg (display msg))
(newline)
(write irritant))
(repl))
(16 (newline) ; ctrl-P
(parent cur-env)(repl))
(17 (reset)) ; ctrl-Q
(19 (newline) ; ctrl-S
(son)(repl))
(21 (newline) ; ctrl-U
(up)(repl))
((22 #\SPACE)
(pp (eval (read) cur-env)) ; ctrl-V, SPACE
(repl))
(23 (newline) ; ctrl-W
(where stk-index)(repl))
(#\! (newline)(init)(repl)) ; !
(#\? (newline) ; ?
(help)(repl))
(else
(if (eqv? key 9) ; ctrl-I
(let ((env (eval (read) cur-env)))
(cond ((or (environment? env)
(closure? env)
(delayed-object? env))
(set! (fluid %inspector-continuation) '())
(%inspect env))
(else
(display (integer->char 7)) ; beep
(display " ? Not an environment: ")
(write env)))
(repl))
(begin
(display (integer->char 7)) ; beep
(display " ? Invalid response... Type `?' for help")
(repl))))))
))
(All
(lambda (env depth)
(fresh-line)
(when (and env (not (eq? env user-global-environment)))
(current env depth #!true)
(all (environment-parent env) (+ depth 1)))))
(Backtrace
(lambda (stk-index)
(let ((si (%reify-stack (+ stk-index 6))))
(fresh-line)
(when (positive? si)
(display " called from ")
(display (%reify-stack (+ si 15)))
(backtrace si)))))
(Current
(lambda (env depth verbose?)
(when verbose?
(display "Environment frame bindings at level ")
(display (+ depth (length son-stk)))
(cond ((eq? env user-initial-environment)
(display " (USER-INITIAL-ENVIRONMENT)"))
((eq? env user-global-environment)
(display " (USER-GLOBAL-ENVIRONMENT)"))))
(when (or verbose?
(=? (%reify env -1) 12)) ; not a global environment
(let ((frame (environment-bindings env)))
(if (null? frame)
(begin
(newline)
(display " --no variables--"))
(let loop ((pairs frame))
(when pairs
(newline)
(display " ")
(if (char-ready?)
(display "[aborted]")
(let ((val (cdar pairs)))
(display (caar pairs)) ; var
(display " ")
(tab27 (current-column))
(cond ((pair? val)
(display "-- list --"))
((vector? val)
(display "-- vector --"))
(else (write val)))
(loop (cdr pairs))))))
)))))
(Down
(lambda ()
(if (null? down-stk)
(display " ? Can't move Down")
(let ((si (car down-stk)))
(set! down-stk (cdr down-stk))
(set! stk-index si)
(set! son-stk '())
(set! cur-env (%reify-stack (+ si 9)))
(where si)))))
(Leave
(lambda (key)
(cond ((not (zero? exit-code))
(newline)
(display " ? Sorry, the program is not resumable")
(repl))
((eqv? key 7) ; ctrl-G
(newline)
'())
((memq msg '(BREAK-ENTRY BREAK-EXIT))
((fluid %*BREAK*continuation) (eval (read) cur-env)))
(else
(newline)
(display " ? Sorry, use `ctrl-R' only to return from BREAK")
(repl)))))
(Parent
(lambda (env)
(let ((penv (environment-parent env)))
(if (null? penv)
(display " ? No parent exists")
(begin
(set! son-stk (cons env son-stk))
(set! cur-env penv)
(current penv 0 #!true))))))
(Son
(lambda ()
(if (null? son-stk)
(display " ? No son exists")
(begin
(set! cur-env (car son-stk))
(set! son-stk (cdr son-stk))
(current cur-env 0 #!true)))))
(Up
(lambda ()
(let ((si (%reify-stack (+ stk-index 6))))
(if (positive? si)
(begin
(set! down-stk (cons stk-index down-stk))
(set! son-stk '())
(set! cur-env (%reify-stack (+ si 9)))
(set! stk-index si)
(where si))
(display " ? Can't move Up")))))
(Where
(lambda (si)
(display "Stack frame for ")
(display (%reify-stack (+ si 15)))
(current cur-env 0 #!false) ))
(tab27
(lambda (cur)
(cond ((>? 24 cur) (display " ")(tab27 (+ cur 3)))
((>? 27 cur) (display " ") (tab27 (+ cur 1)))
((= 27 cur) cur)
(else (newline) (tab27 1)))))
(init
(lambda ()
(set! son-stk '())
(set! down-stk '())
(set! cur-env orig-env)
(set! stk-index orig-stk-index) ))
(help
(lambda ()
(mapc (lambda (x)(display x))
'(" ? -- display this command summary" #\newline
" ! -- reinitialize INSPECT" #\newline
" ctrl-A -- display All environment frame bindings" #\newline
" ctrl-B -- display procedure call Backtrace" #\newline
" ctrl-C -- display Current environment frame bindings" #\newline
" ctrl-D -- move Down to callee's stack frame" #\newline
" ctrl-E -- Edit variable binding" #\newline
" ctrl-G -- Go (resume execution)" #\newline
" ctrl-I -- evaluate one expression and Inspect the result"
#\newline
" ctrl-L -- List current procedure" #\newline
" ctrl-M -- repeat the breakpoint Message" #\newline
" ctrl-P -- move to Parent environment's frame" #\newline
" ctrl-Q -- Quit (RESET to top level)" #\newline
" ctrl-R -- Return from BREAK with a value" #\newline
" ctrl-S -- move to Son environment's frame" #\newline
" ctrl-U -- move Up to caller's stack frame" #\newline
" ctrl-V -- eValuate one expression in current environment"
#\newline
" ctrl-W -- (Where) Display current stack frame" #\newline
"To enter `ctrl-A', press both `CTRL' and `A'."
))))
;; data
(down-stk '())
(son-stk '())
(orig-env '())
(orig-stk-index '())
(msg '())
(kind '())
(irritant '())
(cur-env '())
(stk-index '())
(exit-code '())
)
(lambda (msg0 kind0 irritant0 cur-env0 stk-index0 exit-code0)
(if (and (fluid-bound? %inspector-continuation)
(not (null? (fluid %inspector-continuation))))
((fluid %inspector-continuation) '())
(fluid-let ((%inspector-continuation '()))
(set! msg msg0)
(set! kind kind0)
(set! irritant irritant0)
(set! cur-env cur-env0)
(set! stk-index stk-index0)
(set! exit-code exit-code0)
(set! orig-env cur-env0)
(set! orig-stk-index stk-index0)
(init)
(call/cc
(lambda (k)
(set! (fluid %inspector-continuation) k)))
(repl)))
)))
;;; %PCS-EDIT-BINDING
;;;
;;; argument OBJ: () or value to be edited
;;; optional arg NAME: symbol
;;; optional arg ENV: environment for name
;;;
;;; When NAME and ENV are not supplied, %PCS-EDIT-BINDING calls the
;;; editor to edit OBJ.
;;;
;;; When NAME and ENV are supplied, %PCS-EDIT-BINDING calls the editor
;;; to create a new binding for the name in the environment. If OBJ is
;;; nil, the current binding of NAME in ENV is edited instead of OBJ.
;;;
;;; returns either (1) an error message string or
;;; (2) (LIST edited-value)
(define %pcs-edit-binding
(letrec ((help
(lambda (obj name)
(if (closure? obj)
(let ((info (assq 'SOURCE (%reify obj 0))))
(if (null? info)
"[No source found for compiled procedure.]"
(let ((new (edit (cdr info))))
(if (and (pair? new)
(eq? (car new) 'LAMBDA))
(let ((mode pcs-debug-mode))
(set! pcs-debug-mode #!true)
(let ((value (eval new)))
(set! pcs-debug-mode mode)
(%reify! value 0
(cons (cons 'SOURCE new) name))
(list value)))
(list new)))))
(list (edit obj))))))
(lambda (obj . rebind)
(if (null? rebind)
(help obj rebind)
(let ((name (car rebind))
(env (cadr rebind)))
(if (and (symbol? name)(environment? env))
(let ((value-list (help (or obj (cdr (%env-lu name env)))
name)))
(if (atom? value-list)
value
(let ((value (car value-list))
(cell (%env-lu name env)))
(if (null? cell)
(%define name value env)
(set-cdr! cell value)))))
"[Invalid argument]"))))))

Reference in New Issue View Git Blame Copy Permalink