Copyright (C) 1994, Digital Equipment Corp.
MODULE GEFAlg;
IMPORT Algorithm, Atom, Fmt, gefeventIE, GEFLisp, RefList, SLisp, SLispClass,
Sx, Thread, ZeusCodeView, ZeusPanel;
REVEAL
Interp = PublicInterp BRANDED OBJECT
alg: Algorithm.T
OVERRIDES
init := InitInterp;
error := ParseError;
END;
PROCEDURE ParseError (<* UNUSED *> t: Interp; msg: TEXT): REFANY
RAISES {SLisp.Error} =
BEGIN
ZeusPanel.ReportError(msg);
RAISE SLisp.Error;
END ParseError;
PROCEDURE InitInterp (interp: Interp; alg: Algorithm.T): Interp =
BEGIN
EVAL SLisp.T.init(interp);
interp.alg := alg;
interp.defineFun(NEW(SLisp.Builtin, name := "StartFeedback", minArgs := 0,
maxArgs :=0, apply := StartFeedback));
interp.defineFun(NEW(SLisp.Builtin, name := "EndFeedback", minArgs := 0,
maxArgs := 0, apply := EndFeedback));
interp.defineFun(NEW(SLisp.Builtin, name := "Event", minArgs := 1,
maxArgs := LAST(INTEGER), apply := Event));
interp.defineFun(NEW(SLisp.Builtin, name := "Update", minArgs := 1,
maxArgs := LAST(INTEGER), apply := Update));
interp.defineFun(NEW(SLisp.Builtin, name := "Pause", minArgs := 0,
maxArgs := 0, apply := Pause));
interp.defineFun(
NEW(SLisp.Builtin, name := "CodeViewEvent", minArgs := 1,
maxArgs := 1, apply := CodeViewEvent));
interp.defineFun(
NEW(SLisp.Builtin, name := "CodeViewProc", minArgs := 1,
maxArgs := 1, apply := CodeViewProc));
interp.defineFun(
NEW(SLisp.Builtin, name := "CodeViewExit", minArgs := 0,
maxArgs := 0, apply := CodeViewExit));
GEFLisp.ZeusifyInterp(interp);
RETURN interp;
END InitInterp;
PROCEDURE Update (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
args: RefList.T ): REFANY
RAISES {SLisp.Error} =
BEGIN
RETURN Event1(i, args, TRUE);
END Update;
PROCEDURE Event (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
args: RefList.T ): REFANY
RAISES {SLisp.Error} =
BEGIN
RETURN Event1(i, args, FALSE);
END Event;
PROCEDURE StartFeedback (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
<* UNUSED *> args: RefList.T ): REFANY
RAISES {SLisp.Error} =
VAR interp: Interp := i;
BEGIN
TRY ZeusPanel.StartFeedback(interp.alg) EXCEPT | Thread.Alerted => END;
RETURN interp.varEval("t");
END StartFeedback;
PROCEDURE EndFeedback (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
<* UNUSED *> args: RefList.T ): REFANY
RAISES {SLisp.Error} =
VAR interp: Interp := i;
BEGIN
TRY ZeusPanel.EndFeedback(interp.alg) EXCEPT | Thread.Alerted => END;
RETURN interp.varEval("t");
END EndFeedback;
PROCEDURE Event1 (i: SLisp.T; args: RefList.T; update: BOOLEAN): REFANY
RAISES {SLisp.Error} =
VAR
interp: Interp := i;
name := interp.eval(args.head);
<* FATAL Sx.PrintError *>
BEGIN
TRY
TYPECASE name OF
| NULL => RETURN interp.error("No name given for event");
| TEXT (nm) =>
IF update THEN
gefeventIE.Update(
interp.alg, nm,
GEFLisp.QuoteList(GEFLisp.EvalList(interp, args.tail)));
ELSE
gefeventIE.Event(
interp.alg, nm,
GEFLisp.QuoteList(GEFLisp.EvalList(interp, args.tail)));
END;
ELSE
RETURN interp.error(Fmt.F("Bad value given for event name: %s",
SLispClass.SxToText(name)));
END;
EXCEPT
| Thread.Alerted => RAISE SLisp.Error
END;
RETURN NIL;
END Event1;
PROCEDURE Pause (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
<* UNUSED *> args: RefList.T ): REFANY
RAISES {SLisp.Error} =
VAR interp: Interp := i;
BEGIN
TRY
gefeventIE.Pause(interp.alg);
EXCEPT
| Thread.Alerted => RAISE SLisp.Error
END;
RETURN NIL;
END Pause;
PROCEDURE CodeViewEvent (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
args: RefList.T ): REFANY
RAISES {SLisp.Error} =
VAR
interp: Interp := i;
line := interp.eval(args.head);
BEGIN
TRY
TYPECASE line OF
| NULL =>
RETURN interp.error("No value given for CodeView event line");
| SLisp.Integer (ri) => ZeusCodeView.Event(interp.alg, ri^);
ELSE
RETURN interp.error("Bad value given for CodeView event line");
END;
EXCEPT
| Thread.Alerted => RAISE SLisp.Error
END;
RETURN NIL
END CodeViewEvent;
PROCEDURE CodeViewProc (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
args: RefList.T ): REFANY
RAISES {SLisp.Error} =
VAR
interp: Interp := i;
proc := interp.eval(args.head);
BEGIN
TRY
TYPECASE proc OF
| NULL =>
RETURN interp.error("No name given for CodeView procedure");
| TEXT (nm) => ZeusCodeView.Event(interp.alg, procedureName := nm);
ELSE
RETURN interp.error("Bad value given for CodeView procedure");
END;
EXCEPT
| Thread.Alerted => RAISE SLisp.Error
END;
RETURN NIL
END CodeViewProc;
PROCEDURE CodeViewExit (<*UNUSED*> self: SLisp.Builtin;
i : SLisp.T;
<* UNUSED *> args: RefList.T ): REFANY
RAISES {SLisp.Error} =
VAR interp: Interp := i;
BEGIN
TRY
ZeusCodeView.Exit(interp.alg);
RETURN NIL
EXCEPT
| Thread.Alerted => RAISE SLisp.Error
END;
END CodeViewExit;
PROCEDURE Feedback (interp: Interp; function: TEXT; args: RefList.T) =
<* FATAL SLisp.Error *>
BEGIN
WITH atom = Atom.FromText(function),
fun = interp.lookup(atom, SLispClass.LookupMode.LookupOnly) DO
TRY
IF fun # NIL AND fun.funDefined THEN
EVAL interp.eval(RefList.Cons(atom, args));
END;
EXCEPT
| SLisp.Error =>
END;
END;
END Feedback;
BEGIN
END GEFAlg.