Copyright (C) 1994, Digital Equipment Corp.
MODULE GEFView EXPORTS GEFView, GEFViewClass;
IMPORT Algorithm, Bundle, CodeView, Filename, FileRd, Filter, Fmt,
FormsVBT, gefBundle, gefeventAlgClass, gefeventViewClass,
gefeventTranscriptView, gefeventIE, GEF, GEFAlg,
GEFClass, GEFError, GEFLisp, GraphVBTExtras,
OSError, RefList, Rd, IntRefTbl, Rect, Rsrc,
SLisp, SLispClass, Sx, Text, TextRd, Thread, VBT, View AS ZeusView,
ZeusClass, ZeusCodeView, ZeusPanel, ZeusPanelFriends;
--------------------------- Interpreter -----------------------
REVEAL
Interp = SLisp.T BRANDED OBJECT
rd: Rd.T;
intervals: IntRefTbl.T;
view: ZeusView.T;
OVERRIDES
init := InitInterp;
error := ParseError;
END;
PROCEDURE InitInterp (interp: SLisp.T): SLisp.T =
BEGIN
EVAL SLisp.T.init(interp);
interp.defineFun(NEW(SLisp.Builtin, name := "Feedback", minArgs := 1,
maxArgs := LAST(INTEGER), apply := SLispFeedback));
RETURN interp;
END InitInterp;
PROCEDURE SLispFeedback (<*UNUSED*> self: SLisp.Builtin; i: SLisp.T; args: RefList.T):
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 feedback event");
| TEXT (nm) =>
gefeventIE.Feedback(
interp.view, nm, GEFLisp.QuoteList(GEFLisp.EvalList(interp, args.tail)));
ELSE
RETURN interp.error(Fmt.F("Bad value given for feedback event name: %s",
SLispClass.SxToText(name)));
END;
EXCEPT
| Thread.Alerted => RAISE SLisp.Error
END;
RETURN NIL;
END SLispFeedback;
TYPE
ErrorClosure = Thread.Closure OBJECT
msg : TEXT;
interp : Interp;
evalStack: RefList.T;
OVERRIDES
apply := ErrorApply;
END;
PROCEDURE FindSx (t: IntRefTbl.T; form: SLisp.Sexp): SLispClass.Range =
VAR
iter: IntRefTbl.Iterator;
start: INTEGER;
ref : REFANY;
r : SLispClass.Range;
BEGIN
IF t = NIL THEN RETURN NIL END;
iter := t.iterate();
WHILE iter.next(start, ref) DO
r := ref;
IF r.form = form THEN RETURN r END
END;
RETURN NIL
END FindSx;
PROCEDURE ErrorApply (cl: ErrorClosure): REFANY =
<* FATAL Rd.Failure, Thread.Alerted, SLisp.Error *>
BEGIN
LOCK VBT.mu DO
ZeusPanel.ReportError(cl.msg);
VAR
evalStack := cl.evalStack;
range : SLispClass.Range;
BEGIN
WHILE evalStack # NIL DO
range := FindSx(cl.interp.intervals, evalStack.head);
IF range # NIL THEN
Rd.Seek(cl.interp.rd, range.start);
ZeusPanel.ReportError(
Fmt.F(" at char %s: %s", Fmt.Int(range.start),
Rd.GetText(cl.interp.rd, range.end - range.start + 1)));
EXIT
END;
evalStack := evalStack.tail;
END;
END;
ZeusPanel.ReportError("Backtrace");
EVAL cl.interp.sEval("(backtrace)");
ZeusPanel.Abort();
END;
RETURN NIL
END ErrorApply;
PROCEDURE ParseError (t: Interp; msg: TEXT): REFANY RAISES {SLisp.Error} =
BEGIN
EVAL Thread.Fork(NEW(ErrorClosure, interp := t,
evalStack := t.evalStack, msg := msg));
RAISE SLisp.Error;
END ParseError;
--------------------------- View -------------------------------
REVEAL
ViewClass = gefeventViewClass.T BRANDED OBJECT END;
View = ViewPublic BRANDED OBJECT
name: TEXT;
OVERRIDES
init := InitView;
oeInit := OEInit;
oeEvent := OEEvent;
ueUpdate := UEUpdate;
END;
TYPE MouseGEF = GEF.T OBJECT OVERRIDES mouse := Mouse END;
PROCEDURE Mouse (graph: MouseGEF; READONLY cd: VBT.MouseRec) =
BEGIN
IF cd.clickType = VBT.ClickType.LastUp AND cd.clickCount = 1
AND NOT cd.cp.gone THEN
VAR
rect := Rect.FromPoint(cd.cp.pt);
vertices := graph.verticesAt(rect);
edges := graph.edgesAt(rect);
highlights := graph.vertexHighlightsAt(rect);
polygons := graph.polygonsAt(rect);
worldPt := GraphVBTExtras.ScreenPtToWorldPos(graph, cd.cp.pt);
<* FATAL GEFError.T *>
BEGIN
TRY
GEF.InvokeEvent(
graph, "MouseFeedback",
GEFLisp.QuoteList(
RefList.FromArray(
ARRAY [0 .. 4] OF
REFANY{RefList.List2(Sx.FromReal(worldPt[0]),
Sx.FromReal(worldPt[1])), vertices,
highlights, edges, polygons})));
EXCEPT
Thread.Alerted =>
END;
END;
END;
END Mouse;
PROCEDURE InitView (v: View): View =
<* FATAL SLisp.Error *>
VAR
interp := NEW(Interp, view := v).init();
gef := NEW(MouseGEF).init(interp);
BEGIN
RETURN gefeventViewClass.T.init(v, gef);
END InitView;
PROCEDURE ReportError(msg: TEXT) =
BEGIN
ZeusPanel.ReportError(msg);
ZeusPanel.Abort();
END ReportError;
PROCEDURE OEInit (v: View; files: RefList.T) =
VAR file := MatchName(files, v.name);
BEGIN
TRY
GEF.InitFromRsrc(Filter.Child(v), file, ZeusPanel.GetPath());
EXCEPT
| Thread.Alerted =>
| Rsrc.NotFound =>
ReportError(
Fmt.F("GEF View error: Could not find file: %s", file));
| Rd.Failure =>
ReportError(
Fmt.F("GEF View error finding or parsing file: %s", file));
| GEFError.T (msg) =>
ReportError(
Fmt.F("GEF View error (%s) parsing file: %s", msg, file));
END;
END OEInit;
PROCEDURE OEEvent (v: View; name: TEXT; data: RefList.T) =
<* FATAL GEFError.T *>
VAR gef: GEF.T := Filter.Child(v);
BEGIN
TRY
GEF.InvokeEvent(gef, name, data, FALSE);
gef.redisplay();
gef.animate(0.0, 1.0);
EXCEPT
| Thread.Alerted =>
END;
END OEEvent;
PROCEDURE UEUpdate (v: View; name: TEXT; data: RefList.T) =
<* FATAL GEFError.T *>
VAR gef: GEF.T := Filter.Child(v);
BEGIN
TRY
GEF.InvokeEvent(gef, name, data, FALSE);
gef.redisplay();
gef.animate(0.0, 1.0);
EXCEPT
| Thread.Alerted =>
END;
END UEUpdate;
PROCEDURE NewView(): ZeusView.T =
BEGIN
RETURN NEW(View, name := ZeusPanelFriends.whichView).init();
END NewView;
------------------- Algorithm -------------------------
REVEAL
AlgClass = gefeventAlgClass.T BRANDED OBJECT
interp: GEFAlg.Interp;
OVERRIDES
feFeedback := FeedbackAlg;
END;
Alg = AlgPublic BRANDED OBJECT
sx : REFANY;
viewFiles: RefList.T;
OVERRIDES
init := InitAlg;
run := RunAlg;
END;
PROCEDURE InitAlg (alg: Alg; algFile: TEXT; viewFiles: RefList.T): Alg =
(* If it doesn't work, it should crash *)
BEGIN
TRY
alg.viewFiles := viewFiles;
alg.interp := NEW(GEFAlg.Interp).init(alg);
alg.sx := SLisp.Read(Rsrc.Open(algFile, ZeusPanel.GetPath()));
RETURN gefeventAlgClass.T.init(alg);
EXCEPT
| Rsrc.NotFound =>
ReportError(
Fmt.F("GEF Alg error: Could not find file: %s", algFile));
| Rd.EndOfFile, Rd.Failure, Sx.ReadError =>
ReportError(
Fmt.F("GEF Alg error: Problem reading file: %s", algFile));
END;
RETURN NIL; (* will crash *)
END InitAlg;
PROCEDURE MatchName (list: RefList.T; name: TEXT): TEXT =
VAR assoc: RefList.T;
BEGIN
WHILE list # NIL DO
assoc := list.head;
IF Text.Equal(assoc.head, name) THEN
RETURN assoc.tail.head
END;
list := list.tail;
END;
RETURN NIL
END MatchName;
PROCEDURE NewAlg (): Algorithm.T =
VAR algFile := MatchName(algsGlobal, ZeusPanelFriends.whichAlg);
BEGIN
IF algFile = NIL THEN
ReportError(Fmt.F("No algorithm file given for algorithm: %s",
ZeusPanelFriends.whichAlg));
RETURN NIL
ELSE
RETURN
NEW(Alg, codeViews := codeViewsGlobal).init(algFile, viewsGlobal)
END;
END NewAlg;
PROCEDURE RunAlg(alg: Alg) RAISES {Thread.Alerted} =
BEGIN
TRY
gefeventIE.Init(alg, alg.viewFiles);
EVAL alg.interp.eval(alg.sx)
EXCEPT
| SLisp.Error => RAISE Thread.Alerted
END;
END RunAlg;
PROCEDURE FeedbackAlg(alg: AlgClass; function: TEXT; args: RefList.T) =
BEGIN
GEFAlg.Feedback(alg.interp, function, args);
END FeedbackAlg;
--------------------- generic procs -----------------------
VAR
algsGlobal, viewsGlobal, codeViewsGlobal: RefList.T;
PROCEDURE Create (sessionName: TEXT; views, algs, codeViews: RefList.T) =
BEGIN
algsGlobal := algs;
viewsGlobal := views;
codeViewsGlobal := codeViews;
WHILE algs # NIL DO
ZeusPanel.RegisterAlg(NewAlg, NARROW(algs.head, RefList.T).head, sessionName);
algs := algs.tail;
END;
WHILE views # NIL DO
ZeusPanel.RegisterView(NewView, NARROW(views.head, RefList.T).head, sessionName);
views := views.tail;
END;
ZeusPanel.RegisterView(
NewTranscriptView, sessionName & " Transcript View", sessionName);
END Create;
PROCEDURE Event (alg: AlgClass; event: TEXT; data: RefList.T)
RAISES {Thread.Alerted} =
BEGIN
gefeventIE.Event(alg, event, data);
END Event;
PROCEDURE Update (alg: AlgClass; event: TEXT; data: RefList.T)
RAISES {Thread.Alerted} =
BEGIN
gefeventIE.Update(alg, event, data);
END Update;
PROCEDURE Pause(alg: AlgClass) RAISES {Thread.Alerted} =
BEGIN
gefeventIE.Pause(alg);
END Pause;
PROCEDURE Init(alg: AlgClass; file: TEXT) RAISES {Thread.Alerted} =
BEGIN
gefeventIE.Init(alg, RefList.List1(RefList.List2("Test view", file)));
END Init;
PROCEDURE NewTranscriptView(): ZeusView.T =
BEGIN
RETURN NEW(gefeventTranscriptView.T).init();
END NewTranscriptView;
------------------------- Testing alg and view --------------------------
TYPE
TestAlg = AlgClass OBJECT
OVERRIDES
run := TestAlgRun;
END;
PROCEDURE NewTestAlg (): Algorithm.T =
VAR
fv := ZeusPanel.NewForm("geftest.fv");
alg := NEW(TestAlg, data := fv).init();
BEGIN
RETURN alg;
END NewTestAlg;
PROCEDURE TestAlgRun (alg: TestAlg) RAISES {Thread.Alerted} =
VAR
algFile, viewFile, codeviewFile: TEXT;
interp := NEW(GEFAlg.Interp).init(alg);
sx: REFANY;
cv: CodeView.T;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
alg.interp := interp;
LOCK VBT.mu DO
algFile := FormsVBT.GetText(alg.data, "algFile");
viewFile := FormsVBT.GetText(alg.data, "viewFile");
codeviewFile := FormsVBT.GetText(alg.data, "codeviewFile");
END;
IF Text.Length(algFile) = 0 THEN
ReportError("Need file name for algorithm file.");
RETURN
END;
IF Text.Length(viewFile) = 0 THEN
ReportError("Need file name for view file.");
RETURN
END;
IF testCodeview # NIL AND Text.Length(codeviewFile) # 0 THEN
TRY
cv := NEW(CodeView.T).init(
FileRd.Open(Filename.ExpandTilde(codeviewFile)));
EVAL Filter.Replace(testCodeview, cv);
testCodeview.cv := cv;
EXCEPT
| Rd.EndOfFile =>
ReportError(
"Unexpected end of file in codeview file: " & codeviewFile);
| Rd.Failure, Filename.Error, OSError.E =>
ReportError(
"Could not open codeview file: " & codeviewFile);
END;
END;
Init(alg, viewFile);
TRY
sx := SLisp.Read(FileRd.Open(Filename.ExpandTilde(algFile)));
EVAL interp.eval(sx)
EXCEPT
| Sx.ReadError (msg) =>
ReportError("Error reading algorithm file: " & msg);
| Rd.EndOfFile =>
ReportError(
"Unexpected end of file in algorithm file: " & algFile);
| Rd.Failure, Filename.Error, OSError.E =>
ReportError("Could not open algorithm file: " & algFile);
| SLisp.Error =>
END;
END TestAlgRun;
TYPE
TestView = View OBJECT
OVERRIDES
oeInit := TestOEInit;
END;
PROCEDURE NewTestView(): ZeusView.T =
BEGIN
RETURN NEW(TestView).init();
END NewTestView;
VAR
testCodeview: ZeusCodeView.T;
TYPE
ZCV = ZeusCodeView.T OBJECT
OVERRIDES
isCompat:= CodeViewCompat;
END;
PROCEDURE CodeViewCompat(<* UNUSED *> v: ZCV; alg: ZeusClass.T): BOOLEAN =
BEGIN
RETURN ISTYPE(alg, TestAlg)
END CodeViewCompat;
PROCEDURE NewTestCodeView (): ZeusView.T =
VAR cv := NEW(CodeView.T).init(TextRd.New(""));
BEGIN
testCodeview := NEW(ZCV, cv := cv).init(cv);
RETURN testCodeview;
END NewTestCodeView;
PROCEDURE TestOEInit (v: View; files: RefList.T) RAISES {Thread.Alerted} =
VAR
gef : GEF.T := Filter.Child(v);
interp : Interp := gef.interp;
intervals := NEW(IntRefTbl.Default).init();
file : TEXT := NARROW(files.head, RefList.T).tail.head;
BEGIN
interp.intervals := intervals;
TRY
interp.rd := FileRd.Open(Filename.ExpandTilde(file));
GEF.InitFromRd(gef, interp.rd, intervals);
EXCEPT
| OSError.E, Filename.Error =>
ReportError("TextView error opening file: " & file)
| Rd.Failure =>
ReportError(
Fmt.F("TestView error finding or parsing file: %s", file));
| GEFError.T (msg) =>
ReportError(
Fmt.F("TestView error (%s) parsing file: %s", msg, file));
END;
END TestOEInit;
VAR
inited := FALSE;
mu := NEW(MUTEX);
PROCEDURE RegisterSession () =
VAR init: BOOLEAN;
BEGIN
LOCK mu DO init := NOT inited; inited := TRUE; END;
IF init THEN
ZeusPanel.SetSessTitle("gefevent", "GEF Testing");
ZeusPanel.RegisterAlg(NewTestAlg, "Test algorithm", "gefevent");
ZeusPanel.RegisterView(
NewTestCodeView, "Test Codeview", "gefevent", TRUE);
ZeusPanel.RegisterView(NewTestView, "Test view", "gefevent");
END;
END RegisterSession;
PROCEDURE GetBundle (): Bundle.T =
BEGIN
RETURN gefBundle.Get();
END GetBundle;
BEGIN
END GEFView.