********************************************************************
* NOTE: This file is generated automatically from the event
* definition file Subtype.evt.
********************************************************************
<* PRAGMA LL *>
MODULE Subtypeview1ObliqView ;
<*NOWARN*> IMPORT ObLibM3, ObLibUI, SynWr, Obliq, ObliqParser, Rd;
<*NOWARN*> IMPORT Filter, SubtypeViewClass, Fmt, ObLibAnim, ZFmt;
<*NOWARN*> IMPORT ZeusPanel, ObValue, TextWr, AlgSubtype, View;
<*NOWARN*> IMPORT VBT, Thread, TextRd, Rsrc;
CONST
ViewName = "view1.obl";
TYPE
T = SubtypeViewClass.T BRANDED OBJECT
object : Obliq.Val;
env : Obliq.Env;
wr : TextWr.T;
swr : SynWr.T;
parser : ObliqParser.T;
OVERRIDES
<* LL.sup < VBT.mu *>
startrun := Startrun;
<* LL.sup < VBT.mu *>
oeSetup := Setup;
oeBegin := Begin;
oeNewBot := NewBot;
oeNewTop := NewTop;
oeNewFun := NewFun;
oeNewDomRng := NewDomRng;
oeNewLoop := NewLoop;
oeEnter := Enter;
oeExit := Exit;
oeSeenOK := SeenOK;
oeNotice := Notice;
oeBotLessAnyOK := BotLessAnyOK;
oeTopLessTopOK := TopLessTopOK;
oeTopLessNonTopKO := TopLessNonTopKO;
oeFunLessBotKO := FunLessBotKO;
oeFunLessTopOK := FunLessTopOK;
oeFunLessFun := FunLessFun;
oeOK := OK;
oeKO := KO;
<* LL.sup = VBT.mu *>
END;
OUTPUT and UPDATE event handling methods:
PROCEDURE Setup (view: T; ) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "Setup") THEN
Invoke (view, "Setup", ""
)
END
END Setup;
PROCEDURE Begin (view: T; lftRoot, rhtRoot: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "Begin") THEN
Invoke (view, "Begin", ""
& Fmt.Int(lftRoot)
& ","
& Fmt.Int(rhtRoot)
)
END
END Begin;
PROCEDURE NewBot (view: T; index: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "NewBot") THEN
Invoke (view, "NewBot", ""
& Fmt.Int(index)
)
END
END NewBot;
PROCEDURE NewTop (view: T; index: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "NewTop") THEN
Invoke (view, "NewTop", ""
& Fmt.Int(index)
)
END
END NewTop;
PROCEDURE NewFun (view: T; index, domEdgeIndex, rngEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "NewFun") THEN
Invoke (view, "NewFun", ""
& Fmt.Int(index)
& ","
& Fmt.Int(domEdgeIndex)
& ","
& Fmt.Int(rngEdgeIndex)
)
END
END NewFun;
PROCEDURE NewDomRng (view: T; index, domIndex, rngIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "NewDomRng") THEN
Invoke (view, "NewDomRng", ""
& Fmt.Int(index)
& ","
& Fmt.Int(domIndex)
& ","
& Fmt.Int(rngIndex)
)
END
END NewDomRng;
PROCEDURE NewLoop (view: T; fromIndex, toIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "NewLoop") THEN
Invoke (view, "NewLoop", ""
& Fmt.Int(fromIndex)
& ","
& Fmt.Int(toIndex)
)
END
END NewLoop;
PROCEDURE Enter (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "Enter") THEN
Invoke (view, "Enter", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END Enter;
PROCEDURE Exit (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER; result: BOOLEAN) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "Exit") THEN
Invoke (view, "Exit", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
& ","
& AlgSubtype.FmtBool(result)
)
END
END Exit;
PROCEDURE SeenOK (view: T; fromIndex, toIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "SeenOK") THEN
Invoke (view, "SeenOK", ""
& Fmt.Int(fromIndex)
& ","
& Fmt.Int(toIndex)
)
END
END SeenOK;
PROCEDURE Notice (view: T; fromIndex, toIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "Notice") THEN
Invoke (view, "Notice", ""
& Fmt.Int(fromIndex)
& ","
& Fmt.Int(toIndex)
)
END
END Notice;
PROCEDURE BotLessAnyOK (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "BotLessAnyOK") THEN
Invoke (view, "BotLessAnyOK", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END BotLessAnyOK;
PROCEDURE TopLessTopOK (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "TopLessTopOK") THEN
Invoke (view, "TopLessTopOK", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END TopLessTopOK;
PROCEDURE TopLessNonTopKO (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "TopLessNonTopKO") THEN
Invoke (view, "TopLessNonTopKO", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END TopLessNonTopKO;
PROCEDURE FunLessBotKO (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "FunLessBotKO") THEN
Invoke (view, "FunLessBotKO", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END FunLessBotKO;
PROCEDURE FunLessTopOK (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "FunLessTopOK") THEN
Invoke (view, "FunLessTopOK", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END FunLessTopOK;
PROCEDURE FunLessFun (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "FunLessFun") THEN
Invoke (view, "FunLessFun", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END FunLessFun;
PROCEDURE OK (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "OK") THEN
Invoke (view, "OK", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END OK;
PROCEDURE KO (view: T; lftIndex, rhtIndex, lftLeadingEdgeIndex, rhtLeadingEdgeIndex: INTEGER) =
<* LL.sup < VBT.mu *>
BEGIN
IF FieldDefined(view.object, "KO") THEN
Invoke (view, "KO", ""
& Fmt.Int(lftIndex)
& ","
& Fmt.Int(rhtIndex)
& ","
& Fmt.Int(lftLeadingEdgeIndex)
& ","
& Fmt.Int(rhtLeadingEdgeIndex)
)
END
END KO;
PROCEDURE RegisterView () =
BEGIN
ZeusPanel.RegisterView(New, "view1.obl", "Subtype")
END RegisterView;
PROCEDURE New (): View.T =
BEGIN
RETURN NEW(T).init(NIL)
END New;
CONST
ObliqStackSizeMultiplier = 8;
TYPE
Closure = Thread.SizedClosure OBJECT
view: T;
OVERRIDES
apply := ForkedStartrun;
END;
PROCEDURE Startrun (view: T) =
<* LL.sup < VBT.mu *>
BEGIN
EVAL
Thread.Join(
Thread.Fork(
NEW(Closure, view := view,
stackSize := ObliqStackSizeMultiplier * Thread.GetDefaultStackSize())));
END Startrun;
PROCEDURE ForkedStartrun (cl: Closure): REFANY =
VAR rd: Rd.T; view := cl.view;
BEGIN
IF view.parser = NIL THEN
view.wr := TextWr.New();
view.swr := SynWr.New(view.wr);
view.parser := ObliqParser.New(view.swr);
END;
view.object := NIL;
TRY
rd := Rsrc.Open(ViewName, ZeusPanel.GetPath());
view.env := ParseRd(view.parser, ViewName, rd);
WITH obj = Obliq.Lookup("view", view.env) DO
IF NOT ISTYPE(obj, ObValue.ValObj) THEN
ZeusPanel.ReportError(
"not an Obliq object in '" & ViewName & "'")
ELSIF FieldDefined (obj, "graphvbt") THEN
WITH graphvbt =
NARROW(Obliq.ObjectSelect(obj, "graphvbt"),
ObLibAnim.ValGraph).vbt DO
LOCK VBT.mu DO
EVAL Filter.Replace(view, graphvbt)
END
END;
view.object := obj;
ELSIF FieldDefined (obj, "rectsvbt") THEN
WITH rectsvbt =
NARROW(Obliq.ObjectSelect(obj, "rectsvbt"),
ObLibAnim.ValRects).vbt DO
LOCK VBT.mu DO
EVAL Filter.Replace(view, rectsvbt)
END
END;
view.object := obj;
ELSIF FieldDefined (obj, "formsvbt") THEN
WITH formsvbt =
NARROW(Obliq.ObjectSelect(obj, "formsvbt"),
ObLibUI.ValForm).vbt DO
LOCK VBT.mu DO
EVAL Filter.Replace(view, formsvbt)
END
END;
view.object := obj;
ELSE
ZeusPanel.ReportError(
"cannot find 'graphvbt', 'rectsvbt', or 'formsvbt' in '" & ViewName & "'")
END
END
EXCEPT
| Rsrc.NotFound =>
ZeusPanel.ReportError("cannot find '" & ViewName & "'")
| ObValue.Error (packet) => OblError(view, packet)
| ObValue.Exception (packet) => OblException(view, packet)
END;
RETURN NIL;
END ForkedStartrun;
PROCEDURE ParseRd (p: ObliqParser.T; name: TEXT; rd: Rd.T):
Obliq.Env RAISES {ObValue.Error, ObValue.Exception} =
VAR env := Obliq.EmptyEnv();
BEGIN
ObliqParser.ReadFrom(p, name, rd, TRUE);
TRY
LOOP
EVAL ObliqParser.EvalPhrase(p, ObliqParser.ParsePhrase(p), env)
END
EXCEPT
ObliqParser.Eof => (* clean exit of loop *)
END;
RETURN env
END ParseRd;
PROCEDURE Invoke (view: T; event, args: TEXT) =
VAR
exp := "view." & event & "(" & args & ");";
name := "Zeus Event <" & event & ">";
BEGIN
ObliqParser.ReadFrom (view.parser, name, TextRd.New(exp), FALSE);
TRY
EVAL Obliq.EvalTerm(ObliqParser.ParseTerm(view.parser), view.env)
EXCEPT
| ObliqParser.Eof => <* ASSERT FALSE *>
| ObValue.Error (packet) => OblError(view, packet)
| ObValue.Exception (packet) => OblException(view, packet)
END
END Invoke;
PROCEDURE FieldDefined (object: Obliq.Val; event: TEXT): BOOLEAN =
BEGIN
TRY
RETURN object # NIL AND Obliq.ObjectHas(object, event)
EXCEPT
| ObValue.Error =>
| ObValue.Exception =>
END;
RETURN FALSE
END FieldDefined;
PROCEDURE OblError (view: T; packet: ObValue.ErrorPacket) =
BEGIN
Obliq.ReportError(view.swr, packet);
ZeusPanel.ReportError(
"Obliq error: " & TextWr.ToText(view.wr))
END OblError;
PROCEDURE OblException (view: T; packet: ObValue.ExceptionPacket) =
BEGIN
Obliq.ReportException(view.swr, packet);
ZeusPanel.ReportError(
"Obliq exception: " & TextWr.ToText(view.wr))
END OblException;
BEGIN
SynWr.Setup();
ObliqParser.PackageSetup();
ObLibM3.PackageSetup();
ObLibUI.PackageSetup();
ObLibAnim.PackageSetup();
RegisterView ();
END Subtypeview1ObliqView.