;;; Debugger.mx
;;; Copyright Ó 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on August 15, 1989 3:33:52 pm PDT
;;; Cedar Primitives
(cedar-directory "SchemePrivate")
(cedar-imports "RefTab")
(define-ref-type "Scheme" "Environment")
(define-ref-type "Scheme" "Symbol")
(define-ref-type "SchemePrivate" "Activation")
(define-proc (
make-environment id (parent))
"Construct a new top-level environment"
parentEnv: Environment ~ IF parent = undefined THEN NIL ELSE TheEnvironment[parent];
env: Environment ~ NEW[EnvironmentRep[2]];
IF parentEnv #
NIL
AND parentEnv.names =
NIL
THEN
Complain[parent, "not a top-level environment"];
env.parent ← parentEnv;
env[1] ← id;
env.names ← NIL;
env[0] ← RefTab.Create[];
env.mark ← 100;
result ← env;
)
(define-proc (
environment-parent env)
"Return the parent of the given environment"
result ← TheEnvironment[env].parent;
IF result = NIL THEN result ← false;
)
(define-proc (
environment? value)
"Is VALUE an environment?"
result ← IF ISTYPE[value, Environment] THEN true ELSE false;
)
(define-proc (top-level-environment? value)
"Is VALUE a top-level environment?"
WITH value SELECT FROM
env: Environment => result ← IF env.names = NIL THEN true ELSE false;
ENDCASE => result ← false;
)
(define-proc (
environment-ref env symbol)
"Return the value of SYMBOL in ENV"
result ← LookupVariableValue[symbol, TheEnvironment[env]];
)
(define-proc (
environment-set! env symbol value)
"Set the value of SYMBOL in ENV to VALUE"
IF SetVariableValue[TheSymbol[symbol], value, TheEnvironment[env]]
THEN
result ← unspecified
ELSE
Complain[symbol, "undefined variable cannot be set"];
)
(define-proc (
environment-define! env symbol value)
"Bind SYMBOL to VALUE in ENV"
DefineVariable[TheSymbol[symbol], value, TheEnvironment[env]];
result ← symbol;
)
(define-proc (
environment-bound? env symbol)
"Bind SYMBOL to VALUE in ENV"
result ← true;
[] ← LookupVariableValue[TheSymbol[symbol], TheEnvironment[env]
! Complain => {
result ← false;
CONTINUE;
}];
)
(define-proc (
%environment->alist value)
"PRIVATE: Used in definition of walk-environment"
env: Environment ~ TheEnvironment[value];
IF env.names =
NIL
THEN {
Inner: RefTab.EachPairAction = {
[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL ← FALSE]
result ← Cons[Cons[key, Cdr[val]], result]
};
result ← NIL;
[] ← RefTab.Pairs[x: NARROW[env[0]], action: Inner];
}
ELSE {
names: SimpleVector ← env.names;
result ← NIL;
FOR i:
INT
IN [0..names.length)
DO
result ← Cons[Cons[names[i], env[i]], result];
ENDLOOP;
};
)
(define-proc (
frame-link frame)
"Return the frame for the caller of this frame."
a: SchemePrivate.Activation ~ TheActivation[frame].link;
result ← IF a = NIL THEN false ELSE a;
)
(define-proc (
frame-name frame)
"Return the name of the active procedure for this frame."
result ← TheActivation[frame].code.name;
)
(define-proc (
frame-environment frame)
"Return the environment for this frame."
result ← TheActivation[frame].env;
)
;;; The debugger
(define *debugger-level* (make-dynamic 0))
(define (*system-error-handler* parent-frame name culprit message)
(define (real-error-handler)
(format #t "~L(Type '?' for help in using the debugger.)~L~%" "i" "I")
(dynamic-bind ((*debugger-level* (+ (dynamic-ref *debugger-level*) 1)))
(let loop ((current-frame parent-frame))
(format #t "~LDebug ~S>~L " "b" (dynamic-ref *debugger-level*) "B")
(let* ((input (read))
(command (if (eof-object? input) ':q input)))
(define (print-frame-name frame)
(format #t "~L~S~L~%" "f" (frame-name frame) "F"))
(define (print-variables env indent)
(when (environment-parent env)
(walk-environment
(lambda (name value)
(format #t "~L~A~S: ~S~L~%" "f" indent name value "F"))
env)))
(define (protected-eval expr env)
(call-with-current-continuation
(lambda (k)
(dynamic-bind ((*top-level-continuation* k))
(eval expr env)))))
(case command
((?)
(display
"Type a command or an expression to be evaluated in the top-level environment. The following commands are available:
? Prints this message.
:bt Print a backtrace.
:fr Prints variables in current frame.
:fr* Same as :fr, but includes nested scopes.
:f Moves on to the next outer continuation frame.
:b Moves back to the previous continuation frame.
:r Resumes the computation with a value provided by the user.
:q Aborts to top level.
")
(loop current-frame))
((:bt)
(change-looks "f")
(let inner ((frame parent-frame))
(unless (not frame)
(format #t "~A~S~%"
(if (eq? frame current-frame) "=> " " ")
(frame-name frame))
(inner (frame-link frame))))
(change-looks "F")
(loop current-frame))
((:fr)
(print-frame-name current-frame)
(newline)
(print-variables (frame-environment current-frame) " ")
(newline)
(loop current-frame))
((:fr*)
(print-frame-name current-frame)
(newline)
(let inner ((env (frame-environment current-frame))
(indent " "))
(when env
(print-variables env indent)
(inner
(environment-parent env)
(string-append indent " "))))
(newline)
(loop current-frame))
((:f)
(let ((new-frame (frame-link current-frame)))
(cond
((not new-frame)
(format #t "No next frame.~%")
(loop current-frame))
(else
(print-frame-name new-frame)
(loop new-frame)))))
((:b)
(cond
((eq? current-frame parent-frame)
(format #t "No previous frame.~%")
(loop current-frame))
(else
(let inner ((frame parent-frame))
(cond
((eq? (frame-link frame) current-frame)
(print-frame-name frame)
(loop frame))
(else
(inner (frame-link frame))))))))
((:r)
(format #t "Returning a value to ~S.~%" (frame-name parent-frame))
(format #t "The following expression will be evaluated in the top-level environment.~%")
(format #t "~%Expression to supply value (CR to abort resumption): ")
;; Skip extra CR following command
(let loop ((char (read-char)))
(unless (char=? char #\Newline)
(loop (read-char))))
(let ((char (read-char)))
(cond
((char=? char #\Newline)
(loop current-frame))
(else
(unread-char char)
(protected-eval (read) user)))))
((:q)
((dynamic-ref *top-level-continuation*) "Back to top level"))
(else
(format #t "~L~S~L~%" "i" (protected-eval command user) "I")
(loop current-frame)))))))
(format #t "~%~LError~L in ~L~S~L:~L ~A~L~%"
"zi" "Z" "If" name "F" "i" message "I")
(format #t "~L ~S~L~%~%" "f" culprit "F")
(if (null? parent-frame)
((dynamic-ref *top-level-continuation*) "Back to top level")
(real-error-handler)))