

(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 (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 = {
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;
)


(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)))


(define *top-level-continuation* (make-dynamic #f))

(call/cc (lambda (k) (dynamic-set! *top-level-continuation* k)))
    
;;; 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
(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;
)

[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL _ FALSE]
;;; The debugger
;;; Throwing to top-level
;;; NB: This code must come last in the file!!
‌تع  –(cedarcode) style•NewlineDelimiter
™ ™Jڑœذetœ7™FJ™;—Jک ™Jک Jک!JکJک Jک(Jک#Jک.Jک ڑœدbœک+Jک'Icedarڑ	œدkœںœںœںœکTIcodeڑœںœک*ڑ
ںœںœںœںœںœک2Lک0—LڑœکLڑœکLڑœںœکLڑœکLڑœکLڑœکJکJک —ڑœ‍œک%Jک,Lک$Lڑںœ
ںœںœک$JکJک —ڑœ‍œک!JکKڑ	œ	ںœںœںœںœک<IschemeکMک —ڑœ‍œ™+J™#ڑںœںœں™Lڑ	œںœںœںœںœ™ELڑںœ™—M™M™ —ڑœ‍œک)Mڑœ#ک#Kک:MکMک —ڑœ‍œک0Mڑœ)ک)ڑںœAںکGLک—ڑںکLڑœ5ک5—MکMک —ڑœ‍œک3MڑœکLڑœ>ک>LڑœکMکMک —ڑœ‍œک,MڑœکLڑœکڑœ?ک?ڑœکLڑœکLڑںœک	Lڑœک——MکMک —ڑœ‍œک(Mڑœ1ک1Lک)ڑںœںœںœکڑدnœک Lڑذck?™?Lڑœ*ک*Lک—L•StartOfExpansion2[x: RefTab.Ref, action: RefTab.EachPairAction]ڑœ	ںœکLڑœںœک4Lڑœک—ڑںœکLڑœ ک L–2[x: RefTab.Ref, action: RefTab.EachPairAction]ڑœ	ںœکڑںœںœںœںک"Lک.Lڑںœک—Lڑœک—Mک—Mک ڑœ‍
œکMک0Kک8Kڑ	œ	ںœںœںœںœک&MکMک —ڑœ‍
œکMک9Kک(MکMک —ڑœ‍œک&Mک(Kڑœ"ک"Mک——Jک ™Jک Jک*Jک ڑœBکBڑœکJکFJک ڑœGکGڑœ(ک(JکCڑœکJک2ڑœ ک Jک2—Jک ڑœ$ک$ڑœککڑœکJک7—Jک———Jک ک!ککڑœ,ک,Jک————Jک ڑœککJڑœدکدJک—کJکک!ککJک*Jک—Jک——JکJک—کJڑœ ک Jک	Jڑœ:ک:Jک	Jک—کJڑœ ک Jک	ک3Jکک	JککJکJک ———Jک	Jک—کک-ککJکJک—کJڑœکJک————ککک!Jک"Jک—کک!کک'JڑœکJک—کJک ——————کJکBJکXJکEJک"ککJک——کککJک—کJکJک ————کJک=—کJک<Jک—Jک —————Jک JڑœTکTJک.ڑœکJک<Jڑœک—Jک ——Jک J™ڑœ‍*™.Jک Jک3Jک Jک@—— …—    ‚  p  