Copyright (C) 1994, Digital Equipment Corp. MODULE--------------------------- Interpreter -----------------------GEFView EXPORTSGEFView ,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;
REVEAL Interp = SLisp.T BRANDED OBJECT rd: Rd.T; intervals: IntRefTbl.T; view: ZeusView.T; OVERRIDES init := InitInterp; error := ParseError; END; PROCEDURE--------------------------- View -------------------------------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; PROCEDURESLispFeedback (<*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; PROCEDUREFindSx (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; PROCEDUREErrorApply (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; PROCEDUREParseError (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;
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------------------- Algorithm -------------------------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; PROCEDUREInitView (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; PROCEDUREReportError (msg: TEXT) = BEGIN ZeusPanel.ReportError(msg); ZeusPanel.Abort(); END ReportError; PROCEDUREOEInit (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; PROCEDUREOEEvent (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; PROCEDUREUEUpdate (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; PROCEDURENewView (): ZeusView.T = BEGIN RETURN NEW(View, name := ZeusPanelFriends.whichView).init(); END NewView;
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--------------------- generic procs -----------------------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; PROCEDUREMatchName (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; PROCEDURENewAlg (): 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; PROCEDURERunAlg (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; PROCEDUREFeedbackAlg (alg: AlgClass; function: TEXT; args: RefList.T) = BEGIN GEFAlg.Feedback(alg.interp, function, args); END FeedbackAlg;
VAR algsGlobal, viewsGlobal, codeViewsGlobal: RefList.T; PROCEDURE------------------------- Testing alg and view --------------------------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; PROCEDUREEvent (alg: AlgClass; event: TEXT; data: RefList.T) RAISES {Thread.Alerted} = BEGIN gefeventIE.Event(alg, event, data); END Event; PROCEDUREUpdate (alg: AlgClass; event: TEXT; data: RefList.T) RAISES {Thread.Alerted} = BEGIN gefeventIE.Update(alg, event, data); END Update; PROCEDUREPause (alg: AlgClass) RAISES {Thread.Alerted} = BEGIN gefeventIE.Pause(alg); END Pause; PROCEDUREInit (alg: AlgClass; file: TEXT) RAISES {Thread.Alerted} = BEGIN gefeventIE.Init(alg, RefList.List1(RefList.List2("Test view", file))); END Init; PROCEDURENewTranscriptView (): ZeusView.T = BEGIN RETURN NEW(gefeventTranscriptView.T).init(); END NewTranscriptView;
TYPE TestAlg = AlgClass OBJECT OVERRIDES run := TestAlgRun; END; PROCEDURENewTestAlg (): Algorithm.T = VAR fv := ZeusPanel.NewForm("geftest.fv"); alg := NEW(TestAlg, data := fv).init(); BEGIN RETURN alg; END NewTestAlg; PROCEDURETestAlgRun (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; PROCEDURENewTestView (): ZeusView.T = BEGIN RETURN NEW(TestView).init(); END NewTestView; VAR testCodeview: ZeusCodeView.T; TYPE ZCV = ZeusCodeView.T OBJECT OVERRIDES isCompat:= CodeViewCompat; END; PROCEDURECodeViewCompat (<* UNUSED *> v: ZCV; alg: ZeusClass.T): BOOLEAN = BEGIN RETURN ISTYPE(alg, TestAlg) END CodeViewCompat; PROCEDURENewTestCodeView (): ZeusView.T = VAR cv := NEW(CodeView.T).init(TextRd.New("")); BEGIN testCodeview := NEW(ZCV, cv := cv).init(cv); RETURN testCodeview; END NewTestCodeView; PROCEDURETestOEInit (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); PROCEDURERegisterSession () = 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; PROCEDUREGetBundle (): Bundle.T = BEGIN RETURN gefBundle.Get(); END GetBundle; BEGIN END GEFView.