summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarioBlazevic <>2018-04-08 13:43:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-04-08 13:43:00 (GMT)
commit8e75f9a024d1aab953246371c48c0e14cf146f60 (patch)
tree9d86acb9bb7120157a76c39d35fbfff19505ce36
parent5fc10a56efea25324f117d4dd4a9b6ed0454a50c (diff)
version 0.1.10.1.1
-rw-r--r--ChangeLog.md6
-rw-r--r--examples/AGRS/AGRS.Mod1033
-rw-r--r--examples/AGRS/Attributes.Def208
-rw-r--r--examples/AGRS/Directories.Def48
-rw-r--r--examples/AGRS/Display.Def403
-rw-r--r--examples/AGRS/Display3.Def240
-rw-r--r--examples/AGRS/Files.Def135
-rw-r--r--examples/AGRS/Fonts.Def41
-rw-r--r--examples/AGRS/Gadgets.Def538
-rw-r--r--examples/AGRS/Grammars.Mod711
-rw-r--r--examples/AGRS/Library.Mod677
-rw-r--r--examples/AGRS/Links.Def64
-rw-r--r--examples/AGRS/ListRiders.Def90
-rw-r--r--examples/AGRS/Main.Mod108
-rw-r--r--examples/AGRS/Names.Mod371
-rw-r--r--examples/AGRS/OFS.Def3
-rw-r--r--examples/AGRS/Oberon.Def415
-rw-r--r--examples/AGRS/Objects.Def460
-rw-r--r--examples/AGRS/Parser.Mod802
-rw-r--r--examples/AGRS/Parser2.Mod428
-rw-r--r--examples/AGRS/Perm.Mod215
-rw-r--r--examples/AGRS/Permanence.Mod220
-rw-r--r--examples/AGRS/Pictures.Def137
-rw-r--r--examples/AGRS/SYSTEM.Def18
-rw-r--r--examples/AGRS/Speller.Mod405
-rw-r--r--examples/AGRS/TextFrames.Def69
-rw-r--r--examples/AGRS/Texts.Def348
-rw-r--r--examples/AGRS/Viewers.Def100
-rw-r--r--language-oberon.cabal20
29 files changed, 8302 insertions, 11 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index b2ae8c0..0ba165e 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -2,4 +2,8 @@
## 0.1 -- 2018-04-08
-* First version, but complete enough to be released on an unsuspecting world.
+* First version, but complete enough to be released on an unsuspecting world...
+
+## 0.1.1 -- 2018-04-08
+
+* except for the missing Oberon module examples the test suite depends on.
diff --git a/examples/AGRS/AGRS.Mod b/examples/AGRS/AGRS.Mod
new file mode 100644
index 0000000..81df7e0
--- /dev/null
+++ b/examples/AGRS/AGRS.Mod
@@ -0,0 +1,1033 @@
+MODULE AGRS;
+(*
+ Modul AGRS - Attributed Graph Rewriting System
+
+ Najnizi modul. Ovde su implementirani
+ apstraktni tipovi podataka (ADT) koji cine graf izraza.
+*)
+
+CONST
+ MaxStack= 6495;
+ Fixed*= MAX(INTEGER);
+ Unique*= 0;
+TYPE
+ Term*= POINTER TO TermDesc; (* ADT Term - korenska klasa *)
+
+ TermDesc*= RECORD
+ indirection-: Term;
+ END;
+
+ SubTerm*= POINTER TO SubTermDesc; (* ADT SubTerm *)
+ SubTermDesc*= RECORD(TermDesc)
+ query-: Term;
+ END;
+
+ FieldTail= POINTER TO RECORD(TermDesc)
+ END;
+
+ Field*= POINTER TO RECORD(SubTermDesc) (* ADT Field *)
+ tail: FieldTail;
+ END;
+
+ Name*= POINTER TO NameDesc; (* ADT Name *)
+ NameDesc*= RECORD(TermDesc)
+ age-: INTEGER;
+ END;
+
+ Equation= POINTER TO RECORD(TermDesc)
+ param: Name;
+ next: Equation;
+ END;
+
+ Tree*= POINTER TO TreeDesc; (* ADT Tree *)
+ TreeDesc*= RECORD(TermDesc)
+ attributes: Equation;
+ constant: BOOLEAN;
+ END;
+
+ Atomic*= POINTER TO AtomicDesc; (* ADT Atomic *)
+ AtomicDesc*= RECORD(TermDesc)
+ END;
+
+ OpenTree*= POINTER TO RECORD(TreeDesc) (* ADT OpenTree *)
+ END;
+
+ Class*= POINTER TO ClassDesc; (* ADT Class *)
+ ClassDesc*= RECORD(TreeDesc)
+ END;
+
+ ClosedClass*= POINTER TO ClosedClassDesc; (* ADT ClosedClass *)
+ ClosedClassDesc*= RECORD(ClassDesc)
+ END;
+
+ Block*= POINTER TO RECORD(TreeDesc)
+ END;
+
+ HandlerType*= PROCEDURE;
+
+ SystemTerm*= POINTER TO RECORD(TermDesc) (* ADT SystemTerm *)
+ handler: HandlerType;
+ END;
+
+ Disjunction*= POINTER TO RECORD(TermDesc) (* ADT Disjunction *)
+ alternative-: Term;
+ END;
+
+ TermBackup= NameDesc;
+
+ TermStack*= POINTER TO TermStackDesc;
+ TermStackDesc= RECORD
+ top-: Term;
+ rest-: TermStack;
+ END;
+VAR
+ stack: POINTER TO ARRAY MaxStack OF TermBackup;
+ continuation-,paramStack*: TermStack;
+ sp, eldestAsked*: INTEGER;
+ allConstant: BOOLEAN;
+
+ otherwise*: Name;
+ lastResult-, lastAtom-, Failure*, result*: Term;
+ failName*: Name;
+ Undefined-, Variable-: SystemTerm;
+ LocalRestore, StackRestore, FunctionResult: SystemTerm;
+ GuardTrap*, MatchTrap: SystemTerm;
+
+PROCEDURE Push*(t: Term);
+VAR
+ newStack: TermStack;
+BEGIN
+ IF t#NIL THEN
+ NEW(newStack);
+ newStack.top:= t;
+ newStack.rest:= continuation;
+ continuation:= newStack;
+ END;
+END Push;
+
+
+PROCEDURE (t: Term) Init*(ind: Term);
+BEGIN
+ t.indirection:= ind;
+END Init;
+
+PROCEDURE (t: Term) Reduce*;
+BEGIN
+ t.indirection.Reduce;
+END Reduce;
+
+PROCEDURE (t: Term) Value*(): Term;
+VAR
+ spOld,spNew: INTEGER;
+ contOld: TermStack;
+BEGIN
+ spOld:= sp;
+ contOld:= continuation;
+ Push(FunctionResult);
+ t.Reduce;
+ spNew:= sp;
+ ASSERT((sp=spOld) & (continuation=contOld));
+ RETURN result
+END Value;
+
+PROCEDURE (t: Term) Evaluate*(query: Term): Term;
+VAR
+ spOld,spNew: INTEGER;
+ contOld,contNew: TermStack;
+BEGIN
+ spOld:= sp;
+ contOld:= continuation;
+ Push(FunctionResult);
+ Push(query);
+ t.Reduce;
+ spNew:= sp;
+ contNew:= continuation;
+ ASSERT((sp=spOld) & (continuation=contOld));
+ RETURN result
+END Evaluate;
+
+PROCEDURE (t: Term) Actual*(): Term;
+BEGIN
+ RETURN t
+END Actual;
+
+PROCEDURE Continue*;
+VAR
+ spOld,spNew: INTEGER;
+ next: Term;
+ newTop: TermStack;
+BEGIN
+ spOld:= sp;
+ next:= continuation.top;
+ continuation:= continuation.rest;
+ IF lastResult IS Atomic THEN
+ NEW(newTop);
+ newTop.top:= lastResult;
+ newTop.rest:= paramStack;
+ paramStack:= newTop;
+ next.Reduce;
+ paramStack:= paramStack.rest;
+ ELSE
+ next.Reduce;
+ END;
+ spNew:= sp;
+ ASSERT(spNew=spOld, 255);
+END Continue;
+
+PROCEDURE Continued*(): BOOLEAN;
+BEGIN
+ IF continuation.top=FunctionResult THEN
+ continuation:= continuation.rest;
+ RETURN FALSE
+ ELSE
+ Continue;
+ RETURN TRUE
+ END;
+END Continued;
+
+PROCEDURE ResultHandler*;
+BEGIN
+ result:= lastResult;
+END ResultHandler;
+
+PROCEDURE Fail*;
+VAR
+ spOld: INTEGER;
+BEGIN
+ WHILE continuation.top#FunctionResult DO
+ continuation:= continuation.rest;
+ END;
+ continuation:= continuation.rest;
+ result:= Failure;
+END Fail;
+
+
+PROCEDURE (t: Name) Init*(contents: Term);
+BEGIN
+ t.Init^(contents);
+ t.age:= 0;
+END Init;
+
+PROCEDURE (t: Name) Actual*(): Term;
+BEGIN
+ IF t.indirection IS SystemTerm THEN
+ RETURN t
+ ELSIF t.indirection IS Name THEN
+ ASSERT(t.indirection#t);
+ RETURN t.indirection.Actual()
+ ELSE
+ RETURN t.indirection
+ END;
+END Actual;
+
+PROCEDURE (t: Name) Assign*(contents: Term);
+BEGIN
+(* ASSERT(contents#t); *)
+ INC(sp);
+ stack[sp].indirection:= t.indirection;
+ stack[sp].age:= t.age;
+ t.indirection:= contents;
+ t.age:= sp;
+END Assign;
+
+PROCEDURE (t: Name) Restore*();
+BEGIN
+ ASSERT(sp>0);
+ ASSERT(t.age=sp);
+ t.indirection:= stack[sp].indirection;
+ t.age:= stack[sp].age;
+ DEC(sp);
+END Restore;
+
+PROCEDURE (t: Name) Reduce*;
+VAR
+ saveLastName: Term;
+ spOld,spNew: INTEGER;
+BEGIN
+ spOld:= sp;
+ saveLastName:= lastResult;
+ lastResult:= t;
+ t.indirection.Reduce;
+ lastResult:= saveLastName;
+ IF t.age<eldestAsked THEN
+ eldestAsked:= t.age;
+ END;
+ spNew:= sp;
+ ASSERT(spOld=spNew);
+END Reduce;
+
+
+PROCEDURE (t: SubTerm) Reduce*;
+BEGIN
+ IF t.query=NIL THEN
+ t.Reduce^;
+ ELSE
+ Push(t.query);
+ t.indirection.Reduce;
+ END;
+END Reduce;
+
+PROCEDURE (t: SubTerm) Actual*(): Term;
+VAR
+ newTerm: SubTerm;
+BEGIN
+ IF t.query=NIL THEN
+ RETURN t
+ END;
+ result:= t.query.Actual();
+ IF result=t.query THEN
+ RETURN t
+ ELSE
+ NEW(newTerm);
+ newTerm.indirection:= t.indirection;
+ newTerm.query:= result;
+ RETURN newTerm
+ END;
+END Actual;
+
+PROCEDURE (t: SubTerm) InitQuery*(query: Term);
+BEGIN
+ t.query:= query;
+END InitQuery;
+
+
+PROCEDURE (t: Field) Actual*(): Term;
+VAR
+ spOld: INTEGER;
+BEGIN
+ spOld:= sp;
+ RETURN t.indirection.Evaluate(t.tail)
+END Actual;
+
+PROCEDURE (t: Field) InitQuery*(query: Term);
+VAR
+ newTerm: FieldTail;
+BEGIN
+ NEW(newTerm);
+ newTerm.indirection:= query;
+ t.query:= query;
+ t.tail:= newTerm;
+END InitQuery;
+
+
+PROCEDURE (t: FieldTail) Reduce*;
+BEGIN
+ IF ~Continued() THEN
+ result:= t.indirection.Actual();
+ ELSE
+ HALT(255);
+ END;
+END Reduce;
+
+
+PROCEDURE (t: Equation) Association(param: Name): Term;
+BEGIN
+ WHILE (t#NIL) & (t.param#param) DO
+ t:= t.next;
+ END;
+ IF t=NIL THEN
+ RETURN NIL
+ ELSE
+ RETURN t.indirection.Actual()
+ END;
+END Association;
+
+PROCEDURE (t: Equation) Unfold();
+VAR
+ follow: Equation;
+BEGIN
+ follow:= t;
+ REPEAT
+ follow.param.Assign(follow.indirection);
+ follow:= follow.next;
+ UNTIL follow=NIL;
+END Unfold;
+
+PROCEDURE (t: Equation) UnfoldActual();
+VAR
+ spStart: INTEGER;
+ swap: Term;
+ follow: Equation;
+BEGIN
+ spStart:= sp;
+ follow:= t;
+ REPEAT
+ INC(sp);
+ stack[sp].indirection:= follow.indirection.Actual();
+ follow:= follow.next;
+ UNTIL follow=NIL;
+ REPEAT
+ INC(spStart);
+ swap:= t.param.indirection;
+ t.param.indirection:= stack[spStart].indirection;
+ stack[spStart].indirection:= swap;
+ stack[spStart].age:= t.param.age;
+ t.param.age:= spStart;
+ t:= t.next;
+ UNTIL t=NIL;
+END UnfoldActual;
+
+PROCEDURE (t: Equation) Restore();
+BEGIN
+ sp:= t.param.age-1;
+ REPEAT
+ t.param.indirection:= stack[t.param.age].indirection;
+ t.param.age:= stack[t.param.age].age;
+ t:= t.next;
+ UNTIL t=NIL;
+END Restore;
+
+PROCEDURE (t: Equation) Enrich(VAR base: Term);
+VAR
+ oldEdges, newEdges: Equation;
+ spStart: INTEGER;
+ newTerm: OpenTree;
+BEGIN
+ WITH base: OpenTree DO
+ oldEdges:= base.attributes;
+ newEdges:= oldEdges;
+ spStart:= t.param.age;
+ WHILE oldEdges#NIL DO
+ IF oldEdges.param.age>=spStart THEN
+ oldEdges.param.age:= -oldEdges.param.age;
+ END;
+ oldEdges:= oldEdges.next;
+ END;
+ WHILE t#NIL DO
+ IF t.param.age<0 THEN
+ t.param.age:= -t.param.age;
+ ELSE
+ oldEdges:= newEdges;
+ NEW(newEdges);
+ newEdges.param:= t.param;
+ newEdges.indirection:= t.param.indirection;
+ newEdges.next:= oldEdges;
+ END;
+ t:= t.next;
+ END;
+ base.attributes:= newEdges;
+ base.constant:= FALSE;
+ ELSE
+ IF base IS Name THEN
+ NEW(newTerm);
+ newTerm.indirection:= base;
+ newTerm.constant:= FALSE;
+ newTerm.attributes:= NIL;
+ oldEdges:= t;
+ WHILE oldEdges#NIL DO
+ NEW(newEdges);
+ newEdges.param:= oldEdges.param;
+ newEdges.indirection:= oldEdges.param.indirection;
+ newEdges.next:= newTerm.attributes;
+ newTerm.attributes:= newEdges;
+ oldEdges:= oldEdges.next;
+ END;
+ base:= newTerm;
+ END;
+ END;
+END Enrich;
+
+PROCEDURE (t: Equation) ActualizeUsing(base: Equation);
+VAR
+ follow: Equation;
+ link: Name;
+ spStart: INTEGER;
+BEGIN
+ spStart:= sp;
+ follow:= t;
+ WHILE follow#NIL DO
+ IF follow.indirection IS Name THEN
+ link:= follow.indirection(Name);
+ link.age:= -link.age-1;
+ END;
+ follow:= follow.next;
+ END;
+ WHILE base#NIL DO
+ IF base.param.age<0 THEN
+ base.param.Assign(base.indirection);
+ END;
+ base:= base.next;
+ END;
+ follow:= t;
+ WHILE follow#NIL DO
+ IF follow.indirection IS Name THEN
+ link:= follow.indirection(Name);
+ IF link.age<0 THEN
+ link.age:= -link.age-1;
+ ELSE
+ follow.param.indirection:= link.indirection;
+ follow.indirection:= link.indirection;
+ link.indirection:= stack[link.age].indirection;
+ link.age:= -stack[link.age].age-1;
+ END;
+ END;
+ follow:= follow.next;
+ END;
+ sp:= spStart;
+END ActualizeUsing;
+
+PROCEDURE (t: Equation) Actual(): Term;
+VAR
+ newEdge: Equation;
+ newMeaning,actualRest: Term;
+BEGIN
+ newMeaning:= t.indirection.Actual();
+ IF newMeaning=t.indirection THEN
+ IF t.next#NIL THEN
+ actualRest:= t.next.Actual();
+ IF actualRest#t.next THEN
+ NEW(newEdge);
+ newEdge.param:= t.param;
+ newEdge.indirection:= newMeaning;
+ newEdge.next:= actualRest(Equation);
+ RETURN newEdge
+ END;
+ END;
+ IF t.indirection IS Name THEN
+ allConstant:= FALSE;
+ END;
+ RETURN t
+ ELSE
+ NEW(newEdge);
+ newEdge.param:= t.param;
+ newEdge.indirection:= newMeaning;
+ IF t.next=NIL THEN
+ newEdge.next:= NIL;
+ ELSE
+ actualRest:= t.next.Actual();
+ newEdge.next:= actualRest(Equation);
+ END;
+ RETURN newEdge
+ END;
+END Actual;
+
+
+PROCEDURE (t: Tree) AddProperty*(param: Name; meaning: Term);
+VAR
+ newEdge: Equation;
+BEGIN
+ newEdge:= t.attributes;
+ WHILE (newEdge#NIL) & (newEdge.param#param) DO
+ newEdge:= newEdge.next;
+ END;
+ IF newEdge=NIL THEN
+ NEW(newEdge);
+ newEdge.param:= param;
+ newEdge.next:= t.attributes;
+ t.attributes:= newEdge;
+ END;
+ newEdge.indirection:= meaning;
+END AddProperty;
+
+PROCEDURE (t: Tree) RemoveProperty*(param: Name);
+VAR
+ follow,oldEdge: Equation;
+BEGIN
+ oldEdge:= t.attributes;
+ WHILE (oldEdge#NIL) & (oldEdge.param#param) DO
+ follow:= oldEdge;
+ oldEdge:= oldEdge.next;
+ END;
+ IF oldEdge#NIL THEN
+ IF oldEdge=t.attributes THEN
+ t.attributes:= oldEdge.next;
+ ELSE
+ follow.next:= oldEdge.next;
+ END;
+ END;
+END RemoveProperty;
+
+PROCEDURE Attributed(VAR root: Term; prop: Name; value: Term);
+VAR
+ newTerm: OpenTree;
+BEGIN
+ NEW(newTerm);
+ IF root IS Name THEN
+ newTerm.indirection:= root;
+ newTerm.constant:= FALSE;
+ newTerm.attributes:= NIL;
+ ELSIF root IS OpenTree THEN
+ newTerm^:= root(OpenTree)^;
+ ELSE
+ RETURN
+ END;
+ newTerm.AddProperty(prop,value);
+ root:= newTerm;
+END Attributed;
+
+PROCEDURE (t: Tree) Reduce*;
+VAR
+ spOld,spNew: INTEGER;
+ attr,follow,newEq: Equation;
+ newTerm: OpenTree;
+BEGIN
+ spOld:= sp;
+ attr:= t.attributes;
+ IF attr=NIL THEN
+ t.Reduce^;
+ ELSE
+ attr.UnfoldActual();
+ t.indirection.Reduce;
+ attr.Enrich(result);
+ attr.Restore();
+ END;
+ spNew:= sp;
+ ASSERT(spOld=spNew);
+END Reduce;
+
+PROCEDURE (t: Tree) Actual*(): Term;
+VAR
+ newTerm: Tree;
+ newAttributes: Term;
+BEGIN
+ IF t.constant OR (t.attributes=NIL) THEN
+ t.constant:= TRUE;
+ RETURN t
+ END;
+ allConstant:= TRUE;
+ newAttributes:= t.attributes.Actual();
+ IF allConstant & (newAttributes=t.attributes) THEN
+ t.constant:= TRUE;
+ RETURN t
+ ELSE
+ NEW(newTerm);
+ newTerm.indirection:= t.indirection;
+ newTerm.attributes:= newAttributes(Equation);
+(* newTerm.constant:= TRUE; *)
+ RETURN newTerm
+ END;
+END Actual;
+
+PROCEDURE (t: Tree) Init*(ind: Term);
+BEGIN
+ t.indirection:= ind;
+ t.attributes:= NIL;
+ t.constant:= FALSE;
+END Init;
+
+PROCEDURE (t: Tree) ProcessAttributes*(proc: PROCEDURE(attr: Name; VAR meaning: Term));
+VAR
+ follow: Equation;
+BEGIN
+ follow:= t.attributes;
+ WHILE follow#NIL DO
+ proc(follow.param,follow.indirection);
+ follow:= follow.next;
+ END;
+END ProcessAttributes;
+
+
+PROCEDURE (t: Class) Reduce*;
+VAR
+ spOld: INTEGER;
+ attr: Equation;
+BEGIN
+ spOld:= sp;
+ attr:= t.attributes;
+ IF attr=NIL THEN
+ t.Reduce^;
+ ELSE
+ attr.Unfold();
+ Continue;
+ attr.Restore();
+ END;
+ ASSERT(spOld=sp);
+END Reduce;
+
+PROCEDURE (t: Class) Actual*(): Term;
+BEGIN
+ RETURN t
+END Actual;
+
+
+PROCEDURE (t: ClosedClass) Reduce*;
+VAR
+ query,root: Term;
+BEGIN
+ query:= continuation.top;
+ root:= query;
+ WHILE ~(root IS Name) DO
+ root:= root.indirection;
+ END;
+ WITH root: Name DO
+ result:= t.attributes.Association(root);
+ IF result=NIL THEN
+ result:= t.attributes.Association(otherwise);
+ IF result=NIL THEN
+ Continue;
+ RETURN
+ END;
+ END;
+ root.Assign(Undefined);
+ continuation:= continuation.rest;
+ Push(result);
+ query.Reduce();
+ root.Restore();
+ END;
+END Reduce;
+
+
+PROCEDURE (t: SystemTerm) Reduce*;
+BEGIN
+ t.handler;
+END Reduce;
+
+PROCEDURE (t: SystemTerm) InitHandler*(h: HandlerType);
+BEGIN
+ t.handler:= h;
+END InitHandler;
+
+
+PROCEDURE (t: Atomic) Reduce*;
+VAR
+ saveLastAtom: Term;
+BEGIN
+ saveLastAtom:= lastAtom;
+ lastAtom:= t;
+ t.indirection.Reduce;
+ lastAtom:= saveLastAtom;
+END Reduce;
+
+
+PROCEDURE (t: Atomic) Compare*(reference: Term; VAR lessEq,grEq: BOOLEAN);
+BEGIN
+ lessEq:= (t.indirection=reference.indirection);
+ grEq:= lessEq;
+END Compare;
+
+
+PROCEDURE AtomicHandler*;
+VAR
+ saveLastResult: Term;
+BEGIN
+ eldestAsked:= Fixed;
+ saveLastResult:= lastResult;
+ lastResult:= lastAtom;
+ Continue;
+ lastResult:= saveLastResult;
+END AtomicHandler;
+
+
+PROCEDURE Equal*(t1,t2: Term): BOOLEAN;
+VAR
+ lessEq,greaterEq: BOOLEAN;
+
+ PROCEDURE AttrEqual(attr1,attr2: Equation): BOOLEAN;
+ VAR
+ oldSp: INTEGER;
+ copy: Equation;
+ BEGIN
+ copy:= attr1;
+ oldSp:= sp;
+ copy.Unfold();
+ WHILE (attr1#attr2) & (attr2#NIL) & (attr2.param.age>oldSp) &
+ Equal(attr2.indirection,attr2.param.indirection) DO
+ attr1:= attr1.next;
+ attr2:= attr2.next;
+ END;
+ copy.Restore();
+ RETURN attr1=attr2
+ END AttrEqual;
+
+BEGIN
+ IF t1=t2 THEN
+ RETURN TRUE
+ END;
+ IF t1.indirection#t2.indirection THEN
+ RETURN FALSE
+ END;
+ WITH t1: Tree DO
+ WITH t2: Tree DO
+ IF t1.attributes#NIL THEN
+ RETURN AttrEqual(t1.attributes,t2.attributes)
+ END;
+ ELSE
+ RETURN FALSE
+ END;
+ ELSE
+ WITH t1: Atomic DO
+ t1.Compare(t2,lessEq,greaterEq);
+ RETURN lessEq&greaterEq
+ ELSE
+ RETURN TRUE
+ END;
+ END;
+END Equal;
+
+
+PROCEDURE EnvironmentPath*(t: Name): SubTerm;
+VAR
+ result,previous: SubTerm;
+ position: INTEGER;
+BEGIN
+ NEW(result);
+ result.Init(t.indirection);
+ position:= t.age;
+ WHILE position#0 DO
+ previous:= result;
+ NEW(result);
+ result.indirection:= stack[position].indirection;
+ result.query:= previous;
+ position:= stack[position].age;
+ END;
+ RETURN result
+END EnvironmentPath;
+
+
+PROCEDURE RestoreReversed(list: Equation);
+BEGIN
+ IF list#NIL THEN
+ RestoreReversed(list.next);
+ list.param.Assign(continuation.top);
+ continuation:= continuation.rest;
+ END;
+END RestoreReversed;
+
+PROCEDURE RestoreLocals;
+VAR
+ locals: Equation;
+BEGIN
+ locals:= continuation.top(Equation);
+ continuation:= continuation.rest;
+ RestoreReversed(locals);
+ Continue;
+ WHILE locals#NIL DO
+ locals.param.Restore();
+ locals:= locals.next;
+ END;
+END RestoreLocals;
+
+PROCEDURE RestoreLocal;
+VAR
+ local: Name;
+BEGIN
+ local:= continuation.top(Name);
+ continuation:= continuation.rest;
+ local.Assign(continuation.top);
+ continuation:= continuation.rest;
+ Continue;
+ local.Restore();
+END RestoreLocal;
+
+PROCEDURE PushLocal*(t: Name);
+BEGIN
+ Push(t.indirection);
+ Push(t);
+ Push(LocalRestore);
+END PushLocal;
+
+
+PROCEDURE (t: Block) Reduce*;
+VAR
+ follow: Equation;
+ newTerm: Name;
+BEGIN
+ follow:= t.attributes;
+ IF follow#NIL THEN
+ REPEAT
+ Push(follow.param.indirection);
+ IF follow.indirection=Variable THEN
+ NEW(newTerm);
+ newTerm.Init(Variable);
+ follow.param.Assign(newTerm);
+ ELSE
+ follow.param.Assign(follow.indirection.Actual());
+ END;
+ follow:= follow.next;
+ UNTIL follow=NIL;
+ Push(t.attributes);
+ Push(StackRestore);
+ t.indirection.Reduce;
+ IF result IS Tree THEN
+ t.attributes.ActualizeUsing(result(Tree).attributes);
+ END;
+ t.attributes.Enrich(result);
+ t.attributes.Restore;
+ ELSE
+ t.indirection.Reduce;
+ END;
+END Reduce;
+
+
+PROCEDURE GuardHandler*;
+VAR
+ follow: Equation;
+ pattern: Term;
+ newTerm: OpenTree;
+BEGIN
+ pattern:= continuation.top;
+ continuation:= continuation.rest;
+ IF lastResult=pattern.indirection THEN
+ IF pattern IS Tree THEN
+ follow:= pattern(Tree).attributes;
+ WHILE follow#NIL DO
+ Push(follow.indirection);
+ Push(follow.param.indirection);
+ Push(MatchTrap);
+ follow:= follow.next;
+ END;
+ END;
+ Continue;
+ ELSIF (lastResult IS Name) &
+ (lastResult.indirection=Variable) THEN
+ WITH lastResult: Name DO
+ lastResult.Assign(pattern.Actual());
+ Continue;
+ Attributed(result,lastResult,lastResult.indirection);
+ lastResult.Restore();
+ END;
+ ELSIF (pattern IS Atomic) & Equal(pattern,lastResult) THEN
+ Continue;
+ ELSE
+ Fail;
+ END;
+END GuardHandler;
+
+
+PROCEDURE MatchHandler;
+VAR
+ lhs,pattern: Term;
+ r: TermStack;
+BEGIN
+ lhs:= continuation.top;
+ r:= continuation;
+ continuation:= continuation.rest;
+ pattern:= continuation.top;
+ IF pattern IS Name THEN
+ continuation:= continuation.rest;
+ pattern:= pattern.Value();
+ IF (pattern IS Name) & (pattern.indirection=Variable) THEN
+ WITH pattern: Name DO
+ pattern.Assign(lhs);
+ Continue;
+ pattern.Restore();
+ Attributed(result,pattern,lhs);
+ END;
+ RETURN
+ ELSE
+ Push(pattern);
+ END;
+ END;
+ Push(GuardTrap);
+ lhs.Reduce;
+END MatchHandler;
+
+
+PROCEDURE (t: Disjunction) Reduce*;
+VAR
+ oldCont: TermStack;
+BEGIN
+ oldCont:= continuation;
+ t.indirection.Reduce;
+ IF result=Failure THEN
+ continuation:= oldCont;
+ t.alternative.Reduce;
+ END;
+END Reduce;
+
+PROCEDURE (t: Disjunction) InitAlternative*(alt: Term);
+BEGIN
+ t.alternative:= alt;
+END InitAlternative;
+
+PROCEDURE Unify*(t1,t2: Term);
+BEGIN
+ Push(t2);
+ Push(t1);
+ MatchHandler;
+END Unify;
+
+PROCEDURE MakeLocalBlock*(locals,body: Term): Term;
+VAR
+ newTerm: Block;
+BEGIN
+ IF locals=NIL THEN
+ RETURN body
+ END;
+ NEW(newTerm);
+ newTerm.Init(body);
+ IF locals IS Tree THEN
+ locals:= locals(Tree).attributes;
+ END;
+ newTerm.attributes:= locals(Equation);
+ RETURN newTerm
+END MakeLocalBlock;
+
+
+PROCEDURE MakeAlternative*(pattern,ifMatch: Term): Term;
+VAR
+ sub1,sub2: SubTerm;
+(* newDis: Disjunction; *)
+ acc: Equation;
+
+ PROCEDURE Locals(t: Equation);
+ VAR
+ newEq: Equation;
+ BEGIN
+ IF t#NIL THEN
+ IF t.indirection IS Name THEN
+ IF (acc=NIL) OR (acc.Association(t.indirection(Name))=NIL) THEN
+ NEW(newEq);
+ newEq.param:= t.indirection(Name);
+ newEq.indirection:= Variable;
+ newEq.next:= acc;
+ acc:= newEq;
+ END;
+ ELSIF t.indirection IS Tree THEN
+ Locals(t.indirection(Tree).attributes);
+ END;
+ Locals(t.next);
+ END;
+ END Locals;
+BEGIN
+ WITH pattern: Tree DO
+ NEW(sub1);
+ NEW(sub2);
+ sub1.query:= ifMatch;
+ sub2.query:= pattern;
+ sub2.indirection:= GuardTrap;
+ sub1.indirection:= sub2;
+ acc:= NIL;
+ Locals(pattern.attributes);
+(* IF noMatch=NIL THEN *)
+ RETURN MakeLocalBlock(acc,sub1)
+(* END;
+ NEW(newDis);
+ newDis.indirection:= MakeLocalBlock(acc,sub1);
+ newDis.alternative:= noMatch;
+ RETURN newDis *)
+ ELSE
+ RETURN ifMatch
+ END;
+END MakeAlternative;
+
+BEGIN
+ NEW(stack);
+ sp:= 0;
+ continuation:= NIL;
+ NEW(FunctionResult);
+ FunctionResult.Init(NIL);
+ FunctionResult.InitHandler(ResultHandler);
+ lastAtom:= NIL;
+ NEW(lastResult);
+ lastResult.Init(NIL);
+ NEW(Variable);
+ Variable.Init(NIL);
+ Variable.InitHandler(Continue);
+ NEW(Undefined);
+ Undefined.Init(NIL);
+ Undefined.InitHandler(Continue);
+ NEW(LocalRestore);
+ LocalRestore.Init(NIL);
+ LocalRestore.InitHandler(RestoreLocal);
+ NEW(StackRestore);
+ StackRestore.Init(NIL);
+ StackRestore.InitHandler(RestoreLocals);
+ NEW(GuardTrap);
+ GuardTrap.Init(NIL);
+ GuardTrap.InitHandler(GuardHandler);
+ NEW(MatchTrap);
+ MatchTrap.Init(NIL);
+ MatchTrap.InitHandler(MatchHandler);
+END AGRS.
+
diff --git a/examples/AGRS/Attributes.Def b/examples/AGRS/Attributes.Def
new file mode 100644
index 0000000..4b13edf
--- /dev/null
+++ b/examples/AGRS/Attributes.Def
@@ -0,0 +1,208 @@
+(*
+https://web.archive.org/web/20041223052353/http://www.oberon.ethz.ch:80/ethoberon/defs/Attributes.Def.html
+*)
+DEFINITION Attributes; (* portable *)
+
+(*Module Attributes manages the attribute lists of the gadgets, provides an
+improved scanner with macro substitution facilities for executing commands,
+and supplies type conversion routines.
+*)
+ IMPORT
+ Objects, Texts, Files;
+
+ CONST
+ (* Scanner symbol classes. *)
+ Inval = Texts.Inval; (* Invalid symbol. *)
+ Name = Texts.Name; (* Name. *)
+ String = Texts.String; (* Literal string. *)
+ Int = Texts.Int; (* Integer i. *)
+ Real = Texts.Real; (* Real number x. *)
+ LongReal = Texts.LongReal; (* Long real number y. *)
+ Char = Texts.Char; (* Special character c. *)
+ Obj = Texts.Object; (* Object o. *)
+
+ TYPE
+ Reader = POINTER TO ReaderDesc; (* Macro substituting reader. *)
+ ReaderDesc = RECORD
+ substitute: BOOLEAN; (* Is substitution on or off? *)
+ text: Texts.Text; (* Current text read. *)
+ eot: BOOLEAN; (* End of text reached? *)
+ lib: Objects.Library; (* Library of last character/object read. *)
+ END;
+
+(* Upcall for macro substitution. Ch is the character to be substituted, res
+is the substitution text and beg is the starting position inside of the text.*)
+ MacroHandler = PROCEDURE (ch: CHAR; VAR T: Reader; VAR res: Texts.Text; VAR beg: LONGINT);
+ Scanner = RECORD (* Macro substituting scanner *)
+ R: Reader; (* Scanner operates with this reader. *)
+ eot: BOOLEAN; (* End of text reached? *)
+ nextCh: CHAR; (* Character located immediately after scanned token. *)
+ class: INTEGER; (* Scanner classes. Scanned tokens are returned in the
+record fields below. *)
+ i: LONGINT;
+ x: REAL;
+ y: LONGREAL;
+ c: CHAR;
+ len: SHORTINT;
+ s: ARRAY 128 OF CHAR;
+ o: Objects.Object;
+ END;
+
+ (* Data structures for storing attribute lists. *)
+ Attr = POINTER TO AttrDesc;
+ AttrDesc = RECORD
+ next: Attr;
+ name: Objects.Name
+ END;
+
+ BoolAttr = POINTER TO BoolDesc;
+ BoolDesc = RECORD ( AttrDesc )
+ b: BOOLEAN END;
+
+ CharAttr = POINTER TO CharDesc;
+ CharDesc = RECORD ( AttrDesc )
+ c: CHAR END;
+
+ IntAttr = POINTER TO IntDesc;
+ IntDesc = RECORD ( AttrDesc )
+ i: LONGINT END;
+
+ RealAttr = POINTER TO RealDesc;
+ RealDesc = RECORD ( AttrDesc )
+ r: LONGREAL END;
+
+ StringAttr = POINTER TO StringDesc;
+ StringDesc = RECORD ( AttrDesc )
+ s: ARRAY 64 OF CHAR; END;
+
+(* Convert a string to a text. *)
+ PROCEDURE StrToTxt (s: ARRAY OF CHAR; VAR T: Texts.Text);
+
+(* Convert a text to a string. The string might be terminated early if the text
+is too long to fit. *)
+ PROCEDURE TxtToStr (T: Texts.Text; VAR s: ARRAY OF CHAR);
+
+(* Read character ch from the Reader. Registered character macros are automatically
+substituted by making upcalls to the installed macro handlers. *)
+ PROCEDURE Read (VAR R: Reader; VAR ch: CHAR);
+
+(* Open reader R at position pos in text. *)
+ PROCEDURE OpenReader (VAR R: Reader; text: Texts.Text; pos: LONGINT);
+
+(* Return current position of Reader R in text R.text. Note that R.text may
+change as macro characters are being substituted. *)
+ PROCEDURE Pos (VAR R: Reader): LONGINT;
+
+(* Open Scanner S at position pos in text T. *)
+ PROCEDURE OpenScanner (VAR S: Scanner; T: Texts.Text; pos: LONGINT);
+
+(* Read the next symbol or object in the text. White space is ignored. *)
+ PROCEDURE Scan (VAR S: Scanner);
+
+(* Register a macro handler for a character. This handler is called when character
+ch is read using the reader/scanner, and must return a text with the substitution.
+*)
+ PROCEDURE AddMacro (ch: CHAR; handler: MacroHandler);
+
+(* Store the atttribute list A. *)
+ PROCEDURE StoreAttributes (VAR R: Files.Rider; A: Attr);
+
+(* Load attribute list resulting in a list A. *)
+ PROCEDURE LoadAttributes (VAR R: Files.Rider; VAR A: Attr);
+
+(* Copy an attribute list. *)
+ PROCEDURE CopyAttributes (in: Attr; VAR out: Attr);
+
+(* Insert an attribute in a list. An existing attribute with the same name is
+discarded. *)
+ PROCEDURE InsertAttr (VAR list: Attr; name: ARRAY OF CHAR; val: Attr);
+
+(* Search for an attribute name in list. *)
+ PROCEDURE FindAttr (name: ARRAY OF CHAR; list: Attr): Attr;
+
+(* Delete an attribute. *)
+ PROCEDURE DeleteAttr (VAR list: Attr; name: ARRAY OF CHAR);
+
+(* Write the attribute attr of object obj to the writer W. Format conversion
+to strings are automatic.*)
+ PROCEDURE WriteAttr (obj: Objects.Object; attr: ARRAY OF CHAR; VAR W: Texts.Writer);
+
+(* GetXXX(obj: Objects.Object; name: ARRAY OF CHAR; VAR x: T);
+ Retrieve object attribute name and convert it to type T.
+ The following conversions are done by GetType:
+ Type T Attribute classes converted
+
+ Bool BOOLEAN Bool, String, Char
+ Int LONGINT Int, String, Real, LongReal
+ Real REAL Real, String, LongReal, Int
+ LongReal LONGREAL LongReal, String, Real, Int
+ String ARRAY OF CHAR String, Int, Bool, Real, LongReal, Bool
+*)
+ PROCEDURE GetBool (obj: Objects.Object; name: ARRAY OF CHAR; VAR b: BOOLEAN);
+ PROCEDURE GetInt (obj: Objects.Object; name: ARRAY OF CHAR; VAR i: LONGINT);
+ PROCEDURE GetReal (obj: Objects.Object; name: ARRAY OF CHAR; VAR x: REAL);
+ PROCEDURE GetLongReal (obj: Objects.Object; name: ARRAY OF CHAR; VAR y: LONGREAL);
+ PROCEDURE GetString (obj: Objects.Object; name: ARRAY OF CHAR; VAR s: ARRAY OF CHAR);
+
+(* SetXXX(obj: Objects.Object; name: ARRAY OF CHAR; x: T);
+ Set object attribute name and convert it to the the attribute class understood
+by obj.
+ The following conversions are done by SetType:
+ Type T Attribute classes converted
+
+ Bool BOOLEAN Bool, String, Char
+ Int LONGINT Int, String, Real, LongReal
+ Real REAL Real, String, LongReal, Int
+ LongReal LONGREAL LongReal, String, Real, Int
+ String ARRAY OF CHAR String, Int, Bool, Real, LongReal, Bool
+*)
+ PROCEDURE SetBool (obj: Objects.Object; name: ARRAY OF CHAR; b: BOOLEAN);
+ PROCEDURE SetInt (obj: Objects.Object; name: ARRAY OF CHAR; i: LONGINT);
+ PROCEDURE SetReal (obj: Objects.Object; name: ARRAY OF CHAR; x: REAL);
+ PROCEDURE SetLongReal (obj: Objects.Object; name: ARRAY OF CHAR; y: LONGREAL);
+ PROCEDURE SetString (obj: Objects.Object; name, s: ARRAY OF CHAR);
+
+(* Write all parameters of command. *)
+ PROCEDURE Echo;
+
+END Attributes.
+
+(*
+Remarks:
+
+1. Reader and Scanner
+The reader and scanner operate in the same fashion as that of the Text module.
+There are however a few exceptions. First, the reader does macro substitution
+as texts are read. Some macros are predefined, and the programmer has the capability
+to add his or her own macros by identifying special symbols for macros and a
+handler for that macro symbol. While reading or scanning a text, upcalls are
+made to the registered macro handler to return a substitution text for the macro
+symbol. New macros are registered with the AddMacro procedure. The macro handler
+has to return a text and a position in the text where reading/scanning should
+continue. Reading/scanning will continue in the original text after the end
+of the substitution text is reached. The macro might take parameters (letters
+that follow immediately after the macro symbol), which are read by the macro
+handler using the passed Reader. Note that no substitution is made when no text
+(= NIL) is returned. By default, the up arrow ("^"), which expands to the current
+selection, is installed as a macro in the Attributes module. In contrast to
+the Texts.Scanner, the Attributes.Scanner scan words containing letters like
+ä, ü, ö, – etc, and (non-character) objects embedded inside of the text.
+
+2. Attribute Message and Attribute Storage
+Most gadgets employ two strategies for storing attribute values. The first is
+by allocating own storage space for the attributes in the object definition
+and by responding on the Objects.AttrMsg when these attributes are accessed.
+The second way is having the default message handlers of module Gadgets take
+care of attributes. This is called the default or standard handling of attributes.
+The default message handlers manage lists of gadgets with the types defined
+in module Attributes. Such an attribute list is always identified by its first
+component, which might change when attributes are inserted or deleted. Many
+gadgets uses a hybrid approach to attribute handling, where own attributes are
+handled in a special way, and all other attributes are handled by the default
+message handlers. For example, the "Name" of a gadget is typically handled by
+the default message handlers. This has the advantage that storage space is only
+used when the attribute has a value (remember that many gadgets don't have names,
+and allocating space inside your own gadget record descriptor for a name, makes
+you pay the storage price for each gadget, even if it is not named).
+
+*)
diff --git a/examples/AGRS/Directories.Def b/examples/AGRS/Directories.Def
new file mode 100644
index 0000000..f59d9ab
--- /dev/null
+++ b/examples/AGRS/Directories.Def
@@ -0,0 +1,48 @@
+(*
+https://web.archive.org/web/20041224144144/http://www.oberon.ethz.ch:80/ethoberon/defs/Directories.Def.html
+*)
+DEFINITION Directories; (* portable *)
+
+ IMPORT
+ Objects,
+ Gadgets, ListRiders;
+
+ TYPE
+ Model = POINTER TO ModelDesc;
+ ModelDesc = RECORD ( Gadgets.ObjDesc )
+ END;
+
+ Rider = POINTER TO RiderDesc;
+ RiderDesc = RECORD ( ListRiders.RiderDesc )
+ END;
+
+ TYPE FileProc = PROCEDURE (d: Directory; name: ARRAY OF CHAR; isDir: BOOLEAN; VAR continue: BOOLEAN);
+
+(* Update the model (not yet implemented) *)
+ PROCEDURE UpdateModel (obj: Model);
+
+(* Standard handler for directory models *)
+ PROCEDURE ModelHandler (obj: Objects.Object; VAR M: Objects.ObjMsg);
+
+(* Initialize a directory model *)
+ PROCEDURE InitModel (obj: Model; rootDir, mask: ARRAY OF CHAR);
+
+(* Generator for directory models *)
+ PROCEDURE New;
+ PROCEDURE NewDirList;
+ PROCEDURE NewDrv;
+
+(* Finds all the filenames in the search path that match a specified pattern
+and inserts them
+ into a list model gadget (ListModel, Tree or Dag) named <Objname> in the current
+context.
+ If the option p is specified, the filenames are prefixed with their relative
+path in the current
+ working directory.
+ Usage: Directories.Directory [p] "<pattern>" <Objname> ~
+*)
+ PROCEDURE Directory;
+
+ PROCEDURE Enumerate (dir: Directory; fileProc: FileProc);
+ PROCEDURE This (path: ARRAY OF CHAR): Directory;
+END Directories.
diff --git a/examples/AGRS/Display.Def b/examples/AGRS/Display.Def
new file mode 100644
index 0000000..17990a7
--- /dev/null
+++ b/examples/AGRS/Display.Def
@@ -0,0 +1,403 @@
+(*
+https://web.archive.org/web/20050306075112/http://www.oberon.ethz.ch:80/ethoberon/defs/Display.Def.html
+*)
+DEFINITION Display; (* portable, except where noted *)
+
+(*
+Module Display provides the display drawing primitives and the base type of
+the visual objects, called Frames.
+*)
+ IMPORT Objects;
+
+ CONST
+ BG = 0; FG = 15; (* Background, foreground color palette indices *)
+
+ (* Drawing operation modes. *)
+ replace = 0; (* replace destination. *)
+ paint = 1; (* paint over destination. *)
+ invert = 2; (* invert destination. *)
+
+ (* Message ids. *)
+ remove = 0; suspend = 1; restore = 2; newprinter = 3; (* ControlMsg id.
+*)
+ reduce = 0; extend = 1; move = 2; (* ModifyMsg id. *)
+ display = 0; state = 1; (* ModifyMsg mode. *)
+ screen = 0; printer = 1; (* DisplayMsg device *)
+ full = 0; area = 1; contents = 2; (* DisplayMsg id. *)
+ get = 0; set = 1; reset = 2; (* SelectMsg id. *)
+ drop = 0; integrate = 1; (* ConsumeMsg id. *)
+
+ (* TransferFormat() return values. value DIV 8 = bytes per pixel. portable,
+release >= 2.4*)
+ unknown = 0; index8 = 8; color555 = 16; color565 = 17; color664 = 18; color888 = 24; color8888 = 32;
+
+ TYPE
+ Color = LONGINT; (* portable, release >= 2.4 *)
+ Pattern = LONGINT;
+ Frame = POINTER TO FrameDesc; (* Base type of all displayable objects. *)
+ FrameDesc = RECORD ( Objects.ObjDesc )
+ next, dsc: Frame; (* Sibling, child pointers. *)
+ X, Y, W, H: INTEGER (* Coordinates. *)
+ END;
+
+ FrameMsg = RECORD ( Objects.ObjMsg ) (* Base type of messages sent to frames.
+*)
+ F: Frame; (* Message target, NIL for broadcast. *)
+ x, y: INTEGER; (* Message origin. *)
+ res: INTEGER (* Result code: <0 = error or no response, >=0 response. *)
+ END;
+
+ ControlMsg = RECORD ( FrameMsg )
+ id: INTEGER (* remove, suspend, restore. *)
+ END;
+
+ ModifyMsg = RECORD ( FrameMsg ) (* Change coordinates in container frame.
+*)
+ id: INTEGER; (* reduce, extend, move. *)
+ mode: INTEGER; (* Modes display, state. *)
+ dX, dY, dW, dH: INTEGER; (* Change from old coordinates (delta). *)
+ X, Y, W, H: INTEGER (* New coordinates. *)
+ END;
+
+ DisplayMsg = RECORD ( FrameMsg ) (* Display a frame, a part of it or its
+contents. *)
+ device: INTEGER; (* screen, printer *)
+ id: INTEGER; (* full, area, contents. *)
+ u, v, w, h: INTEGER (* Area to be restored. *)
+ END;
+
+ LocateMsg = RECORD ( FrameMsg ) (* Locate frame in display space. *)
+ loc: Frame; (* Result. *)
+ X, Y: INTEGER; (* Absolute location. *)
+ u, v: INTEGER (* Relative coordinates in loc. *)
+ END;
+
+ SelectMsg = RECORD ( FrameMsg ) (* Selection control. *)
+ id: INTEGER; (* get, set, reset. *)
+ time: LONGINT; (* Time of selection. *)
+ sel: Frame; (* Parent of selection. *)
+ obj: Objects.Object (* List of objects involved, linked with slink. *)
+ END;
+
+ ConsumeMsg = RECORD ( FrameMsg ) (* Drop, integrate frames. *)
+ id: INTEGER; (* drop, integrate. *)
+ u, v: INTEGER; (* Relative coordinates in destination when drop. *)
+ obj: Objects.Object (* List of objects to be consumed, linked with slink.
+*)
+ END;
+
+ MsgProc = PROCEDURE (VAR M: FrameMsg);
+
+ VAR
+ Unit: LONGINT; (* RasterUnit = Unit/36000 mm *)
+ Left, (* Left margin of black-and-white screen. *)
+ ColLeft, (* Left margin of secondary display, often same as Left. *)
+ Bottom, (* Bottom of primary map. *)
+ UBottom, (* Bottom of offscreen area (negative), 0 if not supported. *)
+ Width, (* Display width. *)
+ Height: INTEGER; (* Display height. *)
+ arrow, (* Oberon cursor. *)
+ star, (* Star marker to mark documents and viewers. *)
+ cross, (* Insertion marker. *)
+ downArrow, (* Marker to indicate disk operation. *)
+ hook, (* Text caret pattern. *)
+ grey0, grey1, grey2, ticks, solid: Pattern; (* Simulated grey levels.
+*)
+ Broadcast: MsgProc; (* Message broadcast to all frames in the display space.
+*)
+
+(* Change color palette entry. 0 <= col, red, green, blue < 256. *)
+ PROCEDURE SetColor (col: Color; red, green, blue: LONGINT);
+
+(* Retrieve color palette entry or color components of a true color value. 0
+<= red, green, blue < 256. *)
+ PROCEDURE GetColor (col: Color; VAR red, green, blue: INTEGER);
+
+(* Return true color with specified components. 0 <= red, green, blue < 256.
+ Not all display regions support true color values, see TrueColor(). *)
+ PROCEDURE RGB (red, green, blue: LONGINT): Color; (* portable, release >=
+2.4 *)
+
+(* Returns the color palette depth for the specified display region. Typical
+values are 1, 4 and 8 (not larger). *)
+ PROCEDURE Depth (x: LONGINT): INTEGER;
+
+(* Returns TRUE iff the specified display region supports true color values.
+*)
+ PROCEDURE TrueColor (x: LONGINT): BOOLEAN; (* portable, release >= 2.4 *)
+
+(* Get the current clip rectangle. *)
+ PROCEDURE GetClip (VAR x, y, w, h: INTEGER);
+
+(* Set the new clipping rectangle. *)
+ PROCEDURE SetClip (x, y, w, h: LONGINT);
+
+(* Intersect with current clip rectangle resulting in a new clip rectangle.
+*)
+ PROCEDURE AdjustClip (x, y, w, h: LONGINT);
+
+(* Reset the current clipping rectangle to the whole display, including offscreen
+area. *)
+ PROCEDURE ResetClip;
+
+(* Copy source block sx, sy, w, h to destination dx, dy using operation mode.
+A block is given by its lower left corner sx, sy and its dimension w, h. Some
+drivers only implement mode = replace. *)
+ PROCEDURE CopyBlock (sx, sy, w, h, dx, dy, mode: LONGINT);
+
+(* Copy pattern pat in color col to x, y using operation mode. *)
+ PROCEDURE CopyPattern (col: Color; pat: Pattern; x, y, mode: LONGINT);
+
+(* Replicate pattern pat in color col into block x, y, w, h using operation
+mode, proceeding from left to right and from bottom to top, starting at lower
+left corner. The pattern origin is placed at px, py. *)
+ PROCEDURE FillPattern (col: Color; pat: Pattern; px, py, x, y, w, h, mode: LONGINT);
+
+(* Like FillPattern, but the pattern origin is placed at 0, 0. *)
+ PROCEDURE ReplPattern (col: Color; pat: Pattern; x, y, w, h, mode: LONGINT);
+
+(* Block fill in color col and operation mode. mode paint and replace are equivalent.
+*)
+ PROCEDURE ReplConst (col: Color; x, y, w, h, mode: LONGINT);
+
+(* Place a dot of color col in operation mode at x, y. Effect equivalent to
+ReplConst with a block of size 1, 1. *)
+ PROCEDURE Dot (col: Color; x, y, mode: LONGINT);
+
+(* Returns the dimensions of a pattern. *)
+ PROCEDURE GetDim (pat: Pattern; VAR w, h: INTEGER);
+
+(* Define a new pattern. *)
+ PROCEDURE NewPattern (w, h: LONGINT; VAR image: ARRAY OF SET): Pattern;
+
+(* Return the TransferBlock format of a display region. *)
+ PROCEDURE TransferFormat (x: LONGINT): LONGINT; (* portable, release >= 2.4
+*)
+
+(* Transfer a block of pixels in display format to (mode = set) or from (mode
+= get) the display. Pixels in the rectangular area are transferred from bottom
+to top and left to right. The pixels are transferred to or from buf, starting
+at ofs, and with line increment stride, which may be < 0. *)
+ PROCEDURE TransferBlock (VAR buf: ARRAY OF CHAR; ofs, stride, x, y, w, h, mode: LONGINT); (*
+portable, release >= 2.4 *)
+
+(* Change display mode. s is driver-specific. *)
+ PROCEDURE SetMode (x: LONGINT; s: SET); (* non-portable *)
+
+(* Display a picture. Used internally by Pictures module only. *)
+ PROCEDURE DisplayBlock (adr, dx, dy, w, h, sx, sy, mode: LONGINT); (* non-portable
+*)
+
+(* Return address of display located at x, or 0 if not supported. *)
+ PROCEDURE Map (x: LONGINT): LONGINT; (* non-portable *)
+END Display.
+
+(* Remarks:
+
+1. Background and Foreground colors
+Oberon can either be used with white text on a black background, or inverted
+with black text on a white background (the so-called paper model). To reduce
+confusion you should use the FG and BG constants in your code.
+
+2. Screen Organization
+Oberon supports multiple displays that are placed next to each other in increasing
+X coordinates. The X coordinate thus uniquely determines the screen, hence the
+single parameter of the Depth and TransferFormat procedures. Each screen contains
+a set of nested frames. Historically, the first screen (at Left) is the black
+and white screen, and the second screen is the color screen (at ColLeft). Today
+Left and ColLeft are typically set to 0 (for compatability with older applications),
+as only a few computers still use black and white displays. Only the color map
+is supported, and it now exists at the display origin. The screen origin is
+located at the bottom-left corner of the display (i.e. Y decrease from the top
+to the bottom of the display).
+
+3. The Frames and the Frame messages
+Frames are the visual entities of Oberon. The frames are placed in the display
+space to make them visible. This involves inserting frames using the dsc and
+next fields into a container already located in the display space. All frames
+of a container are linked together in priority sequence using the next field.
+The dsc field points to the first child frame of a container. Note that this
+is only a convention and certain frames might decide to manage their contents
+in different ways. The frame messages are used to manipulate Frames. Frames
+also respond to the object message defined in module Objects.
+
+4. Target or Destination frames
+The Frame messages are often broadcast into the display space rather than sending
+them directly to a frame. This is useful when many frames are to be informed
+of an event. It is also a means to determine the exact location (in coordinates
+and nesting) of a frame in the display space by following the message thread
+from the display root object to the frame itself (see module Objects). It is
+also possible to address a broadcast message to a certain frame. This is called
+a directed broadcast, because the message is still broadcast, but is intended
+for a specific target only. The target or destination of a broadcast message
+is identified by the F field in the FrameMsg. It is set to NIL when all frames
+are to receive the message (true broadcast) and to a specific frame if only
+that frame is interested in the message (directed broadcast). The exact location,
+in coordinates and nesting, of a frame in the display space can be determined
+by tracing the message thread from the display root object to the frame itself.
+ See module Objects.
+
+5. Frame Coordinates and Message origin
+The coordinates of a frame are specified relative to its container or parent
+frame. The frame messages pass the absolute position of the top-left corner
+of the parent frame to their children in the x and y fields (called the message
+origin). Thus the absolute display position of a frame F is determined when
+it receives a frame message M:
+
+ M.x + F.X, M.y + F.Y, F.W, F.H
+
+M.x and M.y are set by the container to its absolute coordinates. refer to sections
+5.5-5.7 of The Oberon Companion (in Book.Tool).
+
+6. Invalidating Messages
+Often a frame knows that a broadcast need not pass through the remainder of
+display space because it has already been handled. In such cases the res field
+of the frame message is set to zero or positive to indicate that an action has
+been completed and that the message is invalidated. Setting the res field in
+this way is called "invalidating a message" and will terminate the broadcast.
+
+7. Broadcasting Frame Messages
+The Broadcast procedure broadcasts a message through the display space. The
+procedure initializes fields in the frame message. The message origin is set
+to (0, 0), the message is time stamped, the res field is set to a negative value,
+and the dlink field (defined in the base type Objects.ObjMsg) is initialized
+to NIL. In addition, the clipping rectangle is set to the whole display area.
+ Refer to section 5.7 of The Oberon Companion (in Book.Tool) for a description
+of dlink.
+
+8. Clipping
+To prevent the clipping rectangle clipping the wrong display primitives, it
+is reset on each message broadcast or when a trap occurs. Clipping does not
+affect the drawing of cursors. The Gadget system uses "display masks" that hide
+the management of the clipping rectangle from the programmer.
+
+9. NewPattern
+The NewPattern procedure allows you to define patterns in a machine portable
+way. The sets contain 32 bits, each specifying a single pixel, with {0} the
+left-most pixel of the pattern. Each pattern line must be filled with empty
+bits so that it is a multiple of 32 pixels long. The first SET of the array
+contains the bottom line of the pattern.
+
+10. ControlMsg
+The ControlMsg is primarily used to remove a frame from the display space. When
+id is set to remove, the destination frame should be removed from its current
+location. This done by the container of the frame and is thus a slight misinterpretation
+of F as a destination frame. More than one frame is removed if the destination
+is a list of frames connected by the slink field. In this case, they should
+all belong to the same parent. This message should always be broadcast.
+When the message id is set to suspend or restore it indicates that all frames
+from the destination downwards in the display space will be temporarily removed
+from the display space, or will be restored to the display space. This allows
+frames to update their internal data structures as they may have missed messages
+while suspended. This is because only those frames located in the display space
+receive message broadcasts. This message is sent to the top-most frame of that
+part of the display space involved with the destination set to NIL.
+
+11. ModifyMsg
+The ModifyMsg broadcasts a resize request to the destination frame. This allows
+moving the relative position or changing the size of a child in a container.
+When the mode is set to state, the frame should not display itself immediately
+but should only update its size and position and possibly indicate changes to
+its children. It is then the task of the sender to send a follow up Display
+message to the frame. The latter way of using the ModifyMsg allows a container
+to influence its children without having them draw themselves for each change
+made. This message must never be invalidated; i.e. it must travel throughout
+the whole display space. The dX, dY, dW, dH coordinates should always be set
+correctly to indicate the change in position and size from the original position
+and size. The id field of the ModifyMsg is ignored by most frames in the system.
+
+12. DisplayMsg
+The DisplayMsg sends either a redraw request or a print request to a destination
+frame, according to whether the value of device is screen or printer. When the
+destination is NIL, a whole DAG of gadgets is implied. When id is set to area,
+the area u, v, w, h inside the destination frame should be redrawn. Gadgets
+assumes that these coordinates are relative to the top left-most corner of the
+destination gadget. Thus v is negative.
+
+When printing, the x, y coordinates indicate the absolute printer coordinates
+of the left-bottom corner of the frame on paper and not the left-bottom corner
+of the container. When the id is set to full, the frame must print itself as
+it appears on the display. When the id is set to contents the frame must print
+its complete contents. For example, a multi-page text can be displayed and printed.
+The frame can assume that the printer driver has already been initialized. Readying
+the printer is the task of the sender and is done by calling Printer.Open.
+
+13. LocateMsg
+This message is broadcast to locate the frame positioned at the absolute coordinates
+X, Y on the display. The result, if any, is found in the loc field. The frame
+should return the relative position u, v of X, Y inside itself. Gadgets return
+these coordinates relative to their top-left corner (i.e. v is typically negative).
+By convention, the message is invalidated when the loc field is set.
+
+14. SelectMsg
+When id is set to get, the message is used to return the current object selection,
+a list, in obj. The parent of the selected objects is returned in the sel field.
+This message is broadcast with the destination set to NIL. The time of the selection
+is returned in the time field. Each container frame in the display space typically
+compares the time of its selection with the time field in the message, updating
+the returned selection when it is after the time set in the message field. When
+id is set to set or reset, the destination frame should select or unselect itself.
+It should never draw itself at this point. This is the task of the message sender.
+
+15. ConsumeMsg
+When the id is set to drop, the destination frame is requested to consume the
+list of objects found in the obj field. In this way objects can be dynamically
+ added to a container. The relative u, v coordinates indicate the location inside
+the container.
+Typically v is negative. When id is set to integrate, the message is broadcast
+and indicates that the frame owning the focus (caret) should consume the list
+of objects.
+
+16. The Broadcast procedure is installed by module Viewers to the default message
+broadcasting procedure found in that module.
+
+17. TransferBlock
+TransferBlock is a fast way to read or write the display in a format as close
+as possible to the native format of the driver. If the driver does not directly
+use one of the supported formats (defined below), it must select one and translate
+on-the-fly. The caller must be prepared to handle any of the supported return
+formats. The value returned by TransferFormat is constant, unless the display
+mode is changed. TransferBlock performs clipping using the normal clipping
+rectangle. When reading from the display, the pixels falling outside the clipping
+rectangle have undefined values.
+
+18. TransferFormat returns
+ unknown - TransferBlock not supported
+ index8 - 8 bits per pixel indexed
+ color555 - 16 bits per pixel XRGB 1x5x5x5
+ color565 - 16 bits per pixel RGB 5x6x5
+ color664 - 16 bits per pixel RGB 6x6x4
+ color888 - 24 bits per pixel RGB 8x8x8
+ color8888 - 32 bits per pixel XRGB 8x8x8x8
+color components: R = red, G = green, B = blue, X = undefined.
+multibyte values are stored in little-endian order in buf (least-significant
+byte first).
+color components are stored in XRGB bit order (B in least-significant bits).
+
+19. Color
+There are two types of display drivers. "Minimal" drivers that support only
+indexed color, and "full-featured" drivers that support indexed color and true
+color. Monochrome drivers should emulate one of the two options. The TrueColor()
+function can be used to determine what kind of driver is active in a display
+region. A minimal driver only supports color values from 0 to 255 (0 to 0FFH),
+which are entries into the palette, and color values outside this range produce
+undefined results (e.g. garbage, index out of range trap). A full-featured
+driver also supports 24-bit true color values that range from MIN(LONGINT) to
+MIN(LONGINT)+2^24-1 (80000000H to 80FFFFFFH). The driver translates the color
+values to the internal format of the display buffer on-the-fly.
+
+20. The RGB() function can be used to construct true color values. The RGB
+components are defined as:
+ R = ASH(col, -16) MOD 256, G = ASH(col, -8) MOD 256, B = col MOD 256, and
+ col = MIN(LONGINT) + ASH(R, 16) + ASH(G, 8) + B, where 0 <= R,G,B <= 255
+The RGB function can be used to compose color values, and GetColor can be used
+to decompose them, as well as to read from the palette.
+
+21. Depth() returns the depth of the color palette.
+ 1 - recommend use of color indices BG and FG only.
+ 4 - color indices 0 to 16 supported.
+ 8 - color indices 0 to 255 supported.
+No driver will support a color palette larger than 8 bits. Instead it might
+support true color values generated by function RGB(). The TrueColor() function
+can be used to check if a driver supports such values.
+*)
diff --git a/examples/AGRS/Display3.Def b/examples/AGRS/Display3.Def
new file mode 100644
index 0000000..a56012f
--- /dev/null
+++ b/examples/AGRS/Display3.Def
@@ -0,0 +1,240 @@
+(*
+https://web.archive.org/web/20041103105402/http://www.oberon.ethz.ch:80/ethoberon/defs/Display3.Def.html
+*)
+DEFINITION Display3; (* portable *) (* jm 17.1.95 / tk 7.12.95*)
+
+(*Module Display3 implements the clipped graphic primitives used by the Gadget
+system. It has a twin module called Printer3 that implements the same primitives
+for the printer.
+*)
+ IMPORT
+ Display, Fonts, Pictures;
+
+ CONST
+ replace = Display.replace; paint = Display.paint; invert = Display.invert; (*
+Standard display modes. *)
+
+ (* Display styles *)
+ filled = 1; (* Filled *)
+
+ TYPE
+ Mask = POINTER TO MaskDesc; (* Clipping Mask. *)
+
+ (* Informs a frame of a new mask. This message is always sent directly. *)
+ OverlapMsg = RECORD ( Display.FrameMsg )
+ M: Mask; (* Use NIL to indicate to a frame that its current mask is invalid.
+*)
+ END;
+
+ (* Message broadcast by a frame (identified by the F field) to indicate that
+it has an invalid mask and now requires
+ its parent, to calculate a new mask for it and to inform it through the OverlapMsg.
+*)
+ UpdateMaskMsg = RECORD ( Display.FrameMsg )
+ END;
+
+ MaskDesc = RECORD (* Clipping mask descriptor. *)
+ x, y: INTEGER; (* Relative mask origin or offset. *)
+ X, Y, W, H: INTEGER; (* Current clipping port in absolute coordinates.
+*)
+ END;
+
+ (* Enumerate the set of rectangles in a mask. The clipping port is not enumerated.
+*)
+ EnumProc = PROCEDURE (X, Y, W, H: INTEGER);
+
+ VAR
+ selectpat: Display.Pattern; (* Pattern used to draw gadgets when in a selected
+state. *)
+
+ (* Colors *)
+ FG, BG: INTEGER; (* Foreground (black) and background (white) color indexes.
+*)
+ red, green, blue: INTEGER; (* Primary color indexes. *)
+ black, white: INTEGER; (* True black and white. *)
+ topC: INTEGER; (* Top shadow color. *)
+ bottomC: INTEGER; (* Bottom shadow color. *)
+ upC: INTEGER; (* Color of a button. *)
+ downC: INTEGER; (* Color of the pushed button *)
+ groupC: INTEGER; (* Color of containers, i.e. gadgets that have a grouping
+function like panels. *)
+ invertC: INTEGER; (* Best color for doing inverts.. *)
+ textC: INTEGER; (* Default text color. *)
+ textbackC: INTEGER; (* Default text background. *)
+ textmode: INTEGER; (* Best CopyPattern mode for this display card. *)
+
+(* Initialize the Mask to the empty region, i.e. everything will be clipped
+away. *)
+ PROCEDURE Open (M: Mask);
+
+(* Enumerate all the visible areas of a mask. The clipping port is not enumerated.
+The mask translation vector is taken into account.*)
+ PROCEDURE Enum (M: Mask; enum: EnumProc);
+
+(* Enumerate all the invisible areas of a mask. The clipping port is not enumerated.
+Note that you might obtain coordinates outside of the normal screen area, bounded
+by approximately -/+ 8192. The mask translation vector is taken into account.*)
+ PROCEDURE EnumInvert (M: Mask; enum: EnumProc);
+
+(* Enumerate all the visible areas in the given rectangular region. The clipping
+port is not taken into account. *)
+ PROCEDURE EnumRect (M: Mask; X, Y, W, H: INTEGER; enum: EnumProc);
+
+(* Make a copy of a mask. *)
+ PROCEDURE Copy (from: Mask; VAR to: Mask);
+
+(* Add the rectangle X, Y, W, H as a visible/drawable area to the mask. *)
+ PROCEDURE Add (M: Mask; X, Y, W, H: INTEGER);
+
+(* Clip the current clipping port of the mask to the rectangle X, Y, W, H. The
+result is an updated clipping port. *)
+ PROCEDURE AdjustMask (M: Mask; X, Y, W, H: INTEGER);
+
+(* Remove area X, Y, W, H from the mask i.e. make area undrawable. *)
+ PROCEDURE Subtract (M: Mask; X, Y, W, H: INTEGER);
+
+(* Interset the mask with the rectangle X, Y, W, H. The visible areas are restricted
+to this rectangle. *)
+ PROCEDURE Intersect (M: Mask; X, Y, W, H: INTEGER);
+
+(* Intersect the masks A and B resulting in R. *)
+ PROCEDURE IntersectMasks (A, B: Mask; VAR R: Mask); (* R is an out parameter
+only *)
+
+(* Subtracts the visible areas of B from A to give mask R. *)
+ PROCEDURE SubtractMasks (A, B: Mask; VAR R: Mask);
+
+(* Translate the mask so that the resulting origin/offset is 0, 0. This is done
+by "adding in" the translation vector. *)
+ PROCEDURE Shift (M: Mask);
+
+(* Returns TRUE if the visible areas of the mask form a single rectangle. The
+result, when TRUE, is returned. The clipping port is not taken into account.
+*)
+ PROCEDURE Rectangular (M: Mask; VAR X, Y, W, H: INTEGER): BOOLEAN;
+
+(* Using Display.CopyBlock, copy the area M to position X, Y. The point M.x,
+M.y is copied to screen coordinates X, Y. *)
+ PROCEDURE CopyMask (M: Mask; X, Y: INTEGER; mode: INTEGER);
+
+(* Display.ReplConst through a mask. *)
+ PROCEDURE ReplConst (M: Mask; col: Display.Color; X, Y, W, H, mode: INTEGER);
+
+(* Is this rectangle completely visible? The clipping port is taken into acount.
+*)
+ PROCEDURE Visible (M: Mask; X, Y, W, H: INTEGER): BOOLEAN;
+
+(* Display.Dot through a clipping mask. *)
+ PROCEDURE Dot (M: Mask; col: Display.Color; X, Y, mode: INTEGER);
+
+(* Display.FillPattern through a clipping mask. pX, pY is the pattern pin-point.
+*)
+ PROCEDURE FillPattern (M: Mask; col: Display.Color; pat: Display.Pattern; pX, pY, X, Y, W, H, mode: INTEGER);
+
+(* Same as Display.CopyPattern, but through a clipping mask. *)
+ PROCEDURE CopyPattern (M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, mode: INTEGER);
+
+(* Draw rectangle outline in the specified size, line width and pattern. *)
+ PROCEDURE Rect (M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, W, H, width, mode: INTEGER);
+
+(* Draw rectangle outline in width using top and bottom shadow (3D effects ).*)
+ PROCEDURE Rect3D (M: Mask; topcol, botcol: Display.Color; X, Y, W, H, width, mode: INTEGER);
+
+(* Fill rectangle with 3D shadow effects. incol specifies the "inside" color.
+*)
+ PROCEDURE FilledRect3D (M: Mask; topcol, botcol, incol: Display.Color; X, Y, W, H, width, mode: INTEGER);
+
+(* Draw a line in the specified pattern and width. Round brushes are used to
+draw thick lines. *)
+ PROCEDURE Line (M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, X1, Y1, width, mode: INTEGER);
+
+(* Draw a polygon in pattern pat. n specifies the number of vertices listed
+in the arrays X and Y. Style may be {filled}. *)
+ PROCEDURE Poly (M: Mask; col: Display.Color; pat: Display.Pattern; VAR X, Y: ARRAY OF INTEGER; n, width: INTEGER; style: SET; mode: INTEGER);
+
+(* Draw an ellipse. Implementation restriction: cannot fill an ellipse or draw
+an ellipse with line width > 1 *)
+ PROCEDURE Ellipse (M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, a, b, width: INTEGER; style: SET; mode: INTEGER);
+
+(* Draw a circle in radius r using pattern pat at position X, Y. Thick line
+widths are allowed. *)
+ PROCEDURE Circle (M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, r, width: INTEGER; style: SET; mode: INTEGER);
+
+(* Draw string s in font fnt and color col at position X, Y. *)
+ PROCEDURE String (M: Mask; col: Display.Color; X, Y: INTEGER; fnt: Fonts.Font; s: ARRAY OF CHAR; mode: INTEGER);
+
+(* Draw a string s in font fnt centered in the rectangle X, Y, W, H. Line breaks
+will be inserted as needed. *)
+ PROCEDURE CenterString (M: Mask; col: Display.Color; X, Y, W, H: INTEGER; fnt: Fonts.Font; s: ARRAY OF CHAR; mode: INTEGER);
+
+(* Return the size of a string in width w and height h. dsr returns the baseline
+offset as a positive value. *)
+ PROCEDURE StringSize (s: ARRAY OF CHAR; fnt: Fonts.Font; VAR w, h, dsr: INTEGER);
+
+(* Draw the area X, Y, W, H of picture P at position DX, DY on the display.
+*)
+ PROCEDURE Pict (M: Mask; P: Pictures.Picture; X, Y, W, H, DX, DY, mode: INTEGER);
+
+(* Replicate a picture filling area X, Y, W, H on the display. px, py is the
+picture pin-point. *)
+ PROCEDURE ReplPict (M: Mask; P: Pictures.Picture; px, py, X, Y, W, H, mode: INTEGER);
+END Display3.
+
+(* Remarks:
+
+1. Clipping Masks
+Built on top of the Display module, the Display3 module is the basis of the
+gadgets imaging model. It extends the Display module with more advanced clipped
+drawing primitives like lines, polygonal lines, ellipses, circles etc. A clipping
+mask indicates which areas on the display can be drawn in. You can imagine the
+mask to be a sheet of paper, possibly full of holes, and a display primitive
+being a spray can. The holes are all rectangular, and may overlap (i.e. only
+rectangular holes can be cut out of the paper). Just as you can move the piece
+of paper to spray an image at a new location, the mask can be translated by
+a translation vector (also refered to as the mask origin). By default, the holes
+of a mask are always defined relative to the origin (0, 0). The origin can be
+translated, efficiently moving the mask to a different position. In the MaskDesc,
+the fields x, y specify the mask origin/translation vector. It can be changed
+directly as needed. Internally masks are sets of non-overlapping rectangles,
+where each rectangle has a flag to indicate if drawing is allowed in that area
+or not. After each operation that changes the mask, the mask is checked to see
+if it might be optimal, i.e. if it is a single rectangular visible area. The
+latter case is handled separately, allowing more efficient drawing and masking
+operations. The construction of a mask is more heavyweight in comparison to
+drawing through a mask, mainly due to the latter checks. Masks should be generated
+once, and then left unchanged for as long as possible.
+
+2. Clipping Ports
+Clipping ports are used to optimize masks operations. A clipping port is an
+absolutely positioned rectangular area through which all display operations
+are clipped (a clipping rectangle). The mask and clipping port form together
+the clipped region, where drawing primitives are first clipped to the mask,
+and then to the clipping port. This is an implementation of the following idea.
+Each gadget on the display can be overlapped by other visual objects, and potentially
+need to clip itself when displayed. Each gadget is thus allocated a static clipping
+mask. In some cases however, only parts of a gadget need to be redisplayed,
+for example when a gadget lying partially in front is removed. Rather than creating
+a new clipping mask just for this simple case, the clipping port can manipulated
+to indicate which "sub-area" of a gadget must be drawn. The key idea is thus
+to restrict the clipping mask of a gadget without actually changing the mask
+(a potentially expensive operation). The clipping port is set by the rectangle
+X, Y, W, H in the MaskDesc. These are absolute display coordinates. Programmers
+are allowed to manipulate the clipping port directly or use Display3.AdjustMask.
+
+3. OverlapMsg and UpdateMaskMsg
+Each gadget has a (cached) display mask associated with it, even if it is completely
+visible. This mask is used when a gadget wants to draw on the display. Each
+parent visual gadget (container) has to manage the display masks of its children.
+The Display3 module provides messages for requesting a mask and for setting
+a mask. The OverlapMsg informs a gadget of its display mask. It is sent directly
+to a visual gadget by its parent. After some editing operations it may happen
+that a gadgets' mask has become invalid, in which case it is set to nothing
+(NIL). Should the gadget notice that it has no mask when it wants to draw itself,
+it may broadcast an UpdateMaskMsg to indicate that the parent must create a
+mask for it (the gadget itself is identified by the F field in the frame message).
+The latter should then calculate the mask, and inform the gadget using the OverlapMsg.
+In some cases, a parent can indicate to a child that its mask is not valid any
+more, by sending an OverlapMsg with no mask (M.M = NIL).
+
+*)
+
diff --git a/examples/AGRS/Files.Def b/examples/AGRS/Files.Def
new file mode 100644
index 0000000..da0b9b5
--- /dev/null
+++ b/examples/AGRS/Files.Def
@@ -0,0 +1,135 @@
+(*
+https://web.archive.org/web/20050218154659/http://www.oberon.ethz.ch:80/ethoberon/defs/Files.Def.html
+*)
+DEFINITION Files;
+
+ IMPORT SYSTEM, OFS;
+
+ TYPE
+ File = OFS.File;
+ Rider = OFS.Rider;
+
+(* Creates a new file with the specified name. *)
+ PROCEDURE New (name: ARRAY OF CHAR): File;
+
+(* Open an existing file. The same file descriptor is returned if a file is
+opened multiple times. *)
+ PROCEDURE Old (name: ARRAY OF CHAR): File;
+
+(* Register a file created with New in the directory, replacing the previous
+file in the
+directory with the same name. The file is automatically closed. *)
+ PROCEDURE Register (f: File);
+
+(* Flushes the changes made to a file to disk. Register will automatically Close
+a file. *)
+ PROCEDURE Close (f: File);
+
+(* Returns the current length of a file. *)
+ PROCEDURE Length (f: File): LONGINT;
+
+(* Returns the time (t) and date (d) when a file was last modified. *)
+ PROCEDURE GetDate (f: File; VAR t, d: LONGINT);
+
+(* Sets the modification time (t) and date (d) of a file. *)
+ PROCEDURE SetDate (f: File; t, d: LONGINT);
+
+(* Positions a Rider at a certain position in a file. Multiple Riders can be
+positioned
+at different locations in a file. A Rider cannot be positioned beyond the end
+of a file. *)
+ PROCEDURE Set (VAR r: Rider; f: File; pos: LONGINT);
+
+(* Returns the offset of a Rider positioned on a file. *)
+ PROCEDURE Pos (VAR r: Rider): LONGINT;
+
+(* Returns the File a Rider is based on. *)
+ PROCEDURE Base (VAR r: Rider): File;
+
+(* Read a byte from a file, advancing the Rider one byte further. R.eof indicates
+if the end
+of the file has been passed. *)
+ PROCEDURE Read (VAR r: Rider; VAR x: SYSTEM.BYTE);
+
+(* Reads a sequence of length n bytes into the buffer x, advancing the Rider.
+Less bytes
+will be read when reading over the length of the file. r.res indicates the number
+of unread bytes.
+x must be big enough to hold n bytes. *)
+ PROCEDURE ReadBytes (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
+
+(*
+Portable routines to read the standard Oberon types.
+*)
+ PROCEDURE ReadInt (VAR r: Rider; VAR x: INTEGER);
+ PROCEDURE ReadLInt (VAR r: Rider; VAR x: LONGINT);
+ PROCEDURE ReadSet (VAR r: Rider; VAR x: SET);
+ PROCEDURE ReadBool (VAR r: Rider; VAR x: BOOLEAN);
+ PROCEDURE ReadReal (VAR r: Rider; VAR x: REAL);
+ PROCEDURE ReadLReal (VAR r: Rider; VAR x: LONGREAL);
+ PROCEDURE ReadString (VAR r: Rider; VAR x: ARRAY OF CHAR);
+
+(* Reads a number in compressed variable length notation using the minimum amount
+of bytes. *)
+ PROCEDURE ReadNum (VAR r: Rider; VAR x: LONGINT);
+
+(* Writes a byte into the file at the Rider position, advancing the Rider by
+one. *)
+ PROCEDURE Write (VAR r: Rider; x: SYSTEM.BYTE);
+
+(* Writes the buffer x containing n bytes into a file at the Rider position.
+*)
+ PROCEDURE WriteBytes (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
+
+(*
+Portable routines to write the standard Oberon types.
+*)
+ PROCEDURE WriteInt (VAR r: Rider; x: INTEGER);
+ PROCEDURE WriteLInt (VAR r: Rider; x: LONGINT);
+ PROCEDURE WriteSet (VAR r: Rider; x: SET);
+ PROCEDURE WriteBool (VAR r: Rider; x: BOOLEAN);
+ PROCEDURE WriteReal (VAR r: Rider; x: REAL);
+ PROCEDURE WriteLReal (VAR r: Rider; x: LONGREAL);
+ PROCEDURE WriteString (VAR r: Rider; x: ARRAY OF CHAR);
+
+(* Writes a number in a compressed format. *)
+ PROCEDURE WriteNum (VAR r: Rider; x: LONGINT);
+
+(* Deletes a file. res = 0 indicates success. *)
+ PROCEDURE Delete (name: ARRAY OF CHAR; VAR res: INTEGER);
+
+(* Renames a file. res = 0 indicates success. *)
+ PROCEDURE Rename (old, new: ARRAY OF CHAR; VAR res: INTEGER);
+
+(* Returns the full name of a file. *)
+ PROCEDURE GetName (f: File; VAR name: ARRAY OF CHAR);
+
+END Files.
+
+(* Remarks:
+
+1. Oberon uses the little-endian byte ordering for exchanging files between
+different Oberon platforms.
+
+2. Files are separate entities from directory entries. Files may be anonymous
+by having no name and not being registered in a
+ directory. Files only become visible to other clients of the Files module by
+explicitly passing a File descriptor or by registering
+ a file and then opening it from the other client. Deleting a file of which
+a file descriptor is still available, results in the file
+ becoming anonymous. The deleted file may be re-registered at any time.
+
+3. Files and their access mechanism (Riders) are separated. A file might have
+more than one rider operating on it at different
+ offsets in the file.
+
+4. The garbage collector will automatically close files when they are not required
+any more. File buffers will be discarded
+ without flushing them to disk. Use the Close procedure to update modified
+files on disk.
+
+5. Relative and absolute filenames written in the directory syntax of the host
+operating system are used. By convention, Oberon
+ filenames consists of the letters A..Z, a..z, 0..9, and ".". The directory
+separator is typically / or :. Oberon filenames are
+ case sensitive. *)
diff --git a/examples/AGRS/Fonts.Def b/examples/AGRS/Fonts.Def
new file mode 100644
index 0000000..b88c195
--- /dev/null
+++ b/examples/AGRS/Fonts.Def
@@ -0,0 +1,41 @@
+(*
+https://web.archive.org/web/20050219180020/http://www.oberon.ethz.ch:80/ethoberon/defs/Fonts.Def.html
+*)
+DEFINITION Fonts; (* portable *)
+
+(*
+The Module Fonts implement the Oberon font manager. Fonts are collections
+of characters, each character being a pattern and and metric data.
+*)
+ IMPORT Objects, Display;
+
+ CONST
+ substitute = -1; font = 0; metric = 1; (* Font types. *)
+
+ TYPE
+ Char = POINTER TO CharDesc;
+ Font = POINTER TO FontDesc;
+ CharDesc = RECORD ( Objects.ObjDesc ) (* The objects in a font library.
+*)
+ dx, x, y, w, h: INTEGER; (* Character width, pattern offset (x, y),
+pattern size (w, h). *)
+ pat: Display.Pattern (* Character raster data. *)
+ END;
+
+ FontDesc = RECORD ( Objects.LibDesc )
+ type: SHORTINT; (* Substitute, font, or metric. *)
+ height, minX, maxX, minY, maxY: INTEGER (* Font height, extremal values
+of characters in font. *)
+ END;
+
+ VAR
+ FontId: CHAR; (* Initial character of font files (.Fnt). *)
+ Default: Font; (* Default system screen font (typically Oberon10.Scn.Fnt).
+*)
+
+(* Return the character and data of ch in a font. *)
+ PROCEDURE GetChar (F: Font; ch: CHAR; VAR dx, x, y, w, h: INTEGER; VAR pat: Display.Pattern);
+
+(* Load and cache a font. *)
+ PROCEDURE This (name: ARRAY OF CHAR): Font;
+END Fonts.
diff --git a/examples/AGRS/Gadgets.Def b/examples/AGRS/Gadgets.Def
new file mode 100644
index 0000000..9db7dc8
--- /dev/null
+++ b/examples/AGRS/Gadgets.Def
@@ -0,0 +1,538 @@
+(*
+https://web.archive.org/web/20050101093105/http://www.oberon.ethz.ch:80/ethoberon/defs/Gadgets.Def.html
+*)
+DEFINITION Gadgets; (* portable *)
+
+(*The Gadgets module forms the basis of the Gadgets system. It defines the
+most important types, provide default message handlers and often used utility
+procedures. In addition, a few gadget specific messages are defined.
+*)
+ IMPORT
+ Objects, Display, Display3, Oberon, Files,
+ Attributes, Links;
+
+ CONST
+ (* Priority message id's. *)
+ top = 0; (* Move gadget to the front. *)
+ bottom = 1; (* Move gadget to the back. *)
+ visible = 2; (* Move gadget to the front if not completely visible. *)
+
+ (* Gadget Frame states. *)
+ selected = 0; (* Selected or not. *)
+ lockedsize = 2; (* Gadget prefers a fixed W, H. *)
+ transparent = 4; (* Transparent or not. *)
+ lockedcontents = 10; (* All direct descendants are locked. *)
+
+ TYPE
+ (* Message broadcast in the display space to indicate that "obj" has changed.
+Normally used for updating model gadgets, although obj can be a list of gadget
+frames belonging to the same container. In this case all of the frames are to
+be displayed. This message is used by the Inspector to indicate that an attribute
+value has changed. *)
+ UpdateMsg = RECORD ( Display.FrameMsg )
+ obj: Objects.Object;
+ END;
+
+ (* Message broadcast in the display space to indicate that the destination
+frame F wants to change its overlapping priority. *)
+ PriorityMsg = RECORD ( Display.FrameMsg )
+ id: INTEGER; (* Top, bottom, visible. *)
+ passon: BOOLEAN; (* Indication if a whole tree of containers should be changed
+in priority. *)
+ END;
+
+ CmdMsg = RECORD ( Objects.ObjMsg )
+ cmd: ARRAY 128 OF CHAR;
+ res: INTEGER;
+ END;
+
+ (* Base type of the Model gadgets *)
+ Object = POINTER TO ObjDesc;
+ ObjDesc = RECORD ( Objects.ObjDesc )
+ attr: Attributes.Attr; (* Attribute list. Private variable. *)
+ link: Links.Link (* Link list. Private variable. *)
+ END;
+
+ (* Base type of the visual gadgets *)
+ Frame = POINTER TO FrameDesc;
+ FrameDesc = RECORD ( Display.FrameDesc )
+ attr: Attributes.Attr; (* Attribute list. Private variable. *)
+ link: Links.Link; (* Link list. Private variable. *)
+ state: SET;
+ mask: Display3.Mask; (* Cached display mask. Can be NIL to indicate no/invalid
+mask. *)
+ obj: Objects.Object (* Model object, if any. *)
+ END;
+
+ (* Base type of the camera-view gadgets. *)
+ View = POINTER TO ViewDesc;
+ ViewDesc = RECORD ( FrameDesc )
+ absX, absY: INTEGER; (* Absolute screen position at last message forward
+to descendants. *)
+ border: INTEGER; (* Border width for clipping. *)
+
+ (* Install own clipping to display/printer mask here if view has an irregular
+outline. Otherwise set to NIL. *)
+ ClipMask: PROCEDURE (v: View; M: Display3.Mask; ondisplay: BOOLEAN);
+ END;
+
+ (* Calculate a mask for gadget G positioned at X, Y in the context dlink. *)
+ MakeMaskHandler = PROCEDURE (G: Frame; X, Y: INTEGER; dlink: Objects.Object; VAR M: Display3.Mask);
+
+ VAR
+ framehandle: Objects.Handler; (* Default message handler for visual gadgets.
+*)
+ objecthandle: Objects.Handler; (* Default message handler for Model gadgets.
+*)
+ MakeMask: MakeMaskHandler; (* Calculates the current display mask of a visual
+gadget. *)
+ MakePrinterMask: MakeMaskHandler; (* Calculates the current printer mask
+of a visual gadget. *)
+
+ (* The following fields are used for parameter transfer during command execution.
+*)
+ context: Objects.Object; (* Context/parent of a gadget executing the command
+*)
+ executorObj: Objects.Object; (* Gadget executing the command. Same as Oberon.Par.obj.
+*)
+ senderObj: Objects.Object; (* Initiator of a drag and drop operation i.e.
+the gadget being dropped. *)
+ receiverObj: Objects.Object; (* Receiver of a dropped gadget. Often same
+as executorObj. *)
+
+(* Is the context/parent of the frame F locked ? *)
+ PROCEDURE IsLocked (F: Frame; dlink: Objects.Object): BOOLEAN;
+
+(* Is the mouse located inside the work area of a gadget (i.e. excluding the
+control areas)? *)
+ PROCEDURE InActiveArea (F: Frame; VAR M: Oberon.InputMsg): BOOLEAN;
+
+(* Returns the name of of obj. Sends an Objects.AttrMsg behind the scenes. *)
+ PROCEDURE GetObjName (obj: Objects.Object; VAR name: ARRAY OF CHAR);
+
+(* Name object obj. Sends an Objects.AttrMsg behind the scenes. *)
+ PROCEDURE NameObj (obj: Objects.Object; name: ARRAY OF CHAR);
+
+(* Search for the object "O" in the public library "L.Lib" wherename is specified
+as "L.O". *)
+ PROCEDURE FindPublicObj (name: ARRAY OF CHAR): Objects.Object;
+
+(* Search for object named name in context. *)
+ PROCEDURE FindObj (context: Objects.Object; name: ARRAY OF CHAR): Objects.Object;
+
+(* Sets new W and H to (offscreen) frame F. *)
+ PROCEDURE ModifySize (F: Display.Frame; W, H: INTEGER);
+
+(* Inserts the frame f into container F at (u, v). (u, v) is relative to upper
+left corner of F. *)
+ PROCEDURE Consume (F, f: Frame; u, v: INTEGER);
+
+(* Returns a deep or shallow copy of object obj, depending on parameter deep
+*)
+ PROCEDURE Clone (obj: Objects.Object; deep: BOOLEAN): Objects.Object;
+
+(* Check if a message loop would be created should newchild be inserted in the
+container parent. Sends a dummy message behind the scenes. *)
+ PROCEDURE Recursive (parent, newchild: Objects.Object): BOOLEAN;
+
+(* Broadcasts an Gadgets.UpdateMsg should obj be a model gadget, or a Display.DisplayMsg
+if obj is a Display.Frame. *)
+ PROCEDURE Update (obj: Objects.Object);
+
+(* Make a copy of a pointer to an object. A shallow copy returns a reference
+to obj. A deep copy results in M being forwarded to obj. *)
+ PROCEDURE CopyPtr (VAR M: Objects.CopyMsg; obj: Objects.Object): Objects.Object;
+
+(* Copy the record fields belonging to the base gadget type. Copies handle,
+X, Y, W, H, state, attr and obj.*)
+ PROCEDURE CopyFrame (VAR M: Objects.CopyMsg; F, F0: Frame);
+
+(* Copy the record fields belonging to the base Model gadget type. Copies handle
+and attr. *)
+ PROCEDURE CopyObject (VAR M: Objects.CopyMsg; obj, obj0: Object);
+
+(* Default handling of Display.ModifyMsg for visual gadgets. F.mask is invalidated
+when the frame changes its location or size. Sends behind the scenes to F an
+Display.OverlapMsg message to invalidate F.mask. Finally, a Display.DisplayMsg
+is broadcast to update F on the display.*)
+ PROCEDURE Adjust (F: Display.Frame; VAR M: Display.ModifyMsg);
+
+(* Returns the frame that is located at X, Y on the display. U, v return the
+relative coordinates of X, Y inside F. Behind the scenes a Display.LocateMsg
+is broadcast. *)
+ PROCEDURE ThisFrame (X, Y: INTEGER; VAR F: Display.Frame; VAR u, v: INTEGER);
+
+(* Implements standard resize handling for frames. Rubber-bands the gadget size
+and broadcasts a Display.ModifyMsg. *)
+ PROCEDURE SizeFrame (F: Display.Frame; VAR M: Oberon.InputMsg);
+
+(* Implements standard move behaviour for frames. Tracks the gadget outline,
+broadcasts a ConsumeMsg on a copy-over or consume interclick, or broadcast a
+Display.ModifyMsg for a simple move operation. *)
+ PROCEDURE MoveFrame (F: Display.Frame; VAR M: Oberon.InputMsg);
+
+(* Integrate obj at the caret position. A Display.ConsumeMsg is broadcast behind
+the scenes. *)
+ PROCEDURE Integrate (obj: Objects.Object);
+
+(* Write an object POINTER to a file. Lib is the library of the object that
+contains the pointer.*)
+ PROCEDURE WriteRef (VAR r: Files.Rider; lib: Objects.Library; obj: Objects.Object);
+
+(* Read an object POINTER from a file. Lib is the library of the object that
+contains the pointer. Obj might be of type Objects.Dummy if a loading failure
+occured. *)
+ PROCEDURE ReadRef (VAR r: Files.Rider; lib: Objects.Library; VAR obj: Objects.Object);
+
+(* Execute a string as an Oberon command. The parameters executor, dlink, sender,
+receiver are copied to the global variables executorObj, context, senderObj,
+receiverObj respectively. Dlink must be the parent of executor. If a '%' is
+leading the command, no Oberon.Par is set up. *)
+ PROCEDURE Execute (cmd: ARRAY OF CHAR; executor, dlink, sender, receiver: Objects.Object);
+
+(* Forwards a message from a camera-view to its contents, inserting the camera-view
+in the message thread. X, Y is the absolute screen coordinates of the bottom-left
+corner of the camera-view. This is important for calculating the correct display
+mask for the contents of the view. *)
+ PROCEDURE Send (from: View; X, Y: INTEGER; to: Display.Frame; VAR M: Display.FrameMsg);
+
+(* Bind an object to a library. Nothing happens if obj is already bound to a
+public library, or is already bound to lib. This is the default behavior when
+an object received the Objects.BindMsg. *)
+ PROCEDURE BindObj (obj: Objects.Object; lib: Objects.Library);
+
+(* Execute the attribute with name attr of F as an Oberon command. Sends a Objects.AttrMsg
+to retrieve the attribute attr of F. The attributed must be of the string class.
+*)
+ PROCEDURE ExecuteAttr (F: Frame; attr: ARRAY OF CHAR; dlink, sender, receiver: Objects.Object);
+
+(* Standard mouse tracking behavior of visual gadgets. Calls ExecuteAttr for
+the "Cmd" attribute, calls MoveFrame and SizeFrame.*)
+ PROCEDURE TrackFrame (F: Display.Frame; VAR M: Oberon.InputMsg);
+
+(* Look up value of the name alias. Empty string is returned if name is not
+aliased. *)
+ PROCEDURE GetAlias (name: ARRAY OF CHAR; VAR value: ARRAY OF CHAR);
+
+(* Create an object from the generator procedure or alias objname. *)
+ PROCEDURE CreateObject (objname: ARRAY OF CHAR): Objects.Object;
+
+(* Create a View/Model pair from the generator procedures viewnewproc and modelnewproc.
+Aliasing is supported. *)
+ PROCEDURE CreateViewModel (viewnewproc, modelnewproc: ARRAY OF CHAR): Display.Frame;
+
+(* Adds a generator alias. *)
+ PROCEDURE AddAlias (name, value: ARRAY OF CHAR);
+
+(* Command to insert a newly allocated gadget at the caret. Used in the form:
+
+ Gadgets.Insert <generatorproc> ~ for a single object
+ or
+ Gadgets.Insert <viewgeneratorproc> <modelgeneratorproc> ~ for a model-view
+pair
+
+ Aliasing is supported.
+*)
+ PROCEDURE Insert;
+
+(* Returns the latest object selection. Time < 0 indicates no selection. *)
+ PROCEDURE GetSelection (VAR objs: Objects.Object; VAR time: LONGINT);
+
+(* Search for the object "O" in the public library "L.Lib" where the name is
+specified as "L.O" and return a deep copy or shallow copy. *)
+ PROCEDURE CopyPublicObject (name: ARRAY OF CHAR; deep: BOOLEAN): Objects.Object;
+
+(* Changes the selected frame into a new frame type. Used in the form
+
+ Gadgets.Change <generatorproc>
+
+ Aliasing is supported.
+*)
+ PROCEDURE Change;
+
+(* Make a deep copy of the object selection and insert the result at the caret.
+*)
+ PROCEDURE Copy;
+
+(* Change the value(s) of (an) attribute(s) in the object selection. Used in
+the form:
+
+ Gadgets.ChangeAttr <AttributeName> <AttributeValue> ~
+
+ AttributeValue can take several forms, depending on the type of the attribute:
+
+ names For string attributes
+ Yes/No For boolean attributes
+ 1234 For number attributes
+ "strings" For string attributes
+*)
+ PROCEDURE ChangeAttr;
+
+(* Set an attribute value of a named object. Used in the form:
+
+ Gadgets.Set O.A <AttributeValue> ~ for attribute A of named object O in the
+current context
+*)
+ PROCEDURE Set;
+
+(* Create a new Model gadget and link it to all the visual objects in the current
+selection. Used in the form:
+
+ Gadgets.Link <modelgenerator>
+
+ Aliasing is supported. An Objects.LinkMsg is sent behind the scenes.
+*)
+ PROCEDURE Link;
+END Gadgets.
+
+(* Remarks:
+
+1. Objects
+The type Gadgets.Object forms the base class of all model gadgets. Examples
+of these are the Integer, Boolean, Real, String and Complex gadgets.
+
+2. Frames
+The Frame definition is the base type of all displayable gadgets (sometimes
+called views when discussed in relation to the MVC model). The state variable
+(a SET) plays an important role in controlling the gadget frame. It remembers
+state information and controls editing abilities by setting flags. A flag is
+represented by a small integer value (a flag is set if that number is a member
+of the state set). The selected flag indicates if the gadget is selected or
+not. The lockedsize flag prevents resizing of the gadget. The transparent flag
+indicates that a gadget is transparent. It is possible to "see through" parts
+of a transparent gadget to gadgets lying behind it. The lockchildren flag locks
+the direct children of a container gadget. A locked gadget cannot be moved or
+resized. The lockchildren flag is inspected by the IsLocked function and also
+used by the InActiveArea function to determine if a gadget can be moved or resized.
+This flag is normally visible to the outside world through a "Locked" attribute.
+The obj field points to the model of the gadget (if it has one). The mask field
+contains the gadget cached mask. This mask is calculated by the parent of a
+gadget, and transfered from parent to child through the Display3.OverlapMsg.
+During editing operations in the display space, the mask might become invalid
+due to new gadgets overlapping the gadget. In this case, a parent will invalidate
+the mask by setting no (i.e. NIL) mask. This results in the cached mask to be
+set to NIL. However, as soon as a gadget wants to display itself, the MakeMask
+procedure will notice the invalidated mask and request its parent to inform
+it of the correct mask (using Display3.UpdateMaskMsg). The mask is located in
+the fourth quadrant, with the top left corner of the gadget positioned at the
+origin (0, 0) of the mask. Before displaying a visual gadget, the cached mask
+is translated to the correct position on the display. This is done by a call
+to Gadgets.MakeMask.
+
+3. Views
+The View type forms the base of a special class of gadgets called camera-views.
+A camera-view displays other displayable gadgets. Different camera views may
+display the same gadget, where each camera view may display a different part
+of it. The View base type is used to calculate the actual visible area of the
+object being viewed. This operation is hidden behind the secens in Gadgets.MakeMask.
+The absX, absY pair indicate the absolute position of the camera view on the
+display. This is set by the camera view itself when it forwards a message down
+to its model (i.e. the thing it is displaying). The border field indicates how
+wide the border of the camera view is (the border clips away parts of the model).
+ The display mask generation of Gadgets.MakeMask is intimitely coupled with
+the structure of the display space. The remainder of this paragraph is for those
+curious about how mask calculation is done. The display space is organized in
+a DAG-like structure. Messages travel through the DAG, possibly passing to the
+same frame through different messages paths Conceptually, we take the DAG and
+partition it into separate display groups. This is done by removing all the
+edges in the DAG that connect a camera view with its model, and eliminating
+all the non-visual gadgets and their corresponding edges. As no multiple views
+of the same visual gadget through camera views are involved, the mask of each
+gadget in a display group only takes into account the overlapping between gadgets
+in the same display group. These masks remain static, and can be cached for
+each gadget. This is under the assumption that the root object of a display-group
+is completely visible. In practice, display groups corresponds to panels and
+their contents.
+ The display groups are used to determine the visibility of a gadget when it
+calls Gadgets.MakeMask. Using the message thread, all camera-views from the
+root of the display space to the displayed frame are visited. For each of these,
+the camera-view can influence the visibility of its descendants. By intersecting
+the cached mask of a gadget with all of the masks of the camera-views located
+in the message path, we can determine exactly what area of a gadget is visible.
+
+4. UpdateMsg
+The Smalltalk MVC framework is supported with the UpdateMsg. This message must
+always be broadcast to inform everybody of a change of a model gadget. It contains
+a pointer to the object that has changed. All gadgets that have this object
+as a model, has to update themselves. The object that changes need not always
+be a model gadget; it can also be a frame (this indicates that the frame's parent
+should redraw the frame). In the latter case, a whole list of frames may be
+updated (the frames are linked through the slink field). By convention, all
+the frames updated should belong to one single parent.
+
+5. PriorityMsg
+The Priority message allows the changing of the overlapping order of gadgets.
+Each container gadget contains a list of children gadgets, where the position
+in the dsc-next list specifies the overlapping priority (from back to front).
+Changing the position of a child in the list has the affect of moving it to
+the front or the back in the container. When the PriorityMsg is broadcast the
+destination F indicates the child that wants to change its display priority.
+The top, bottom and visible flags are used to move the child to the front, to
+the back or to make it visible when not. The visible flag has the affect of
+moving the child to the front only when it is overlapped by a sibling. Otherwise,
+no action is undertaken. The passon flag indicates if the priority change should
+be recursive, meaning that the parent of F and onwards should also change priority,
+and thus bring a whole hierarchy to the front or back.
+
+6. Default message handlers
+To simplify programming, default handlers for model and visual gadgets are provided.
+These may be called to handle messages a default way. The default frame handler
+(framehandle) responds to the Objects.FileMsg (storing/loading X, Y, W, H, state,
+obj and attr), Objects.CopyMsg (calls CopyFrame), BindMsg (calls BindObj), Objects.AttrMsg,
+Objects.FindMsg (returning itself or the model), Display.DisplayMsg (simply
+draws rectangle), Display3.OverlapMsg, Display.LocateMsg, Display.ModifyMsg
+(calls Adjust), Display.SelectMsg (only flips the selected flag), Display.ConsumeMsg
+(executes the ConsumeCmd attribute if the gadget has one), Display.ControlMsg
+(forwards it to the gadgets model), and Oberon.InputMsg (calling TrackFrame
+on a mouse track event). The default model gadget handler (objecthandle) respond
+to the Objects.FileMsg (storing/loading attr), Objects.AttrMsg, Objects.BindMsg
+(calls BindObj), Objects.CopyMsg (calling CopyObject), and Objects.FindMsg (returning
+the model if the names match).
+
+7. The Imaging Model
+Two important relationships exist between gadgets: the view relationship and
+parent-child relationship. A panel may display several gadgets contained inside
+of it. This is the parent-child relationship, where the children are displayed
+and managed by the parent. The parent does not assume anything about the type
+of its children, and the children do not assume to be contained in an object
+of a specified type. This allows a gadget to be integrated in all environments,
+and for parents to manage children that are unknown to it. This is the principle
+of complete integration and plays a central role in the gadgets system.
+ The view relationship allows one gadget to display or view another gadget.
+The first (the viewer) may either visualize the state of the viewed gadget (for
+example, a slider representing an integer value), or display the viewed gadget.
+In the first case, a model is viewed, while in the latter, a displayable object
+is viewed (a camera-view). Models form the interface to the application, and
+displayable models allow the same gadget to be displayed many times on the display.
+Many different views of the same object (model or displayable) may be possible,
+where each view can visualize the viewed object in a different manner. Views
+may be nested to an arbitrary depth, as long as no recursive views are created.
+Messages travel through the system informing views that a model has changed.
+These Update messages indicate the model involved, which the views may check
+to find out if it needs to redisplay or recalculate itself. The model-view framework
+is open; it is also possible for one model gadget to be dependent on another
+model gadget.You may have different representations of the same data, allow
+objects to depend on others, and allow data or objects to be shared between
+different documents.
+ It is this flexible model-view framework combined with the ability to have
+gadgets overlapping each other and edited-in-place, that complicates the imaging
+model. A displayable gadget may be partially visible through one camera-view,
+and partially visible through another. The same object, can be seen and edited
+two or more times on different areas of the display. Also, some of these camera-views
+may be partially overlapped by other displayable gadgets. The problem is compounded
+when camera-views are nested inside camera-views, increasing the number of display
+instances. Thus a gadget may potentially have to display itself in many different
+ways. Clearly, with a single displayable gadget having so many different display
+instances (one for each view, in the simplest case), the gadget cannot have
+one unique display coordinate. The gadgets system uses relative coordinates,
+where the coordinate of a gadget is always relative to its parent. All displayable
+frame are connected to a data structure called the display root. Broadcasting
+a message through the display space causes all displayable objects in the structure
+to be reached. If we assume that views relay the message to the objects they
+display, the display space forms a directed a-cyclic graph (DAG). There are
+certain objects where two or more message paths converges. Such a convergence
+point can occur when two or more camera-views display the same object. Thus
+during a single message broadcast, the message may arrive twice or more times
+at the same object. If this object is displayable, it receives the message exactly
+once for each of its display instances. For each of these message arrivals,
+the gadget should have different coordinates on the display.
+ In practice, the coordinates of a gadget is determined by the path the message
+follows to reach that gadget. Each message relay operation may change the coordinate
+system. This is reflected in the origin stored in the message. The display coordinates
+of a display instance of a gadget is thus the combination of the current origin
+(in the message) and the relative coordinates of the gadget itself. A gadget
+can be prompted into displaying itself on many different locations on the display
+by varying the origin of the message. This is called the multiple view model
+of the gadgets system.
+ The main disadvantage of the multiple view model is that potentially each display
+instance of a frame may have a different visible area. Theoretically, the visible
+area of a display instance is a function of the message path to that instance.
+A data structure is used to indicate what part of a gadget is visible. Such
+a data structure is called a display mask. The mask can be constructed as the
+message travels through the display space, continually being reduced and expanded
+as the message travels. It consists of a set of non-overlapping rectangles which
+indicate which areas of the gadget are visible. Drawing primitives are issued
+through this mask, which has the effect of clipping them only to the visible
+areas in the mask. Operations on masks are also provided. You can, for example,
+calculate the intersection or union between masks, or enumerate all the visible
+areas in a mask.
+ Implementing the sketched procedure is inefficient. Masks may be calculated
+that are not used at all (not all broadcasts are display related). Also, masks
+should be cached for each display instance, rather being recalculated each time.
+In practice, a imaging model is used that is based on these observations. The
+following remarks give an idea of how things have actually been implemented.
+
+8. Masks
+Each gadget has a mask that shows which areas of it are visible. The mask field
+can be set to NIL, to indicates that no mask exists. A gadget can only be displayed
+once it becomes a mask. Should no mask exist, the Display3.UpdateMaskMsg is
+broadcast, with F set the maskless gadget. The parent of F is responsible for
+creating a new mask for F. The Display3.OverlapMsg is used to inform the gadget
+of its new mask. It is sent directly from the parent to the gadget (the above
+protocol is explained in the section about the Display3 module).
+ The mask generation is hidden from gadget programmers. When displaying a gadget,
+the mask's relative coordinates have to be converted into absolute screen coordinates,
+or possibly even a new mask created (as described above). The whole process
+is hidden behind the procedures MakeMask and MakePrinterMask. G is the frame
+for which a mask is needed, X and Y indicate the absolute screen position of
+the left-bottom corner of G, and dlink is the context of G. The context of G
+can be found in the dlink field of the received frame message. The MakePrinterMask
+procedure variable functions in the same way, except that a mask for the printer
+is created. For the latter X, Y should be the absolute printer coordinates of
+the gadget. The resulting masks are return in variable parameter M, and can
+immediately be used for displaying or printing the gadget.
+
+9. Mask Calculations
+ Masks are calculated from the intersection of the cached mask of a gadget and
+all the camera-views through which a message travels. We need a backward traversal
+from the gadget through all the display groups. On receiving a frame message,
+the dlink field in the message points to the first frame in the message thread.
+The list can be traversed further backwards with the dlink field of the frame.
+The backward traversal can continue by following the dlink fields through all
+frames in the thread. Thus when masks are generated one should distinguish between
+normal frames and camera-views, as we are only interested in camera-views when
+generating masks. Broadcast messages travel from one display group to another
+(through views) to reach a gadget. Thus the actual visible area of a gadget
+is the intersection of its static/cached mask plus all the masks of views through
+which the message travelled. This calculation only need to be made on demand.
+For example, when a gadget decides to display itself, it calls MakeMask to build
+it's visibility mask. MakeMask has to find out the path the message traveled
+to reach the gadget, extract all the camera-views, and build the intersection
+of the static mask plus all the masks of the views. This can be done by following
+the message path back from the receiver gadget to the root of the display.
+ Typically we don't want to modify the static mask of a gadget. However, this
+mask will be changed by the intersection process during mask calculation. Observations
+shows that the masks of views are mostly rectangular, i.e they are seldomly
+partially overlapped. If we assume that this is always the case, the mask calculation
+is nothing more than reducing the static mask by rectangular areas (clipping
+windows or ports). For this situation, the mask is provided with a rectangular
+clipping port, to which all output primitives are clipped after they have been
+clipped by the mask itself. The simple structure of the clipping port means
+that it can easily be saved, modified and restored, without affecting the static
+portion of the mask. Of course, the latter condition fails when the views are
+also partially obscured. In this case, the mask calculation has to be done in
+the less efficient way.
+
+10. Command Execution
+Gadgets may execute Oberon commands (procedures Execute and ExecuteAttr) specified
+by their command attributes. Commands can take their parameters from the user
+interface. For this purpose, several global variables are exported from the
+gadgets module. The variable context identifies the context, normally the parent,
+of the gadget executing the command. The context of a gadget is found in the
+dlink field of a Display.FrameMsg the gadget receives. The variable executorObj
+identifies the gadget executing the command, which is always the same as Oberon.Par.obj.
+The senderObj and receiverObj identifies the objects involved in consume operations,
+and may be NIL.
+
+11. Aliasing
+The Gadgets module implements a simple aliasing feature. This allows the user
+to give more meaningful abbreviations or names to the not so easy to remember
+object generator procedures. The principle client of aliasing are the Gadgets.Insert
+and Gadgets.Link commands. The aliases are found in the Oberon.Text/Registry
+section called Aliases. The aliases are read into an internal lookup table when
+the Gadgets module is loaded for the first time. The format of each line of
+the Aliases section is:
+
+ Alias=GeneratorProc
+
+*)
diff --git a/examples/AGRS/Grammars.Mod b/examples/AGRS/Grammars.Mod
new file mode 100644
index 0000000..6452b33
--- /dev/null
+++ b/examples/AGRS/Grammars.Mod
@@ -0,0 +1,711 @@
+MODULE Grammars;
+IMPORT AGRS, Names, Library, Parser, Texts;
+
+CONST
+ SetBits= MAX(SET)+1;
+ MaxStrLength*= 30;
+TYPE
+ ParserProc= PROCEDURE;
+ ParserTerm= POINTER TO RECORD(AGRS.TermDesc)
+ handler: ParserProc;
+ END;
+ BuilderTerm= POINTER TO RECORD(AGRS.TermDesc)
+ property: AGRS.Name;
+ END;
+ GenericBuilderTerm= POINTER TO RECORD(AGRS.TermDesc)
+ END;
+ SetLimitTerm= POINTER TO RECORD(AGRS.TermDesc)
+ limit: LONGINT;
+ END;
+ ReaderProc= PROCEDURE(VAR in: CHAR);
+VAR
+ Read*: ReaderProc;
+ BackSpace*: PROCEDURE;
+ input: Texts.Reader;
+ inputString: Names.CharPtr;
+ inputText: Texts.Text;
+ position,limit: LONGINT;
+ EmptyMarker: AGRS.Atomic;
+ spaceChars,idChars: Library.CharSet;
+ i: INTEGER;
+ temp: AGRS.SubTerm;
+ tempDis: AGRS.Disjunction;
+ disjunctionBuilder,continuationBuilder: AGRS.SystemTerm;
+ fieldBuilder,blockBuilder: AGRS.SystemTerm;
+ nameToTreeBuilder: AGRS.SystemTerm;
+ localConsName,classConsName: AGRS.Name;
+ grammarName*,followName: AGRS.Name;
+ treeName*,propertyName*,valueName*,rootName*: AGRS.Name;
+ sentenceName*,genericRootName,emptyName: AGRS.Name;
+ spaceCharsName,idCharsName: AGRS.Name;
+ genericAttrName*,disjunctionName*,continuationName*: AGRS.Name;
+ fieldName*,blockName*: AGRS.Name;
+ optionName*: AGRS.Name;
+ terminalName*,attrName*,constructName*,parseEndName: AGRS.Name;
+ parseName*,defaultGrammarName: AGRS.Name;
+ charParser*,stringParser*: AGRS.Name;
+ charTerminalParser*,stringTerminalParser*: AGRS.Name;
+ spaceParser,nameParser*,idParser*,recurrenceParser: AGRS.Name;
+
+PROCEDURE ReadFile(VAR ch: CHAR);
+BEGIN
+ REPEAT
+ Texts.Read(input, ch);
+ INC(position);
+ UNTIL input.elem=NIL;
+END ReadFile;
+
+PROCEDURE ReadString(VAR ch: CHAR);
+BEGIN
+ ch:= inputString[position];
+ INC(position);
+END ReadString;
+
+PROCEDURE BackSpaceFile;
+BEGIN
+ DEC(position);
+ Texts.OpenReader(input,inputText,position);
+END BackSpaceFile;
+
+PROCEDURE BackSpaceString;
+BEGIN
+ DEC(position);
+END BackSpaceString;
+
+PROCEDURE SkipSpaces;
+VAR
+ ch: CHAR;
+ spaces: AGRS.Term;
+BEGIN
+ spaces:= spaceCharsName.Value();
+ WITH spaces: Library.CharSet DO
+ REPEAT
+ Read(ch);
+ UNTIL ~(ORD(ch) MOD SetBits IN
+ spaces.value[ORD(ch) DIV SetBits]) OR (position>limit);
+ BackSpace;
+ END;
+END SkipSpaces;
+
+PROCEDURE pSkipSpaces;
+BEGIN
+ SkipSpaces;
+ AGRS.Continue;
+END pSkipSpaces;
+
+PROCEDURE ParseConstruct;
+VAR
+ expect,skeleton: AGRS.Term;
+ newTerm: AGRS.Tree;
+BEGIN
+ expect:= treeName.indirection;
+ skeleton:= rootName.indirection;
+ IF expect=AGRS.Variable THEN
+ NEW(newTerm);
+ WITH skeleton: AGRS.Tree DO
+ newTerm^:= skeleton^;
+ ELSE
+ newTerm.Init(skeleton.indirection);
+ END;
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore;
+ ELSIF AGRS.Equal(expect,skeleton) THEN
+ AGRS.Continue;
+ ELSE
+ AGRS.Fail;
+ END;
+END ParseConstruct;
+
+PROCEDURE ParseGenericSkeleton(builder: AGRS.Term; check: BOOLEAN);
+VAR
+ skeleton: AGRS.Class;
+BEGIN
+ IF check & (treeName.indirection#AGRS.Variable) THEN
+ AGRS.Fail;
+ RETURN
+ END;
+ AGRS.Push(builder);
+ AGRS.Push(treeName);
+ NEW(skeleton);
+ skeleton.Init(genericRootName);
+ treeName.Assign(skeleton);
+ grammarName.Reduce;
+ treeName.Restore;
+END ParseGenericSkeleton;
+
+PROCEDURE ParseDisjunctConstruct;
+BEGIN
+ ParseGenericSkeleton(disjunctionBuilder,TRUE);
+END ParseDisjunctConstruct;
+
+PROCEDURE ParseContinueConstruct;
+BEGIN
+ ParseGenericSkeleton(continuationBuilder,TRUE);
+END ParseContinueConstruct;
+
+PROCEDURE ParseFieldConstruct;
+BEGIN
+ ParseGenericSkeleton(fieldBuilder,TRUE);
+END ParseFieldConstruct;
+
+PROCEDURE ParseBlockConstruct;
+BEGIN
+ Names.LocalBlock;
+ ParseGenericSkeleton(blockBuilder,TRUE);
+ Names.EndBlock;
+END ParseBlockConstruct;
+
+PROCEDURE ParseGenericAttribute;
+VAR
+ builder: GenericBuilderTerm;
+BEGIN
+ NEW(builder);
+ builder.Init(treeName.indirection);
+ ParseGenericSkeleton(builder,FALSE);
+END ParseGenericAttribute;
+
+PROCEDURE LocalConstruct;
+VAR
+ newTerm: AGRS.Block;
+BEGIN
+ IF treeName.indirection IS AGRS.Tree THEN
+ NEW(newTerm);
+ newTerm.Init(treeName.indirection.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore();
+ ELSE
+ AGRS.Fail;
+ END;
+END LocalConstruct;
+
+PROCEDURE ClassConstruct;
+VAR
+ newTerm: AGRS.Class;
+BEGIN
+ IF treeName.indirection IS AGRS.Tree THEN
+ NEW(newTerm);
+ newTerm.Init(treeName.indirection.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore();
+ ELSE
+ AGRS.Fail;
+ END;
+END ClassConstruct;
+
+PROCEDURE ParseAttribute;
+VAR
+ prop,val: AGRS.Term;
+ root: AGRS.Name;
+ builder: BuilderTerm;
+BEGIN
+ prop:= propertyName.indirection;
+ IF ~(prop IS AGRS.Name) THEN
+ prop:= prop.indirection;
+ END;
+ WITH prop: AGRS.Name DO
+ root:= treeName.indirection.indirection(AGRS.Name);
+ root.Assign(AGRS.Variable);
+ prop.Assign(EmptyMarker);
+ val:= treeName.Evaluate(prop);
+ prop.Restore;
+ root.Restore;
+ IF val=EmptyMarker THEN
+ val:= AGRS.Variable;
+ END;
+ NEW(builder);
+ builder.Init(treeName.indirection);
+ builder.property:= prop;
+ AGRS.Push(builder);
+ treeName.Assign(val);
+ grammarName.Reduce;
+ treeName.Restore;
+ END;
+END ParseAttribute;
+
+PROCEDURE ParseTerminal;
+VAR
+ val: AGRS.Term;
+ builder: BuilderTerm;
+BEGIN
+ NEW(builder);
+ builder.Init(treeName.indirection);
+ builder.property:= NIL;
+ AGRS.Push(builder);
+ grammarName.Reduce;
+END ParseTerminal;
+
+PROCEDURE ParseCharTerminal;
+VAR
+ chRead: CHAR;
+ chTerm: AGRS.Term;
+BEGIN
+ Read(chRead);
+ chTerm:= grammarName.Value();
+ IF chRead=chTerm(Library.Character).value THEN
+ AGRS.Continue;
+ ELSE
+ AGRS.Fail;
+ END;
+END ParseCharTerminal;
+
+PROCEDURE ParseChar;
+VAR
+ chRead: CHAR;
+ chTerm: Library.Character;
+BEGIN
+ Read(chRead);
+ chTerm:= Library.NewChar(chRead);
+ AGRS.Unify(treeName,chTerm);
+END ParseChar;
+
+PROCEDURE ParseTheStringPrim(termExpect: AGRS.Term);
+VAR
+ strExpect: Names.CharPtr;
+ chRead: CHAR;
+ i: INTEGER;
+BEGIN
+ IF ~(termExpect IS Library.String) THEN
+ AGRS.Fail;
+ RETURN
+ END;
+ strExpect:= termExpect(Library.String).value;
+ i:= 0;
+ WHILE (i<LEN(strExpect^)) & (strExpect[i]#0X) DO
+ Read(chRead);
+ IF strExpect[i]#chRead THEN
+ AGRS.Fail;
+ RETURN
+ END;
+ INC(i);
+ END;
+ IF strExpect[i]=0X THEN
+ AGRS.Continue;
+ ELSE
+ AGRS.Fail;
+ END;
+END ParseTheStringPrim;
+
+PROCEDURE ParseTheString;
+BEGIN
+ ParseTheStringPrim(treeName.Value());
+END ParseTheString;
+
+PROCEDURE ParseStringTerminal;
+BEGIN
+ ParseTheStringPrim(grammarName.Value());
+END ParseStringTerminal;
+
+PROCEDURE ParseIdentifier;
+VAR
+ wd: AGRS.Name;
+ str: ARRAY MaxStrLength OF CHAR;
+ ch: CHAR;
+ i: INTEGER;
+ termExpect: AGRS.Term;
+BEGIN
+ i:= 0;
+ REPEAT
+ Read(ch);
+ str[i]:= ch;
+ INC(i);
+ UNTIL ~(ORD(ch) MOD SetBits IN
+ idChars.value[ORD(ch) DIV SetBits]);
+ IF i=1 THEN
+ AGRS.Fail;
+ RETURN
+ END;
+ BackSpace;
+ str[i-1]:= 0X;
+ wd:= Names.FindPublicName(str);
+
+ termExpect:= treeName.indirection;
+ IF termExpect IS AGRS.Tree THEN
+ termExpect:= termExpect.indirection;
+ END;
+ IF termExpect=wd THEN
+ AGRS.Continue;
+ ELSIF (termExpect=AGRS.Variable) OR
+ (termExpect=AGRS.Undefined) THEN
+ IF wd=NIL THEN
+ Names.AddArgument(wd,str);
+ treeName.Assign(wd);
+ AGRS.Continue;
+ ELSE
+ treeName.Assign(wd);
+(* wd.Assign(AGRS.Undefined); *)
+ AGRS.Continue;
+(* wd.Restore; *)
+ END;
+ treeName.Restore;
+ ELSE
+ AGRS.Fail;
+ END;
+END ParseIdentifier;
+
+PROCEDURE NameToTree;
+VAR
+ newTerm: AGRS.Tree;
+BEGIN
+ IF treeName.indirection IS AGRS.Name THEN
+ NEW(newTerm);
+ newTerm.Init(treeName.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore;
+ ELSE
+ AGRS.Continue;
+ END;
+END NameToTree;
+
+PROCEDURE (t: BuilderTerm) Reduce*;
+VAR
+ newTerm: AGRS.Tree;
+ newTerm2: AGRS.Class;
+ newTerm3: AGRS.Block;
+BEGIN
+(*
+ IF treeName.indirection=AGRS.Variable THEN
+ AGRS.Fail;
+ RETURN
+ END;
+*)
+ IF t.property=NIL THEN
+ treeName.Assign(t.indirection);
+ ELSE
+ IF t.indirection IS AGRS.Tree THEN
+ IF t.indirection IS AGRS.Class THEN
+ NEW(newTerm2);
+ newTerm2^:= t.indirection(AGRS.Class)^;
+ newTerm:= newTerm2;
+ ELSIF t.indirection IS AGRS.Block THEN
+ NEW(newTerm3);
+ newTerm3^:= t.indirection(AGRS.Block)^;
+ newTerm:= newTerm3;
+ ELSE
+ NEW(newTerm);
+ newTerm^:= t.indirection(AGRS.Tree)^;
+ END;
+ ELSE
+ ASSERT(t.indirection IS AGRS.Name);
+ newTerm.Init(t.indirection);
+ END;
+ newTerm.AddProperty(t.property,treeName.indirection);
+ treeName.Assign(newTerm);
+ END;
+ AGRS.Continue;
+ treeName.Restore;
+END Reduce;
+
+PROCEDURE (t: GenericBuilderTerm) Reduce*;
+VAR
+ newTerm: AGRS.Tree;
+ newTerm2: AGRS.Class;
+ newTerm3: AGRS.Block;
+ prop: AGRS.Term;
+BEGIN
+ NEW(newTerm);
+ IF t.indirection IS AGRS.Tree THEN
+ IF t.indirection IS AGRS.Class THEN
+ NEW(newTerm2);
+ newTerm2^:= t.indirection(AGRS.Class)^;
+ newTerm:= newTerm2;
+ ELSIF t.indirection IS AGRS.Block THEN
+ NEW(newTerm3);
+ newTerm3^:= t.indirection(AGRS.Block)^;
+ newTerm:= newTerm3;
+ ELSE
+ NEW(newTerm);
+ newTerm^:= t.indirection(AGRS.Tree)^;
+ END;
+ ELSE
+ ASSERT(t.indirection IS AGRS.Name);
+ newTerm.Init(t.indirection);
+ END;
+ prop:= propertyName.indirection;
+ IF ~(prop IS AGRS.Name) THEN
+ prop:= prop.indirection;
+ END;
+ newTerm.AddProperty(prop(AGRS.Name),valueName.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore;
+END Reduce;
+
+PROCEDURE BuildDisjunction;
+VAR
+ newTerm: AGRS.Disjunction;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(Library.argName1.indirection);
+ newTerm.InitAlternative(Library.argName2.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore;
+END BuildDisjunction;
+
+PROCEDURE BuildContinuation;
+VAR
+ newTerm: AGRS.SubTerm;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(Library.argName1.indirection);
+ newTerm.InitQuery(Library.argName2.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore;
+END BuildContinuation;
+
+PROCEDURE BuildField;
+VAR
+ newTerm: AGRS.Field;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(Library.argName1.indirection);
+ newTerm.InitQuery(Library.argName2.indirection);
+ treeName.Assign(newTerm);
+ AGRS.Continue;
+ treeName.Restore;
+END BuildField;
+
+PROCEDURE BuildBlock;
+VAR
+ newTerm: AGRS.Term;
+BEGIN
+ newTerm:= treeName.indirection;
+ newTerm(AGRS.Tree).RemoveProperty(rootName);
+ treeName.Assign(AGRS.MakeLocalBlock(newTerm,rootName.indirection));
+ AGRS.Continue;
+ treeName.Restore;
+END BuildBlock;
+
+PROCEDURE (t: SetLimitTerm) Reduce*;
+VAR
+ oldLimit: LONGINT;
+BEGIN
+ oldLimit:= limit;
+ limit:= t.limit;
+ t.indirection.Reduce;
+ limit:= oldLimit;
+END Reduce;
+
+PROCEDURE ParseRecurrence;
+VAR
+ oldLimit: LONGINT;
+ seeker: Texts.Reader;
+ expect: AGRS.Term;
+ chExpect,chRead: CHAR;
+ newTerm: AGRS.Tree;
+ restoreTerm: SetLimitTerm;
+BEGIN
+ oldLimit:= limit;
+ NEW(newTerm);
+ expect:= followName.Value();
+ IF expect IS Library.Character THEN
+ chExpect:= expect(Library.Character).value;
+ newTerm.Init(charTerminalParser);
+ ELSE
+ chExpect:= expect(Library.String).value[0];
+ newTerm.Init(stringTerminalParser);
+ END;
+ IF inputString=NIL THEN
+ REPEAT
+ DEC(limit);
+ Texts.OpenReader(seeker,inputText,limit);
+ Texts.Read(seeker,chRead);
+ UNTIL (chRead=chExpect) OR (limit<=position);
+ ELSE
+ REPEAT
+ DEC(limit);
+ chRead:= inputString[limit];
+ UNTIL (chRead=chExpect) OR (limit<=position);
+ END;
+ IF chRead=chExpect THEN
+ newTerm.AddProperty(grammarName,expect);
+ NEW(restoreTerm);
+ restoreTerm.Init(newTerm);
+ restoreTerm.limit:= oldLimit;
+ AGRS.Push(restoreTerm);
+ grammarName.Reduce;
+ ELSE
+ AGRS.Fail;
+ END;
+ limit:= oldLimit;
+END ParseRecurrence;
+
+PROCEDURE (t: ParserTerm) Reduce*;
+VAR
+ oldPos: LONGINT;
+ ch: CHAR;
+ spaces: AGRS.Term;
+BEGIN
+ oldPos:= position;
+ spaces:= spaceCharsName.Value();
+ WITH spaces: Library.CharSet DO
+ REPEAT
+ Read(ch);
+ UNTIL ~(ORD(ch) MOD SetBits IN
+ spaces.value[ORD(ch) DIV SetBits])
+ OR (position>limit);
+ BackSpace;
+ END;
+ t.handler;
+ position:= oldPos;
+ IF inputString=NIL THEN
+ Texts.OpenReader(input,inputText,oldPos);
+ END;
+END Reduce;
+
+
+PROCEDURE pParse;
+VAR
+ txt,r: AGRS.Term;
+BEGIN
+ txt:= sentenceName.Value();
+ WITH txt: Library.Text DO
+ inputText:= txt.base;
+ inputString:= NIL;
+ position:= txt.startOffset;
+ Texts.OpenReader(input,txt.base,txt.startOffset);
+ limit:= txt.endOffset;
+ Read:= ReadFile;
+ BackSpace:= BackSpaceFile;
+ ELSE
+ WITH txt: Library.String DO
+ position:= 0;
+ inputString:= txt.value;
+ limit:= txt.Length();
+ Read:= ReadString;
+ BackSpace:= BackSpaceString;
+ END;
+ END;
+ treeName.Assign(AGRS.Variable);
+ r:= grammarName.Evaluate(parseEndName);
+ treeName.Restore;
+ IF r.indirection#AGRS.failName THEN
+ IF ~AGRS.Continued() THEN
+ AGRS.result:= r.indirection;
+ END;
+ RETURN
+ END;
+ r:= Library.NewError(Library.SyntaxError);
+ r.Reduce;
+END pParse;
+
+PROCEDURE ExtractTree;
+VAR
+ newTerm: AGRS.Term;
+BEGIN
+ SkipSpaces;
+ IF position<limit THEN
+ AGRS.Fail;
+ ELSE
+ AGRS.Continue;
+ NEW(newTerm);
+ newTerm.Init(treeName.indirection);
+ AGRS.result:= newTerm;
+ END;
+END ExtractTree;
+
+PROCEDURE ParseByDefault;
+VAR
+ r: AGRS.Term;
+BEGIN
+ Parser.sentenceName.Assign(sentenceName.indirection);
+ r:= Parser.parseName.Value();
+ Parser.sentenceName.Restore;
+ treeName.Assign(r);
+ AGRS.Continue;
+ treeName.Restore;
+END ParseByDefault;
+
+PROCEDURE DefineParser*(VAR parserName: AGRS.Name;
+ spelling: ARRAY OF CHAR; handlerProc: ParserProc);
+VAR
+ parser: ParserTerm;
+BEGIN
+ NEW(parser);
+ parser.Init(Names.SystemRoot);
+ parser.handler:= handlerProc;
+ Names.DefinePublicName(parserName,spelling,parser);
+END DefineParser;
+
+BEGIN
+ Names.AddArgument(rootName, 'Root');
+ Names.AddArgument(treeName, 'Tree');
+ Names.AddArgument(propertyName, 'Property');
+ Names.AddArgument(grammarName, 'Grammar');
+ Names.AddArgument(followName, 'Follow');
+ Names.AddArgument(genericRootName, 'GenericRoot');
+ Names.AddArgument(valueName, 'Value');
+ Names.AddArgument(sentenceName, 'TextSentence');
+ Names.AddSystemName(emptyName,'Empty',AGRS.AtomicHandler);
+ Names.AddSystemName(defaultGrammarName,'DefaultGrammar',ParseByDefault);
+ grammarName.Init(defaultGrammarName);
+ Names.AddSystemName(attrName,'Attr',ParseAttribute);
+ Names.AddSystemName(genericAttrName,'Attribute',ParseGenericAttribute);
+ Names.AddSystemName(constructName,'Construct',ParseConstruct);
+ Names.AddSystemName(disjunctionName,'Disjunction',
+ ParseDisjunctConstruct);
+ Names.AddSystemName(continuationName,'Continuation',
+ ParseContinueConstruct);
+ Names.AddSystemName(fieldName,'FieldConstruct',ParseFieldConstruct);
+ Names.AddSystemName(blockName,'BlockConstruct',ParseBlockConstruct);
+ Names.AddSystemName(localConsName,'LocalConstruct',LocalConstruct);
+ Names.AddSystemName(classConsName,'ClassConstruct',ClassConstruct);
+ Names.AddSystemName(parseEndName,'ParseEnding',ExtractTree);
+ Names.AddSystemName(terminalName,'Terminal',ParseTerminal);
+ NEW(EmptyMarker);
+ EmptyMarker.Init(emptyName);
+ DefineParser(charParser,'CharGrammar',ParseChar);
+ DefineParser(stringParser,'StringGrammar',ParseTheString);
+ DefineParser(charTerminalParser,'CharTerminal',ParseCharTerminal);
+ DefineParser(stringTerminalParser,'StringTerminal',ParseStringTerminal);
+ DefineParser(nameParser,'NameGrammar',ParseIdentifier);
+ DefineParser(spaceParser,'SpaceGrammar',pSkipSpaces);
+ DefineParser(recurrenceParser,'Recurrence',ParseRecurrence);
+ Names.AddSystemName(parseName,'GrammarParser',pParse);
+ NEW(disjunctionBuilder);
+ disjunctionBuilder.Init(Names.SystemRoot);
+ disjunctionBuilder.InitHandler(BuildDisjunction);
+ NEW(continuationBuilder);
+ continuationBuilder.Init(Names.SystemRoot);
+ continuationBuilder.InitHandler(BuildContinuation);
+ NEW(fieldBuilder);
+ fieldBuilder.Init(Names.SystemRoot);
+ fieldBuilder.InitHandler(BuildField);
+ NEW(blockBuilder);
+ blockBuilder.Init(Names.SystemRoot);
+ blockBuilder.InitHandler(BuildBlock);
+ NEW(nameToTreeBuilder);
+ nameToTreeBuilder.Init(Names.SystemRoot);
+ nameToTreeBuilder.InitHandler(NameToTree);
+ NEW(temp);
+ temp.Init(nameParser);
+ temp.InitQuery(nameToTreeBuilder);
+ Names.DefinePublicName(idParser,'IdentifierGrammar',temp);
+ NEW(tempDis);
+ tempDis.Init(grammarName);
+ tempDis.InitAlternative(AGRS.Undefined);
+ Names.DefinePublicName(optionName,'Option',tempDis);
+ spaceChars:= Library.NewCharSet();
+ spaceChars.Include(' ');
+ spaceChars.Include(0X);
+ spaceChars.Include(9X);
+ spaceChars.Include(0AX);
+ spaceChars.Include(0DX);
+ Names.DefinePublicName(spaceCharsName,'SpaceChars',spaceChars);
+ idChars:= Library.NewCharSet();
+ FOR i:= ORD('a') TO ORD('z') DO
+ idChars.Include(CHR(i));
+ idChars.Include(CAP(CHR(i)));
+ END;
+ FOR i:= ORD('0') TO ORD('9') DO
+ idChars.Include(CHR(i));
+ END;
+ idChars.Include('_');
+ Names.DefinePublicName(idCharsName,'IdentifierChars',idChars);
+END Grammars.
+
diff --git a/examples/AGRS/Library.Mod b/examples/AGRS/Library.Mod
new file mode 100644
index 0000000..fc3fc88
--- /dev/null
+++ b/examples/AGRS/Library.Mod
@@ -0,0 +1,677 @@
+MODULE Library;
+IMPORT AGRS,Names,Texts,TextFrames;
+
+
+CONST
+ (* Kodovi gresaka koji su sadrzani u tipu podataka Error. *)
+ NotLogicalType*= 0;
+ NotNumberType*= 1;
+ NotCharacterType*= 2;
+ NotStringType*= 3;
+ NotTextType*= 4;
+ NotFound*= 5;
+ SyntaxError*= 6;
+
+ CharSetLength= 256 DIV (MAX(SET)+1);
+
+TYPE
+ Term= AGRS.Term;
+ ErrorType= INTEGER;
+
+ NamesType= POINTER TO RECORD(AGRS.ClosedClassDesc)
+ END;
+
+ Number*= POINTER TO RECORD(AGRS.AtomicDesc)
+ value*: INTEGER;
+ END;
+
+ String*= POINTER TO RECORD(AGRS.AtomicDesc)
+ value-: Names.CharPtr;
+ END;
+
+ Text*= POINTER TO RECORD(AGRS.AtomicDesc)
+ base-: Texts.Text;
+ startOffset-,endOffset-: LONGINT;
+ END;
+
+ Character*= POINTER TO RECORD(AGRS.AtomicDesc)
+ value-: CHAR;
+ END;
+
+ CharSet*= POINTER TO RECORD( AGRS.AtomicDesc)
+ value-: ARRAY CharSetLength OF SET;
+ END;
+
+ Error*= POINTER TO RECORD(AGRS.AtomicDesc)
+ value-: ErrorType;
+ END;
+
+ BinOp= POINTER TO RECORD(AGRS.TermDesc)
+ END;
+VAR
+ TrueDef: Term;
+
+ disTerm: AGRS.Disjunction;
+ NamesTerm: NamesType;
+
+ atomicName,numberName*,errorName*: AGRS.Name;
+ charName*,stringName*,textName*,charSetName*: AGRS.Name;
+ ifName,orName,andName,notName,testName,yesName,noName: AGRS.Name;
+ addName*,subName*,mulName*,divName,modName: AGRS.Name;
+ argName1*,argName2*: AGRS.Name;
+ equalName,lessName,greaterName,lessEqName,grEqName: AGRS.Name;
+ trueName*,disName,unifyName: AGRS.Name;
+ abortName*,findName,nameName: AGRS.Name;
+ carName,cdrName,consName,nilName: AGRS.Name;
+ namesName: AGRS.Name;
+
+
+
+PROCEDURE NewNumber*(v: INTEGER): Number;
+VAR
+ result: Number;
+BEGIN
+ NEW(result);
+ result.Init(numberName);
+ result.value:= v;
+ AGRS.eldestAsked:= AGRS.Fixed;
+ RETURN result;
+END NewNumber;
+
+PROCEDURE NewString*(v: Names.CharPtr): String;
+VAR
+ result: String;
+BEGIN
+ NEW(result);
+ result.Init(stringName);
+ result.value:= v;
+ AGRS.eldestAsked:= AGRS.Fixed;
+ RETURN result;
+END NewString;
+
+PROCEDURE NewChar*(v: CHAR): Character;
+VAR
+ result: Character;
+BEGIN
+ NEW(result);
+ result.Init(charName);
+ result.value:= v;
+ AGRS.eldestAsked:= AGRS.Fixed;
+ RETURN result;
+END NewChar;
+
+PROCEDURE NewCharSet*(): CharSet;
+VAR
+ result: CharSet;
+ i: INTEGER;
+BEGIN
+ NEW(result);
+ result.Init(charSetName);
+ FOR i:= 0 TO CharSetLength-1 DO
+ result.value[i]:= {};
+ END;
+ AGRS.eldestAsked:= AGRS.Fixed;
+ RETURN result;
+END NewCharSet;
+
+
+PROCEDURE (t: String) Length*(): LONGINT;
+VAR
+ i: LONGINT;
+ str: Names.CharPtr;
+BEGIN
+ i:= 0;
+ str:= t.value;
+ WHILE str[i]#0X DO
+ INC(i);
+ END;
+ RETURN i
+END Length;
+
+
+PROCEDURE (t: CharSet) Include*(ch: CHAR);
+BEGIN
+ INCL(t.value[ORD(ch) DIV (MAX(SET)+1)],ORD(ch) MOD (MAX(SET)+1));
+END Include;
+
+PROCEDURE (t: CharSet) Complement*();
+VAR
+ i: INTEGER;
+BEGIN
+ FOR i:= 0 TO CharSetLength-1 DO
+ t.value[i]:= -t.value[i];
+ END;
+END Complement;
+
+PROCEDURE NewError*(v: ErrorType): Error;
+VAR
+ result: Error;
+BEGIN
+ NEW(result);
+ result.Init(errorName);
+ AGRS.eldestAsked:= AGRS.Fixed;
+ result.value:= v;
+ RETURN result
+END NewError;
+
+PROCEDURE SubText*(txt: Texts.Text; startPos,endPos: LONGINT): Text;
+VAR
+ newTerm: Text;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(textName);
+ newTerm.base:= txt;
+ newTerm.startOffset:= startPos;
+ newTerm.endOffset:= endPos;
+ RETURN newTerm
+END SubText;
+
+
+PROCEDURE (t: Text) AppendText*(appendage: Text);
+VAR
+ temp: Texts.Buffer;
+ newText: Texts.Text;
+BEGIN
+ IF (t.base=appendage.base) & (t.endOffset=appendage.startOffset) THEN
+ t.endOffset:= appendage.endOffset;
+ ELSE
+ newText:= TextFrames.Text("");
+ NEW(temp);
+ Texts.OpenBuf(temp);
+ Texts.Save(t.base,t.startOffset,t.endOffset,temp);
+ Texts.Save(appendage.base,appendage.startOffset,appendage.endOffset,temp);
+ Texts.Append(newText,temp);
+ t.base:= newText;
+ t.startOffset:= 0;
+ t.endOffset:= newText.len;
+ END;
+END AppendText;
+
+PROCEDURE (t: Text) AppendBuffer*(appendage: Texts.Buffer);
+VAR
+ newText: Texts.Text;
+BEGIN
+ IF t.endOffset=t.base.len THEN
+ Texts.Append(t.base,appendage);
+ t.endOffset:= t.base.len;
+ ELSE
+ newText:= TextFrames.Text("");
+ Texts.Append(newText,appendage);
+ t.base:= newText;
+ t.startOffset:= 0;
+ t.endOffset:= newText.len;
+ END;
+END AppendBuffer;
+
+
+PROCEDURE (t: NamesType) Evaluate*(query: Term): Term;
+BEGIN
+ RETURN NewString(Names.NameSpelling(query.indirection))
+END Evaluate;
+
+
+PROCEDURE pType;
+VAR
+ newTerm: AGRS.OpenTree;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(AGRS.lastResult);
+ AGRS.result:= newTerm;
+END pType;
+
+
+PROCEDURE (t: Character) Compare*(reference: Term; VAR lessEq,grEq: BOOLEAN);
+BEGIN
+ WITH reference: Character DO
+ lessEq:= t.value<=reference.value;
+ grEq:= t.value>=reference.value;
+ ELSE
+ WITH reference: String DO
+ lessEq:= t.value<=reference.value[0];
+ grEq:= t.value>=reference.value[0];
+ IF lessEq & grEq THEN
+ grEq:= reference.value[1]=0X;
+ END;
+ ELSE
+ lessEq:= FALSE;
+ grEq:= FALSE;
+ END;
+ END;
+END Compare;
+
+PROCEDURE (t: String) Compare*(reference: AGRS.Term; VAR lessEq,grEq: BOOLEAN);
+VAR
+ i: INTEGER;
+BEGIN
+ WITH reference: Character DO
+ lessEq:= t.value[0]<=reference.value;
+ grEq:= t.value[0]>=reference.value;
+ IF lessEq & grEq THEN
+ lessEq:= t.value[1]=0X;
+ END;
+ ELSE
+ WITH reference: String DO
+ i:= 0;
+ WHILE (t.value[i]=reference.value[i]) & (t.value[i]#0X) DO
+ INC(i);
+ END;
+ lessEq:= (t.value[i]<=reference.value[i]);
+ grEq:= (t.value[i]>=reference.value[i]);
+ ELSE
+ lessEq:= FALSE;
+ grEq:= FALSE;
+ END;
+ END;
+END Compare;
+
+PROCEDURE (t: Number) Compare*(reference: Term; VAR lessEq,grEq: BOOLEAN);
+BEGIN
+ WITH reference: Number DO
+ lessEq:= t.value<=reference.value;
+ grEq:= t.value>=reference.value;
+ ELSE
+ lessEq:= FALSE;
+ grEq:= FALSE;
+ END;
+END Compare;
+
+PROCEDURE (t: CharSet) Compare*(reference: Term; VAR lessEq,grEq: BOOLEAN);
+VAR
+ i: INTEGER;
+BEGIN
+ lessEq:= TRUE;
+ grEq:= TRUE;
+ WITH reference: CharSet DO
+ FOR i:= 0 TO CharSetLength-1 DO
+ IF t.value[i]-reference.value[i]#{} THEN
+ lessEq:= FALSE;
+ END;
+ IF reference.value[i]-t.value[i]#{} THEN
+ grEq:= FALSE;
+ END;
+ END;
+ ELSE
+ END;
+END Compare;
+
+PROCEDURE (t: Error) Compare*(reference: Term; VAR lessEq,grEq: BOOLEAN);
+BEGIN
+ WITH reference: Error DO
+ lessEq:= t.value<=reference.value;
+ grEq:= t.value>=reference.value;
+ ELSE
+ lessEq:= FALSE;
+ grEq:= FALSE;
+ END;
+END Compare;
+
+
+PROCEDURE pEqual;
+VAR
+ t1,t2: AGRS.Term;
+BEGIN
+ t1:= argName1.Value();
+ t2:= argName2.Value();
+ IF AGRS.Equal(t1,t2) THEN
+ TrueDef.Reduce;
+ ELSE
+ AGRS.Fail;
+ END;
+END pEqual;
+
+PROCEDURE pLess;
+VAR
+ t1,t2: AGRS.Term;
+ lessEq,grEq: BOOLEAN;
+BEGIN
+ t1:= argName1.Value();
+ WITH t1: AGRS.Atomic DO
+ t2:= argName2.Value();
+ t1.Compare(t2,lessEq,grEq);
+ IF lessEq & ~grEq THEN
+ TrueDef.Reduce;
+ RETURN
+ END;
+ END;
+ AGRS.Fail;
+END pLess;
+
+PROCEDURE pGreater;
+VAR
+ t1,t2: AGRS.Term;
+ lessEq,grEq: BOOLEAN;
+ oldStack: AGRS.TermStack;
+BEGIN
+ t1:= argName1.Value();
+ WITH t1: AGRS.Atomic DO
+ t2:= argName2.Value();
+ t1.Compare(t2,lessEq,grEq);
+ IF ~lessEq & grEq THEN
+ TrueDef.Reduce;
+ RETURN
+ END;
+ END;
+ AGRS.Fail;
+END pGreater;
+
+PROCEDURE pLessEq;
+VAR
+ t1,t2: AGRS.Term;
+ lessEq,grEq: BOOLEAN;
+BEGIN
+ t1:= argName1.Value();
+ WITH t1: AGRS.Atomic DO
+ t2:= argName2.Value();
+ t1.Compare(t2,lessEq,grEq);
+ IF lessEq THEN
+ TrueDef.Reduce;
+ RETURN
+ END;
+ END;
+ AGRS.Fail;
+END pLessEq;
+
+PROCEDURE pGrEq;
+VAR
+ t1,t2: AGRS.Term;
+ lessEq,grEq: BOOLEAN;
+BEGIN
+ t1:= argName1.Value();
+ WITH t1: AGRS.Atomic DO
+ t2:= argName2.Value();
+ t1.Compare(t2,lessEq,grEq);
+ IF grEq THEN
+ TrueDef.Reduce;
+ RETURN
+ END;
+ END;
+ AGRS.Fail;
+END pGrEq;
+
+PROCEDURE pNot;
+BEGIN
+ AGRS.result:= argName1.Value();
+ IF AGRS.result.indirection=trueName THEN
+ AGRS.result:= AGRS.Failure;
+ ELSIF AGRS.result.indirection=AGRS.failName THEN
+ AGRS.result:= TrueDef;
+ ELSE
+ AGRS.result:= NewError(NotLogicalType);
+ END;
+ AGRS.result.Reduce;
+END pNot;
+
+PROCEDURE pAnd;
+VAR
+ eldest1: INTEGER;
+BEGIN
+ AGRS.result:= argName1.Value();
+ IF AGRS.result.indirection=trueName THEN
+ eldest1:= AGRS.eldestAsked;
+ AGRS.result:= argName2.Value();
+ IF eldest1<AGRS.eldestAsked THEN
+ AGRS.eldestAsked:= eldest1;
+ END;
+ ELSIF AGRS.result.indirection#AGRS.failName THEN
+ AGRS.result:= NewError(NotLogicalType);
+ END;
+ AGRS.result.Reduce;
+END pAnd;
+
+PROCEDURE pOr;
+VAR
+ eldest1: INTEGER;
+BEGIN
+ AGRS.result:= argName1.Value();
+ IF AGRS.result.indirection=AGRS.failName THEN
+ eldest1:= AGRS.eldestAsked;
+ AGRS.result:= argName2.Value();
+ IF eldest1<AGRS.eldestAsked THEN
+ AGRS.eldestAsked:= eldest1;
+ END;
+ ELSIF AGRS.result.indirection#trueName THEN
+ AGRS.result:= NewError(NotLogicalType);
+ END;
+ AGRS.result.Reduce;
+END pOr;
+
+
+PROCEDURE pIf;
+VAR
+ eldest1: INTEGER;
+BEGIN
+ AGRS.result:= testName.Value();
+ eldest1:= AGRS.eldestAsked;
+ IF AGRS.result.indirection=trueName THEN
+ yesName.Reduce;
+ ELSIF AGRS.result.indirection=AGRS.failName THEN
+ noName.Reduce;
+ ELSE
+ AGRS.result:= NewError(NotLogicalType);
+ AGRS.result.Reduce;
+ END;
+ IF eldest1<AGRS.eldestAsked THEN
+ AGRS.eldestAsked:= eldest1;
+ END;
+END pIf;
+
+
+PROCEDURE ExtractNumbers(VAR x,y:INTEGER):BOOLEAN;
+VAR
+ eldest1: INTEGER;
+ arg: Term;
+BEGIN
+ arg:= argName1.Value();
+ WITH arg: Number DO
+ x:= arg.value;
+ ELSE
+ RETURN FALSE
+ END;
+ eldest1:= AGRS.eldestAsked;
+ arg:= argName2.Value();
+ WITH arg: Number DO
+ y:= arg.value;
+ ELSE
+ RETURN FALSE
+ END;
+ IF eldest1<AGRS.eldestAsked THEN
+ AGRS.eldestAsked:= eldest1;
+ END;
+ RETURN TRUE
+END ExtractNumbers;
+
+PROCEDURE ExtractNumbersFromStack(VAR x,y:INTEGER; VAR oldStack:AGRS.TermStack):BOOLEAN;
+VAR
+ arg: Term;
+BEGIN
+ IF (AGRS.paramStack=NIL) OR (AGRS.paramStack.rest=NIL) THEN
+ RETURN FALSE
+ END;
+ oldStack:= AGRS.paramStack;
+ arg:= AGRS.paramStack.top;
+ WITH arg: Number DO
+ x:= arg.value;
+ ELSE
+ RETURN FALSE
+ END;
+ AGRS.paramStack:= AGRS.paramStack.rest;
+ arg:= AGRS.paramStack.top;
+ WITH arg: Number DO
+ y:= arg.value;
+ ELSE
+ RETURN FALSE
+ END;
+ AGRS.paramStack:= AGRS.paramStack.rest;
+ RETURN TRUE
+END ExtractNumbersFromStack;
+
+PROCEDURE pAdd;
+VAR
+ x,y:INTEGER;
+ newTerm: Term;
+ oldStack: AGRS.TermStack;
+BEGIN
+ IF ExtractNumbers(x,y) THEN
+ newTerm:= NewNumber(x+y);
+ newTerm.Reduce;
+ ELSE
+ AGRS.Continue;
+ END;
+END pAdd;
+
+PROCEDURE pSub;
+VAR
+ x,y:INTEGER;
+ newTerm: Term;
+BEGIN
+ IF ExtractNumbers(x,y) THEN
+ newTerm:= NewNumber(x-y);
+ newTerm.Reduce;
+ ELSE
+ AGRS.Continue;
+ END;
+END pSub;
+
+PROCEDURE pMul;
+VAR
+ x,y:INTEGER;
+ newTerm: Term;
+BEGIN
+ IF ExtractNumbers(x,y) THEN
+ newTerm:= NewNumber(x*y);
+ newTerm.Reduce;
+ ELSE
+ AGRS.Continue;
+ END;
+END pMul;
+
+PROCEDURE pDiv;
+VAR
+ x,y:INTEGER;
+ newTerm: Term;
+BEGIN
+ IF ExtractNumbers(x,y) THEN
+ newTerm:= NewNumber(x DIV y);
+ newTerm.Reduce;
+ ELSE
+ AGRS.Continue;
+ END;
+END pDiv;
+
+PROCEDURE pMod;
+VAR
+ x,y:INTEGER;
+ newTerm: Term;
+BEGIN
+ IF ExtractNumbers(x,y) THEN
+ newTerm:= NewNumber(x MOD y);
+ newTerm.Reduce;
+ ELSE
+ AGRS.Continue;
+ END;
+END pMod;
+
+
+PROCEDURE pFind;
+VAR
+ s,n: Term;
+BEGIN
+ s:= nameName.Value();
+ WITH s: String DO
+ n:= Names.FindPublicName(s.value^);
+ IF n=NIL THEN
+ n:= NewError(NotFound);
+ END;
+ ELSE
+ n:= NewError(NotStringType);
+ END;
+ n.Reduce;
+END pFind;
+
+PROCEDURE pAbort;
+VAR
+ stack: AGRS.TermStack;
+BEGIN
+ stack:= AGRS.continuation;
+ HALT(255)
+END pAbort;
+
+PROCEDURE pUnify;
+BEGIN
+ AGRS.Push(trueName);
+ AGRS.Unify(argName1.indirection,argName2.Value());
+END pUnify;
+
+PROCEDURE (t: BinOp) Reduce*;
+BEGIN
+ AGRS.Push(t.indirection);
+ AGRS.Push(argName2.indirection);
+ argName1.Reduce;
+END Reduce;
+
+PROCEDURE AddBinOp(proc:AGRS.HandlerType; name,primName: ARRAY OF CHAR);
+VAR
+ newTerm: BinOp;
+ newName: AGRS.Name;
+BEGIN
+ Names.AddSystemName(newName,primName,proc);
+ NEW(newTerm);
+ newTerm.Init(newName);
+ Names.DefinePublicName(newName,name,newTerm);
+END AddBinOp;
+
+BEGIN
+ Names.AddSystemName(atomicName,'AtomSystemRoot',AGRS.AtomicHandler);
+ Names.DefinePublicName(textName,'TEXT',atomicName.indirection);
+ Names.DefinePublicName(stringName,'STRING',atomicName.indirection);
+ Names.DefinePublicName(charName,'CHAR',atomicName.indirection);
+ Names.DefinePublicName(charSetName,'CharSET',atomicName.indirection);
+ Names.DefinePublicName(errorName,'ERROR',atomicName.indirection);
+ Names.DefinePublicName(numberName,'NUMBER',atomicName.indirection);
+
+ Names.AddArgument(carName, 'Car');
+ Names.AddArgument(cdrName, 'Cdr');
+ Names.AddArgument(nilName, 'Nil');
+ Names.AddArgument(consName, 'Cons');
+
+ Names.AddArgument(trueName, 'True');
+ NEW(TrueDef);
+ TrueDef.Init(trueName);
+ Names.AddSystemName(andName, 'And', pAnd);
+ Names.AddSystemName(orName, 'Or', pOr);
+ Names.AddSystemName(notName, 'Not', pNot);
+ Names.AddSystemName(ifName, 'If', pIf);
+ Names.AddArgument(testName, 'Test');
+ Names.AddArgument(yesName, 'Yes');
+ Names.AddArgument(noName, 'No');
+
+ argName1:= Names.FindOrdinalName(1);
+ argName2:= Names.FindOrdinalName(2);
+
+ NEW(disTerm);
+ disTerm.Init(argName1);
+ disTerm.InitAlternative(argName2);
+ Names.DefinePublicName(disName, 'Dis', disTerm);
+
+ Names.AddSystemName(AGRS.failName,'Fail',AGRS.Fail);
+ Names.AddSystemName(unifyName, 'Unify', pUnify);
+ Names.AddSystemName(equalName, 'Equal', pEqual);
+ Names.AddSystemName(lessName, 'Less', pLess);
+ Names.AddSystemName(greaterName, 'Greater', pGreater);
+ Names.AddSystemName(lessEqName, 'LessEq', pLessEq);
+ Names.AddSystemName(grEqName, 'GrEq', pGrEq);
+ NEW(AGRS.Failure);
+ AGRS.Failure.Init(AGRS.failName);
+
+ Names.AddSystemName(addName, 'Add', pAdd);
+ Names.AddSystemName(subName, 'Sub', pSub);
+ Names.AddSystemName(mulName, 'Mul', pMul);
+ Names.AddSystemName(divName, 'Div', pDiv);
+ Names.AddSystemName(modName, 'Mod', pMod);
+ Names.AddSystemName(findName, 'Find', pFind);
+ Names.AddSystemName(abortName, 'Abort', pAbort);
+
+ NEW(NamesTerm);
+ NamesTerm.Init(Names.SystemRoot);
+ Names.DefinePublicName(namesName,'Names',NamesTerm);
+END Library.
diff --git a/examples/AGRS/Links.Def b/examples/AGRS/Links.Def
new file mode 100644
index 0000000..b8c0f05
--- /dev/null
+++ b/examples/AGRS/Links.Def
@@ -0,0 +1,64 @@
+(*
+https://web.archive.org/web/20041226015509/http://www.oberon.ethz.ch:80/ethoberon/defs/Links.Def.html
+*)
+DEFINITION Links; (* portable *)
+
+(*The Links module manage a set of named references to objects for the gadgets.
+*)
+ IMPORT
+ Files, Objects;
+
+ TYPE
+ Link = POINTER TO LinkDesc;
+ LinkDesc = RECORD
+ next: Link;
+ name: ARRAY 32 OF CHAR;
+ obj: Objects.Object
+ END;
+
+(* Store links to a file. Only (ref, lib) references to links are written. *)
+ PROCEDURE StoreLinks (VAR R: Files.Rider; lib: Objects.Library; list: Link);
+
+(* Load links from a file. *)
+ PROCEDURE LoadLinks (VAR R: Files.Rider; lib: Objects.Library; VAR list: Link);
+
+(* Copy links. Both shallow and deep copies are supported. *)
+ PROCEDURE CopyLinks (VAR M: Objects.CopyMsg; in: Link; VAR out: Link);
+
+(* Bind all linked objects. *)
+ PROCEDURE BindLinks (list: Link; VAR M: Objects.BindMsg);
+
+(* Insert a link in a list. An existing link with the same name is discarded.
+*)
+ PROCEDURE InsertLink (VAR list: Link; name: ARRAY OF CHAR; val: Link);
+
+(* Link Locate. *)
+ PROCEDURE FindLink (name: ARRAY OF CHAR; list: Link): Link;
+
+(* Delete a link. *)
+ PROCEDURE DeleteLink (VAR list: Link; name: ARRAY OF CHAR);
+
+(* Default handling of setting, retrieving and enumerating a list of links.
+Parameter list might be modified
+during a set operation. *)
+ PROCEDURE HandleLinkMsg (VAR list: Link; VAR M: Objects.LinkMsg);
+
+(* Forward a message to all linked objects in the list. USE WITH CARE, MESSAGE
+CYCLES! *)
+ PROCEDURE Broadcast (list: Link; VAR M: Objects.ObjMsg);
+
+(* Get the named link of obj. *)
+ PROCEDURE GetLink (obj: Objects.Object; name: ARRAY OF CHAR; VAR ob1: Objects.Object);
+
+(* Set the named link of obj. *)
+ PROCEDURE SetLink (obj: Objects.Object; name: ARRAY OF CHAR; ob1: Objects.Object);
+
+END Links.
+
+(* Remarks:
+
+1. The links of gadgets (both Gadgets.Object and Gadgets.Frame) are managed
+by module Gadgets. Module Gadgets use the utility procedures defined in module
+Links.
+
+*)
diff --git a/examples/AGRS/ListRiders.Def b/examples/AGRS/ListRiders.Def
new file mode 100644
index 0000000..81e8021
--- /dev/null
+++ b/examples/AGRS/ListRiders.Def
@@ -0,0 +1,90 @@
+(*
+https://web.archive.org/web/20041226023712/http://www.oberon.ethz.ch:80/ethoberon/defs/ListRiders.Def.html
+*)
+DEFINITION ListRiders; (* portable *) (* ps, based on Rider by rv, *)
+
+ IMPORT Objects, Gadgets;
+
+ CONST
+ (* id for UpdateMsg *)
+ insert = 0; delete = 1; state = 2;
+
+ TYPE
+ Data = POINTER TO DataDesc;
+ DataDesc = RECORD
+ END;
+
+ Bool = POINTER TO BoolDesc;
+ BoolDesc = RECORD ( DataDesc )
+ b: BOOLEAN END;
+
+ Char = POINTER TO CharDesc;
+ CharDesc = RECORD ( DataDesc )
+ c: CHAR END;
+
+ String = POINTER TO StringDesc;
+ StringDesc = RECORD ( DataDesc )
+ s: ARRAY 64 OF CHAR END;
+
+ Int = POINTER TO IntDesc;
+ IntDesc = RECORD ( DataDesc )
+ i: LONGINT END;
+
+ Real = POINTER TO RealDesc;
+ RealDesc = RECORD ( DataDesc )
+ x: REAL END;
+
+ LReal = POINTER TO LRealDesc;
+ LRealDesc = RECORD ( DataDesc )
+ x: LONGREAL END;
+
+ Method = POINTER TO MethodDesc;
+ Rider = POINTER TO RiderDesc;
+ RiderDesc = RECORD
+ d: Data; (* Data of the current item *)
+ do: Method; (* Method block *)
+ base: Objects.Object; (* Model object on which the rider is working *)
+ dsc, eol: BOOLEAN (* Has-descendant, End-of-list *)
+ END;
+
+ MethodDesc = RECORD
+ Key: PROCEDURE (R: Rider): LONGINT; (* Get the current item's key *)
+ Seek: PROCEDURE (R: Rider; key: LONGINT); (* Position rider R on the item
+having the given key *)
+ Pos: PROCEDURE (R: Rider): LONGINT; (* Get current position of the rider
+*)
+ Set: PROCEDURE (R: Rider; pos: LONGINT); (* Position rider R on the item
+having the given pos *)
+ Write: PROCEDURE (R: Rider; d: Data); (* Insert data at the current position
+of R *)
+ WriteLink: PROCEDURE (R, linkR: Rider); (* Link the item at the position
+of linkR to the current position of R *)
+ DeleteLink: PROCEDURE (R, linkR: Rider); (* Delete link from R to linkR
+*)
+ State: PROCEDURE (R: Rider): LONGINT; (* Get the state of the current item
+*)
+ SetState: PROCEDURE (R: Rider; s: LONGINT); (* Set the state of the current
+item *)
+ (* Get a rider working on the descendants of the item on the position of R.
+If old is NIL, then a new rider
+ is allocated. old is recycled if not NIL *)
+ Desc: PROCEDURE (R, old: Rider): Rider;
+ GetStamp: PROCEDURE (R: Rider): LONGINT; (* Get stamp value of the item
+at the current position of R *)
+ SetStamp: PROCEDURE (R: Rider; stamp: LONGINT) (* Set stamp value of the
+item at the current position of R *)
+ END;
+
+ (* Get a new initialized rider from a model gadget. Sent by a client to a model
+gadget. *)
+ ConnectMsg = RECORD ( Objects.ObjMsg )
+ R: Rider
+ END;
+
+ (* Message broadcast to indicate that a model object changed *)
+ UpdateMsg = RECORD ( Gadgets.UpdateMsg )
+ id: INTEGER (* insert, delete or state *)
+ END;
+ PROCEDURE Stamp (): LONGINT;
+
+END ListRiders.
diff --git a/examples/AGRS/Main.Mod b/examples/AGRS/Main.Mod
new file mode 100644
index 0000000..f1e2521
--- /dev/null
+++ b/examples/AGRS/Main.Mod
@@ -0,0 +1,108 @@
+MODULE Main;
+IMPORT AGRS,Names,Library,Parser,Speller,Parser2,
+ Grammars,Permanence,Oberon,Texts;
+
+
+VAR
+ rd: Texts.Reader;
+ wr: Texts.Writer;
+
+
+PROCEDURE InputText(limit: CHAR): Library.Text;
+VAR
+ text: Texts.Text;
+ ch: CHAR;
+ first,last,time: LONGINT;
+BEGIN
+ text:= Oberon.Par.text;
+ Texts.OpenReader(rd,text,Oberon.Par.pos);
+ Texts.Read(rd,ch);
+ WHILE (ch=' ') OR (ch=9X) DO
+ Texts.Read(rd,ch);
+ END;
+ IF ch='^' THEN
+ Oberon.GetSelection(text,first,last,time);
+ IF (time=0) OR (text=NIL) THEN
+ RETURN NIL
+ END;
+ ELSE
+ first:= Texts.Pos(rd)-1;
+ WHILE (ch#limit) & ~rd.eot DO
+ Texts.Read(rd,ch);
+ END;
+ last:= Texts.Pos(rd)-1;
+ END;
+ RETURN Library.SubText(text,first,last)
+END InputText;
+
+PROCEDURE InputValue(): AGRS.Term;
+VAR
+ textTerm: Library.Text;
+ t: AGRS.Term;
+BEGIN
+ textTerm:= InputText(0DX);
+ IF textTerm=NIL THEN
+ RETURN NIL
+ END;
+ Grammars.sentenceName.Assign(textTerm);
+ t:= Grammars.parseName.Value();
+(* t:= Names.IsolateSymbols(Parser.parseName); *)
+ Grammars.sentenceName.Restore();
+(* RETURN t; *)
+ RETURN Permanence.environmentName.Evaluate(t)
+(* RETURN t.Value() *)
+END InputValue;
+
+
+PROCEDURE Evaluate*;
+VAR
+ t,s: AGRS.Term;
+BEGIN
+ t:= InputValue();
+ IF t=NIL THEN
+ RETURN
+ END;
+ Speller.thoughtName.Assign(t);
+ s:= Speller.spellingName.Value();
+ Speller.thoughtName.Restore;
+ WITH s: Library.Text DO
+ Texts.Save(s.base,s.startOffset,s.endOffset,wr.buf);
+ END;
+ Texts.WriteLn(wr);
+ Texts.Append(Oberon.Log,wr.buf);
+END Evaluate;
+
+
+PROCEDURE AssignDefinition(param: AGRS.Name; VAR meaning: AGRS.Term);
+BEGIN
+ param.Init(meaning);
+END AssignDefinition;
+
+
+PROCEDURE Define*;
+VAR
+ textTerm: Library.Text;
+ definition: AGRS.Term;
+BEGIN
+ textTerm:= InputText(';');
+ IF textTerm=NIL THEN
+ RETURN
+ END;
+ Parser.sentenceName.Assign(textTerm);
+ Parser.buildingName.Assign(Names.SystemRoot);
+ definition:= Parser.attributeParser.Value();
+ Parser.buildingName.Restore();
+ Parser.sentenceName.Restore();
+ IF definition.indirection=AGRS.failName THEN
+ Texts.WriteString(wr,'Syntax error!');
+ ELSE
+ definition(AGRS.Tree).ProcessAttributes(AssignDefinition);
+ Texts.WriteString(wr,'Assigned.');
+ END;
+ Texts.WriteLn(wr);
+ Texts.Append(Oberon.Log,wr.buf);
+END Define;
+
+BEGIN
+ Texts.OpenWriter(wr);
+END Main.
diff --git a/examples/AGRS/Names.Mod b/examples/AGRS/Names.Mod
new file mode 100644
index 0000000..44a83b5
--- /dev/null
+++ b/examples/AGRS/Names.Mod
@@ -0,0 +1,371 @@
+MODULE Names;
+IMPORT AGRS,SYSTEM;
+
+
+CONST
+ MaxEntries=64; (* Broj ulaza u hash tabeli *)
+ LastEntry=MaxEntries-1;
+TYPE
+ CharPtr*= POINTER TO ARRAY OF CHAR;
+ PublicName= POINTER TO RECORD(AGRS.NameDesc) (* Imenovani parametar *)
+ spelling: CharPtr;
+ next: PublicName;
+ END;
+ OrdinalName= POINTER TO RECORD(AGRS.NameDesc) (* Genericki parametar sa imenom 'nth' *)
+ number: INTEGER;
+ next: OrdinalName;
+ END;
+ Dictionary= POINTER TO DictRec; (* Tabela simbola *)
+ DictRec= RECORD
+ entries: ARRAY MaxEntries OF PublicName;
+ next: Dictionary;
+ END;
+VAR
+ top: Dictionary;
+ ordinalList: OrdinalName;
+
+ SystemRoot*,VariableRoot*: AGRS.Name;
+ localName*, bodyName*: AGRS.Name;
+
+ UndefinedTerm: AGRS.SystemTerm;
+
+ temp: AGRS.Term;
+ temp1: AGRS.SubTerm;
+ temp2: AGRS.SystemTerm;
+
+ systemSpelling: CharPtr;
+ systemHash: INTEGER;
+
+ i: INTEGER;
+ search: BOOLEAN;
+
+
+
+PROCEDURE IsolateSymbols*(query: AGRS.Term): AGRS.Term;
+VAR
+ d: Dictionary;
+ i: INTEGER;
+ result: AGRS.Term;
+BEGIN
+ NEW(d);
+ FOR i:= 0 TO LastEntry DO
+ d.entries[i]:=top.entries[i];
+ END;
+ d.next:= top;
+ top:= d;
+ result:= query.Value();
+ top:= top.next;
+ RETURN result
+END IsolateSymbols;
+
+
+PROCEDURE LocalBlock*;
+VAR
+ d: Dictionary;
+ i: INTEGER;
+BEGIN
+ NEW(d);
+ FOR i:= 0 TO LastEntry DO
+ d.entries[i]:=top.entries[i];
+ END;
+ d.next:= top;
+ top:= d;
+END LocalBlock;
+
+PROCEDURE EndBlock*;
+BEGIN
+ top:= top.next;
+END EndBlock;
+
+PROCEDURE LocalNames;
+BEGIN
+ search:= FALSE;
+ bodyName.Reduce;
+END LocalNames;
+
+PROCEDURE EndLocalNames;
+BEGIN
+ search:= TRUE;
+ AGRS.Continue;
+END EndLocalNames;
+
+
+PROCEDURE NewStringCopy*(str: ARRAY OF CHAR): CharPtr;
+VAR
+ result: CharPtr;
+ i,length: INTEGER;
+BEGIN
+ length:= 0;
+ WHILE (length#LEN(str)) & (str[length]#0X) DO
+ INC(length);
+ END;
+ NEW(result,length+1);
+ FOR i:= 0 TO length-1 DO
+ result[i]:= str[i];
+ END;
+ result[length]:= 0X;
+ AGRS.eldestAsked:= AGRS.Fixed;
+ RETURN result;
+END NewStringCopy;
+
+
+
+PROCEDURE HashString(VAR str: ARRAY OF CHAR; module: INTEGER): INTEGER;
+VAR
+ i,result: INTEGER;
+BEGIN
+ i:= 0;
+ result:= 0;
+ WHILE (i<LEN(str)) & (str[i]#0X) DO
+ result:= result+ORD(CAP(str[i]));
+ INC(i);
+ END;
+ RETURN result MOD module;
+END HashString;
+
+
+PROCEDURE DefinePublicName*(VAR result: AGRS.Name; spelling: ARRAY OF CHAR; meaning: AGRS.Term);
+VAR
+ newName: PublicName;
+ hash: INTEGER;
+ spellingCopy: CharPtr;
+BEGIN
+ spellingCopy:= NewStringCopy(spelling);
+ NEW(newName);
+ result:= newName;
+ IF meaning#UndefinedTerm THEN
+ newName.Init(meaning);
+ newName.spelling:= spellingCopy;
+ newName.next:= top.entries[systemHash];
+ meaning:= newName;
+ top.entries[systemHash]:= newName;
+ NEW(newName);
+ END;
+ hash:= HashString(spelling,MaxEntries);
+ newName.Init(meaning);
+ newName.spelling:= NewStringCopy(spelling);
+ newName.next:= top.entries[hash];
+ top.entries[hash]:= newName;
+END DefinePublicName;
+
+PROCEDURE AddSystemName*(VAR result: AGRS.Name; spelling: ARRAY OF CHAR; handler: AGRS.HandlerType);
+VAR
+ newTerm: AGRS.SystemTerm;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(SystemRoot);
+ newTerm.InitHandler(handler);
+ DefinePublicName(result,spelling,newTerm);
+END AddSystemName;
+
+
+PROCEDURE AddArgument*(VAR result: AGRS.Name; spelling: ARRAY OF CHAR);
+BEGIN
+ DefinePublicName(result,spelling,UndefinedTerm);
+END AddArgument;
+
+
+PROCEDURE AddAtom*(VAR name: AGRS.Name; spelling: ARRAY OF CHAR): AGRS.Term;
+VAR
+ newTerm: AGRS.Atomic;
+BEGIN
+ AddSystemName(name,spelling,AGRS.AtomicHandler);
+ NEW(newTerm);
+ newTerm.Init(name);
+ RETURN newTerm
+END AddAtom;
+
+
+PROCEDURE FindOrdinalName*(ordinalNumber: INTEGER): AGRS.Name;
+VAR
+ newName,seek,follow: OrdinalName;
+BEGIN
+ seek:= ordinalList;
+ WHILE (seek#NIL) & (seek.number<ordinalNumber) DO
+ follow:= seek;
+ seek:= seek.next;
+ END;
+ IF (seek=NIL) OR (seek.number>ordinalNumber) THEN
+ NEW(newName);
+ newName.Init(UndefinedTerm);
+ newName.number:= ordinalNumber;
+ newName.next:= seek;
+ follow.next:= newName;
+ RETURN newName
+ ELSE
+ RETURN seek
+ END;
+END FindOrdinalName;
+
+
+PROCEDURE FindPublicName*(wd: ARRAY OF CHAR): AGRS.Name;
+VAR
+ follow: PublicName;
+ letter: INTEGER;
+ ordinal: INTEGER;
+BEGIN
+ IF ~search THEN
+ RETURN NIL
+ END;
+ follow:= top.entries[HashString(wd,MaxEntries)];
+ WHILE follow#NIL DO
+ IF follow.spelling[0]=wd[0] THEN
+ letter:=1;
+ WHILE (wd[letter]=follow.spelling[letter]) & (follow.spelling[letter]#0X) DO
+ INC(letter);
+ END;
+ IF wd[letter]=follow.spelling[letter] THEN
+ RETURN follow
+ END;
+ END;
+ follow:=follow.next;
+ END;
+ letter:= 0;
+ ordinal:= 0;
+ WHILE (wd[letter]>='0') & (wd[letter]<='9') DO
+ ordinal:= 10*ordinal+ORD(wd[letter])-ORD('0');
+ INC(letter);
+ END;
+ IF (ordinal=0) OR (wd[letter+2]#0X) THEN
+ RETURN NIL
+ END;
+ CASE wd[letter-1] OF
+ |'1': IF (wd[letter]#'s') OR (wd[letter+1]#'t') THEN RETURN NIL END;
+ |'2': IF (wd[letter]#'n') OR (wd[letter+1]#'d') THEN RETURN NIL END;
+ |'3': IF (wd[letter]#'r') OR (wd[letter+1]#'d') THEN RETURN NIL END;
+ ELSE
+ IF (wd[letter]#'t') OR (wd[letter+1]#'h') THEN RETURN NIL END;
+ END;
+ RETURN FindOrdinalName(ordinal)
+END FindPublicName;
+
+
+PROCEDURE FindPublicNameNoCase*(wd: ARRAY OF CHAR): AGRS.Name;
+VAR
+ follow: PublicName;
+ letter: LONGINT;
+BEGIN
+ letter:= 0;
+ WHILE (wd[letter]#0X) & (letter<LEN(wd)) DO
+ wd[letter]:= CAP(wd[letter]);
+ INC(letter);
+ END;
+ follow:=top.entries[HashString(wd,MaxEntries)];
+ WHILE follow#NIL DO
+ IF CAP(follow.spelling[0])=wd[0] THEN
+ letter:=1;
+ WHILE (wd[letter]=CAP(follow.spelling[letter])) & (follow.spelling[letter]#0X) DO
+ INC(letter);
+ END;
+ IF wd[letter]=follow.spelling[letter] THEN
+ RETURN follow
+ END;
+ END;
+ follow:=follow.next
+ END;
+ RETURN NIL
+END FindPublicNameNoCase;
+
+
+PROCEDURE NameSpelling*(t: AGRS.Term): CharPtr;
+VAR
+ nameSpelling: CharPtr;
+ size,rest: INTEGER;
+ addr: LONGINT;
+BEGIN
+ WITH t: PublicName DO
+ RETURN t.spelling
+ ELSE
+ WITH t: OrdinalName DO
+ size:= 3;
+ rest:= t.number;
+ REPEAT
+ rest:= rest DIV 10;
+ INC(size);
+ UNTIL rest=0;
+ NEW(nameSpelling,size);
+ nameSpelling[size-1]:= 0X;
+ rest:= t.number;
+ IF (rest DIV 10) MOD 10 = 1 THEN
+ nameSpelling[size-3]:= 't';
+ nameSpelling[size-2]:= 'h';
+ ELSE
+ CASE rest MOD 10 OF
+ |1:
+ nameSpelling[size-3]:= 's';
+ nameSpelling[size-2]:= 't';
+ |2:
+ nameSpelling[size-3]:= 'n';
+ nameSpelling[size-2]:= 'd';
+ |3:
+ nameSpelling[size-3]:= 'r';
+ nameSpelling[size-2]:= 'd';
+ ELSE
+ nameSpelling[size-3]:= 't';
+ nameSpelling[size-2]:= 'h';
+ END;
+ END;
+ size:= size-4;
+ REPEAT
+ nameSpelling[size]:= CHR(ORD('0') + rest MOD 10);
+ rest:= rest DIV 10;
+ DEC(size);
+ UNTIL size<0;
+ RETURN nameSpelling
+ ELSE
+ IF t IS AGRS.Name THEN
+ NEW(nameSpelling,12);
+ nameSpelling[0]:= '_';
+ size:= 1;
+ addr:= SYSTEM.VAL(LONGINT,t);
+ REPEAT
+ nameSpelling[size]:= CHR(ORD('0') + addr MOD 10);
+ addr:= addr DIV 10;
+ INC(size);
+ UNTIL addr=0;
+ nameSpelling[size]:= 0X;
+ RETURN nameSpelling;
+ END;
+ RETURN NewStringCopy('!@#')
+ END;
+ END;
+END NameSpelling;
+
+BEGIN
+ search:= TRUE;
+ NEW(top);
+ top.next:= NIL;
+ FOR i:= 0 TO LastEntry DO
+ top.entries[i]:= NIL
+ END;
+ NEW(UndefinedTerm);
+ AddArgument(SystemRoot,'#System#');
+ UndefinedTerm.Init(SystemRoot);
+ UndefinedTerm.InitHandler(AGRS.Continue);
+ AddArgument(VariableRoot,'#System#');
+ AGRS.Variable.Init(VariableRoot);
+ AGRS.Variable.InitHandler(AGRS.Continue);
+ NEW(ordinalList);
+ ordinalList.Init(UndefinedTerm);
+ ordinalList.number:= 1;
+ ordinalList.next:= NIL;
+ AddArgument(AGRS.otherwise,'Otherwise');
+ AddArgument(bodyName, 'LocalBody');
+ NEW(temp1);
+ NEW(temp2);
+ temp1.Init(bodyName);
+ temp1.InitQuery(temp2);
+ temp2.Init(SystemRoot);
+ temp2.InitHandler(EndLocalNames);
+ temp:= temp1;
+ NEW(temp1);
+ NEW(temp2);
+ temp2.Init(SystemRoot);
+ temp2.InitHandler(LocalNames);
+ temp1.Init(temp2);
+ temp1.InitQuery(temp);
+ DefinePublicName(localName,'LocalNames',temp);
+ systemSpelling:= NewStringCopy('#');
+ systemHash:= HashString(systemSpelling^, MaxEntries);
+END Names.
+
diff --git a/examples/AGRS/OFS.Def b/examples/AGRS/OFS.Def
new file mode 100644
index 0000000..acf9dbe
--- /dev/null
+++ b/examples/AGRS/OFS.Def
@@ -0,0 +1,3 @@
+DEFINITION OFS;
+
+END OFS. \ No newline at end of file
diff --git a/examples/AGRS/Oberon.Def b/examples/AGRS/Oberon.Def
new file mode 100644
index 0000000..43847b4
--- /dev/null
+++ b/examples/AGRS/Oberon.Def
@@ -0,0 +1,415 @@
+(*
+https://web.archive.org/web/20041226165258/http://www.oberon.ethz.ch:80/ethoberon/defs/Oberon.Def.html
+*)
+DEFINITION Oberon; (* portable, except where noted *)
+
+(* Oberon system manager for dispatch of keyboard and mouse input,
+scheduling of tasks, cursor handling and command execution.
+*)
+ IMPORT Display, Objects, Viewers, Fonts, Texts;
+
+ CONST
+
+ (* Message ids: *)
+ defocus = 0; neutralize = 1; mark = 2; (* ControlMsg*)
+ consume = 0; track = 1; (* InputMsg*)
+ get = 0; set = 1; reset = 2; (* CaretMsg id, SelectMsg id*)
+
+ TYPE
+ Painter = PROCEDURE (x, y: INTEGER);
+ Marker = RECORD
+ Fade, Draw: Painter (* Remove and draw marker. *)
+ END;
+
+ Cursor = RECORD
+ marker: Marker; (* Cursor marker. *)
+ on: BOOLEAN; (* Is cursor shown? *)
+ X, Y: INTEGER (* Absolute cursor position. *)
+ END;
+
+ ParList = POINTER TO ParRec;
+ ParRec = RECORD (* Area for passing command parameters. *)
+ vwr: Viewers.Viewer; (* Viewer in which command is executed. *)
+ frame: Display.Frame; (* Frame of vwr from where command is executed. *)
+ obj: Objects.Object; (* Object in vwr executing command. *)
+ text: Texts.Text; (* Text parameter to be passed to command. *)
+ pos: LONGINT (* Starting position in text of parameter. *)
+ END;
+
+ ControlMsg = RECORD ( Display.FrameMsg )
+ id: INTEGER; (* defocus, neutralize, mark *)
+ X, Y: INTEGER (* Absolute mark position. *)
+ END;
+
+ InputMsg = RECORD ( Display.FrameMsg )
+ id: INTEGER; (* consume, track *)
+ keys: SET; (* Mouse buttons. *)
+ X, Y: INTEGER; (* Mouse position. *)
+ ch: CHAR; (* Character typed. *)
+ fnt: Fonts.Font; (* Font of typed character. *)
+ col, voff: SHORTINT (* Color and vertical offset of typed character. *)
+ END;
+
+ CaretMsg = RECORD ( Display.FrameMsg ) (* Text caret handling. *)
+ id: INTEGER; (* get, set, reset *)
+ car: Display.Frame; (* Destination frame, returned frame. *)
+ text: Texts.Text; (* Text represented by car. *)
+ pos: LONGINT (* Caret position. *)
+ END;
+
+ SelectMsg = RECORD ( Display.FrameMsg ) (* Text selection handling. *)
+ id: INTEGER; (* get, set, reset *)
+ time: LONGINT; (* Time of the selection. *)
+ sel: Display.Frame; (* Destination frame, returned frame. *)
+ text: Texts.Text; (* Text represented by sel. *)
+ beg, end: LONGINT (* Text stretch of the selection. *)
+ END;
+
+ ConsumeMsg = RECORD ( Display.FrameMsg ) (* Drag and drop control of text.
+*)
+ text: Texts.Text; (* Text to be inserted. *)
+ beg, end: LONGINT (* Text stretch to be inserted. *)
+ END;
+
+ RecallMsg = RECORD ( Display.FrameMsg )
+ END;
+
+ Task = POINTER TO TaskDesc;
+ Handler = PROCEDURE (me: Task);
+ TaskDesc = RECORD
+ next: Task; (* for internal use. *)
+ time: LONGINT; (* Earliest time to schedule task. *)
+ safe: BOOLEAN; (* Don't remove from task queue when a trap occurs. *)
+ handle: Handler (* Task handler. *)
+ END;
+
+ VAR
+ Arrow, Star: Marker; (* Normal Oberon arrow, and the star marker. *)
+ Mouse, Pointer: Cursor; (* Normal Oberon mouse, and the star pointer. *)
+ Log: Texts.Text; (* The Oberon log. *)
+ Par: ParList; (* Actual parameters of executed command. *)
+ CurFnt: Fonts.Font; (* Current input font when typing. *)
+ CurCol, CurOff: SHORTINT; (* Current color and offset when typing. *)
+ OptionChar: CHAR; (* Option character "/" or "" *)
+ OpenText: PROCEDURE (title: ARRAY OF CHAR; T: Texts.Text; W, H: INTEGER);
+ NextTask: Task; (* non-portable, for internal use. *)
+ New: BOOLEAN; (* enable new style mouse handling suitable for two-button
+mice *)
+
+(* Get time (t) and date (d). day = d MOD 32, month = d DIV 32 MOD 16, year
+= 1900+d DIV 512,
+ hour = t DIV 4096 MOD 32, minute = t DIV 64 MOD 64, second = t MOD 64 *)
+ PROCEDURE GetClock (VAR t, d: LONGINT);
+
+ (* Set time (t) and date (d). *)
+ PROCEDURE SetClock (t, d: LONGINT);
+
+ (* Return the number of timer ticks since Oberon startup. (See module Input
+for frequency) *)
+ PROCEDURE Time (): LONGINT;
+
+ (* Initialize a cursor, setting it to off, and at position 0, 0. *)
+ PROCEDURE OpenCursor (VAR c: Cursor);
+
+ (* Fade cursor if visible. *)
+ PROCEDURE FadeCursor (VAR c: Cursor);
+
+ (* Draw cursor c using marker m at position X, Y. *)
+ PROCEDURE DrawCursor (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER);
+
+(* Remove the caret by broadcasting a ControlMsg into the display space.
+Afterwards, no visual object should own either a caret for inserting text or
+objects. *)
+ PROCEDURE Defocus;
+
+(* Fade the mouse and pointer cursors if located inside the screen area X, Y,
+W, H.
+This is required before drawing inside the area X, Y, W, H. *)
+ PROCEDURE RemoveMarks (X, Y, W, H: INTEGER);
+
+(* Initialize a new display with user track width UW, system track width SW,
+
+and height H. The display is appended to the display space starting at X position
+
+Viewers.curW. Normally this procedure is only called once to configure the
+default layout of the Oberon screen. *)
+ PROCEDURE OpenDisplay (UW, SW, H: INTEGER); (* non-portable *)
+
+(* Returns the width in pixels of the display that contains the X coordinate.
+*)
+ PROCEDURE DisplayWidth (X: INTEGER): INTEGER;
+
+(* Returns the height in pixels of the display that contains the X coordinate.
+*)
+ PROCEDURE DisplayHeight (X: INTEGER): INTEGER;
+
+(* Open a new track of width W at X. *)
+ PROCEDURE OpenTrack (X, W: INTEGER);
+
+(* Get left margin of user track on display X. *)
+ PROCEDURE UserTrack (X: INTEGER): INTEGER;
+
+(* Get left margin of the system track on display X. *)
+ PROCEDURE SystemTrack (X: INTEGER): INTEGER;
+
+(* Allocate a new user viewer within the display located at DX. (X, Y)
+returns the suggested position. *)
+ PROCEDURE AllocateUserViewer (DX: INTEGER; VAR X, Y: INTEGER);
+
+(* Allocate a new system viewer within the display located at DX.
+(X, Y) returns the suggested position. *)
+ PROCEDURE AllocateSystemViewer (DX: INTEGER; VAR X, Y: INTEGER);
+
+(* Returns the star-marked viewer. *)
+ PROCEDURE MarkedViewer (): Viewers.Viewer;
+
+(* Returns the star-marked frame. *)
+ PROCEDURE MarkedFrame (): Display.Frame;
+
+(* Returns the text of the star-marked frame. *)
+ PROCEDURE MarkedText (): Texts.Text;
+
+(* Execute an Oberon command. Name should be a string of the form
+"M.P", where M is the module and P is the procedure of the command.
+Par is the command parameter record; it will be assigned to Oberon.Par
+so that the command can pick up its parameters. The new flag indicates
+if the module M should be reloaded from disk (obly possible if M is a "top"
+
+module, i.e. it has no clients. Res indicates success (res = 0) or failure (res
+# 0).
+Modules.resMsg contains an explanation of what went wrong when res # 0. *)
+ PROCEDURE Call (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
+
+(* Returns the selected stretch [beg, end[ of the current selected text T.
+Time indicates the time of selection; time = -1 indicates that no text is currently
+selected. *)
+ PROCEDURE GetSelection (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
+
+(* Install a background task. The background task is periodically activated
+
+by calling its handler when the system has nothing else to do. *)
+ PROCEDURE Install (T: Task);
+
+(* Remove a background task. *)
+ PROCEDURE Remove (T: Task);
+
+(* Request a garbage collection to be done. The GC will take place immediately.
+*)
+ PROCEDURE Collect;
+
+(* Set the default font used when typing characters. *)
+ PROCEDURE SetFont (fnt: Fonts.Font);
+
+(* Set the color of typed characters. *)
+ PROCEDURE SetColor (col: SHORTINT);
+
+(* Set the vertical offset of typed characters. *)
+ PROCEDURE SetOffset (voff: SHORTINT);
+
+(* Open a scanner at a specific section of the Oberon Text. Scans the first
+symbol in the section. Returns
+ S.class = Texts.Inval on error. *)
+ PROCEDURE OpenScanner (VAR S: Texts.Scanner; name: ARRAY OF CHAR);
+
+(* Main Oberon task dispatcher. Reads the mouse position and characters
+typed, informing the viewer of the display space of events using the
+Display.InputMsg. The loop broadcasts a ControlMsg (id = mark) when the
+marker is set. Pressing the neutralise key results in a ControlMsg (id = neutralize)
+
+to be broadcast. All frames receiving the neutralize message should remove
+selections and the caret. The Loop periodically activates background tasks and
+
+the garbage collector, if no mouse or keyboard events are arriving. *)
+ PROCEDURE Loop;
+END Oberon.
+
+(* Remarks:
+
+1. Command execution
+Execution of commands is the task of modules Module. Oberon.Call provides an
+
+abstraction for this mechanism and also a way to pass parameters in the form
+of
+a text to the executed command. After command execution, the global variable
+
+Oberon.Par is a pointer to a parameter record specifying a parameter text, a
+
+position in that text, and details what objects are involved in the commands.
+
+The vwr field of the ParRec points to the viewer in which the command was executed.
+
+The frame field of the ParRec points to the direct child of the vwr (the menu
+or the
+main frame) from which the command was executed. This semantics is compatible
+
+with older Oberon applications and is seldomly used today. The obj field of
+the
+ParRec points to the object (normally a frame) that executed the command.
+The Oberon.Par pointer is initialized before command execution to the parameter
+
+record passed to Oberon.Call.
+
+2. Cursors and Markers
+Markers are a way to draw and undraw a shape on the display. Typically, draw
+
+and undraw can be realized by an invert display operation. Cursors keep track
+of
+the current position and state (visible or not) of a marker. The Mouse cursor
+is the
+standard mouse arrow, and the Pointer cursor is the star marker placed with
+the
+Setup key. Repeatedly calling Oberon.DrawCursor with different coordinates move
+a
+cursor (and marker) across the display. Before drawing in a certain area of
+the
+display, cursors should be removed with Oberon.RemoveMarks or Oberon.FadeCursor
+
+(failingly to do so may result in the cursor leaving garbage on the display
+when
+drawing operations are performed in its vicinity). Note that on some Oberon
+host
+platforms (Windows, Mac, Unix) the mouse cursor is under control of the host
+
+windowing system, and is automatically faded when required. It is recommended
+
+to fade the cursor on these platforms anyway, as your Oberon programs will then
+
+also work on native Oberon systems.
+
+3. The InputMsg
+The InputMsg informs the frames of the display space of the current mouse position
+
+and character typed. It is repeatedly broadcast into the display space by the
+
+Oberon.Loop for each input event. An InputMsg id of Oberon.consume indicates
+a
+key was pressed. The ASCII keycode is contained in the ch field of the message
+
+(check the description of module Input for special keycodes). The fields fnt,
+col and
+voff give information about the requested font, color (index), and verticall
+offset
+(in pixels). These values are copied from hidden variables in the Oberon module,
+
+which are set with the procedures SetFont, SetColor, and SetOffset. Note that
+the
+TextGadgets ignore these fields when typing. Instead the font, color and vertical
+
+offset of the character immediately before the caret is used (thus the fields
+have
+fallen out of use). A frame should only process the consume message if it has
+the
+caret set. Afterwards the message should be invalidated by setting the message
+res
+field to 0 or a positive value. This prevents the character being consumed by
+other
+frames in the display space and also terminates the message broadcast.
+ An InputMsg id of track indicates a mouse event. The display space normally
+only
+ forwards this message to the frame located at position X, Y on the display.
+Field X, Y
+ indicates the absolute mouse position (cursor hotspot) and keys the mouse button
+
+ state (which mouse buttons are pressed). The mouse buttons are numbered 0,
+1, 2
+ for right, middle, and left respectively. It is typical for a frame receiving
+a track
+ message with keys # {} to temporarily taking control of the mouse by polling
+(using
+ module Input). As soon as all mouse buttons are released, control must be passed
+
+ back to the Oberon loop. A frame should invalidate the track message if it
+took
+ action on a mouse event; otherwise the enclosing frame might think that the
+message
+ could not be handled. In some cases a child frame takes no action on an event
+even
+ though a mouse buttton is pressed and the mouse is located inside the frame.
+This is
+ an indication that the child frame cannot or is unwilling to process the event,
+and
+ the parent (and forwarder of the message in the display space) should take
+a default
+ action. Note that during a tracking operation, no background tasks can be serviced.
+
+4. The ControlMsg
+The control message manages display space wide events like removing the (one
+and
+only) caret, pressing Neutralise (for removing the caret and the selections),
+and setting the
+star marker with the Setup key. The id field of the control message is set to
+defocus,
+neutralize, and mark respectively. Note that the mark variant need not be handled
+by
+own frames; it is already processed by the Viewers. Messages of this type must
+never
+be invalidated during their travels through the display space.
+
+5. The CaretMsg
+The CaretMsg controls the removing (id = reset), retrieving (id = get) and setting
+
+(id = set) of the caret on a frame to frame basis. All text editor-like frames
+should
+respond to this message. The car field of the message defines the editor frame
+involved
+for reset and set, and returns the editor frame that has the caret for get.
+The text field
+specifies which text is meant (or which text is returned for get). In the reset
+and set
+cases this field is mostly redundant but is checked for correctness ANYWAY.
+The pos
+field must be valid position in the text. The CaretMsg is always broadcast.
+
+6. The SelectMsg
+In a similar way as the CaretMsg, the SelectMsg controls the removing (id =
+reset),
+retrieving (id = get) and setting (id = set) of the selection. In this case,
+the sel field
+indicates the destination frame or returned frame, in a similar manner as the
+car
+field of the CaretMsg. The SelectMsg is extended with fields for specifying/retrieving
+
+the selection time, starting and ending position. The SelectMsg is always broadcast.
+
+7. Background tasks
+The handle procedure variable of installed background tasks are periodically
+called
+by the Oberon loop when the Oberon system is idle (no mouse or keyboard events).
+
+The task handlers have to be programmed in an inverted manner and should return
+
+as quickly as possible to the loop, otherwise the user will notice delays (typically
+
+when elapsed time is greater than 100-200ms). As tasks are activated periodically,
+
+a badly written task can cause a cascade of traps, one for each invocation.
+By default,
+the loop removes such a task that does not return from the task list (the safe
+flag
+prevents the loop from such an action). The garbage collector is realized as
+a task.
+A task can request to be invoked only at a specified time by setting the time
+field in
+the task descriptor. The time is measured according to Oberon.Time() at tick
+frequency
+specified by Input.TimeUnit. After each handler invocation, the task is expected
+to
+advance the time field to the next earliest event, overwise it will never be
+invoked in
+future. It is highly recommended to use this feature by specifying for tasks
+that are
+only invoked every few ms. This will save network traffic when using Oberon
+in an
+X-Window environment.
+
+8. The Oberon Loop
+The Oberon loop is called when the Oberon system starts, and never returns until
+
+the Oberon system is left. After a trap occurs, the run-time stack is reset,
+and the
+Oberon loop is started afresh. The Oberon loop polls the mouse and keyboard
+for
+events that it broadcasts to the display space using messages. When no events
+are
+happening, background tasks are activated periodically in a round-robin fashion.
+*)
diff --git a/examples/AGRS/Objects.Def b/examples/AGRS/Objects.Def
new file mode 100644
index 0000000..d4621f8
--- /dev/null
+++ b/examples/AGRS/Objects.Def
@@ -0,0 +1,460 @@
+(*
+https://web.archive.org/web/20041226165949/http://www.oberon.ethz.ch:80/ethoberon/defs/Objects.Def.html
+*)
+DEFINITION Objects; (* portable *)
+
+(* Module Objects forms the basis of the object-oriented part of the Oberon
+system.
+It provides the system with the type Object and defines what messages objects
+understand.
+Most entities in Oberon are derived from this base type.
+*)
+ IMPORT Files;
+
+ CONST
+ enum = 0; get = 1; set = 2; (* AttrMsg and LinkMsg id *)
+ shallow = 0; deep = 1; (* CopyMsg id *)
+ load = 0; store = 1; (* FileMsg id*)
+
+ (* AttrMsg class *)
+ Inval = 0; String = 2; Int = 3; Real = 4; LongReal = 5; Char = 6; Bool = 7;
+
+ TYPE
+ Name = ARRAY 32 OF CHAR;
+ Object = POINTER TO ObjDesc;
+ Dummy = POINTER TO DummyDesc;
+ Library = POINTER TO LibDesc;
+ ObjMsg = RECORD (* Base type of all messages sent to objects. *)
+ stamp: LONGINT; (* Message time stamp. *)
+ dlink: Object (* Sender of the message. *)
+ END;
+
+ Handler = PROCEDURE (obj: Object; VAR M: ObjMsg);
+ ObjDesc = RECORD (* Base type of all objects. *)
+ stamp: LONGINT; (* Time stamp of last message processed by object. *)
+ dlink, (* Next object in the message thread. *)
+ slink: Object; (* Next object in a list of objects. *)
+ lib: Library; ref: INTEGER; (* Library and reference number of object.
+*)
+ handle: Handler (* Message handler. *)
+ END;
+
+ (* Set, get and enumerate the attributes of an object. *)
+ AttrMsg = RECORD ( ObjMsg )
+ id: INTEGER; (* get, set or enum. *)
+ Enum: PROCEDURE (name: ARRAY OF CHAR); (* Called by object to enumerate
+attribute names. *)
+ name: Name; (* Name of the attribute to be set or retrieved. *)
+ res: INTEGER; (* Return result: < 0 = no response, >= 0 action completed.
+*)
+ class: INTEGER; (* Attribute class (Inval, String, Int, Real, LongReal,
+Char or Bool). *)
+ i: LONGINT;
+ x: REAL;
+ y: LONGREAL;
+ c: CHAR;
+ b: BOOLEAN;
+ s: ARRAY 64 OF CHAR
+ END;
+
+ (* Link objects with each other or retrieve the link structure between objects
+*)
+ LinkMsg = RECORD ( ObjMsg )
+ id: INTEGER; (* get, set or enum. *)
+ Enum: PROCEDURE (name: ARRAY OF CHAR); (* Called by object to enumerate
+link names. *)
+ name: Name; (* Link name. *)
+ res: INTEGER; (* Return result: < 0 = no response, >= 0 action completed.
+*)
+ obj: Object (* Value of the link to be set, or link result. *)
+ END;
+
+ (* Request to an object to make a copy of itself *)
+ CopyMsg = RECORD ( ObjMsg )
+ id: INTEGER; (* Copy style: deep or shallow. *)
+ obj: Object (* Result of the copy operation. *)
+ END;
+
+ (* Request to an object to bind itself to a library. *)
+ BindMsg = RECORD ( ObjMsg )
+ lib: Library (* Library where object should be bound. *)
+ END;
+
+ (* Request to an object to load/store itself. *)
+ FileMsg = RECORD ( ObjMsg )
+ id: INTEGER; (* load or store *)
+ len: LONGINT; (* Length of the object data on loading. *)
+ R: Files.Rider (* Rider with which to load or store data. *)
+ END;
+
+ (* Search request for an object with the specified name. *)
+ FindMsg = RECORD ( ObjMsg )
+ name: Name;
+ obj: Object (* Result object, if found. *)
+ END;
+
+ (* A placeholder object created for objects that cannot be loaded. *)
+ DummyDesc = RECORD ( ObjDesc )
+ GName: Name; (* Generator procedure of failed object. *)
+ END;
+
+ (* (Hidden) Data structure containing the objects of a library. *)
+ Index = POINTER TO IndexDesc;
+ IndexDesc = RECORD END;
+
+ (* (Hidden) Map of (ref) numbers and corresponding object names. *)
+ Dictionary = POINTER TO DictionaryDesc;
+ DictionaryDesc = RECORD END;
+
+ LibDesc = RECORD (* Container for persistent objects. *)
+ ind: Index; (* Library contents. *)
+ name: Name; (* name of the library. Private library when "", else public
+library. *)
+ dict: Dictionary; (* Object names. *)
+ maxref: INTEGER; (* Highest ref number used in library. *)
+
+ (* Return a free reference number. *)
+ GenRef: PROCEDURE (L: Library; VAR ref: INTEGER);
+
+ (* Return the object with the indicated reference number. *)
+ GetObj: PROCEDURE (L: Library; ref: INTEGER; VAR obj: Object);
+
+ (* Insert an object under the indicated reference number. *)
+ PutObj: PROCEDURE (L: Library; ref: INTEGER; obj: Object);
+
+ (* Free object with indicated reference number. *)
+ FreeObj: PROCEDURE (L: Library; ref: INTEGER);
+
+ (* Initialize/load library with L.name. *)
+ Load: PROCEDURE (L: Library);
+
+ (* Store library under L.name. *)
+ Store: PROCEDURE (L: Library)
+ END;
+
+ NewProc = PROCEDURE (): Library; (* Library generator. *)
+ EnumProc = PROCEDURE (L: Library); (* Enumerator of public libraries *)
+
+ VAR
+ LibBlockId: CHAR; (* Identification character as first character of a Library
+file. *)
+ NewObj: Object; (* Newly generated objects are returned here. *)
+ PROCEDURE Stamp (VAR M: ObjMsg); (* Timestamp a message. *)
+
+(* Search, load and cache a public library. *)
+ PROCEDURE ThisLibrary (name: ARRAY OF CHAR): Library;
+
+(* Free library from public library cache *)
+ PROCEDURE FreeLibrary (name: ARRAY OF CHAR);
+
+(* Enumerate public libraries. Don't free libraries during enumeration! *)
+ PROCEDURE Enumerate (P: EnumProc);
+
+(* Register a new library file extension and its associated generator procedure.
+*)
+ PROCEDURE Register (ext: ARRAY OF CHAR; new: NewProc);
+
+(* Load a standard object library from position pos in file f. *)
+ PROCEDURE LoadLibrary (L: Library; f: Files.File; pos: LONGINT; VAR len: LONGINT);
+
+(* Store a standard object library at position pos in file f. *)
+ PROCEDURE StoreLibrary (L: Library; f: Files.File; pos: LONGINT; VAR len: LONGINT);
+
+(* Initialize a standard object library. *)
+ PROCEDURE OpenLibrary (L: Library);
+
+(* Given an object name, return the object reference number from the dictionary.
+*)
+ PROCEDURE GetRef (VAR D: Dictionary; name: ARRAY OF CHAR; VAR ref: INTEGER);
+
+(* Allocate a key (any integer < 0) to a name. *)
+ PROCEDURE GetKey (VAR D: Dictionary; name: ARRAY OF CHAR; VAR key: INTEGER);
+
+(* Get name associated with a key/reference number. *)
+ PROCEDURE GetName (VAR D: Dictionary; key: INTEGER; VAR name: ARRAY OF CHAR);
+
+(* Associate a name with a reference number. *)
+ PROCEDURE PutName (VAR D: Dictionary; key: INTEGER; name: ARRAY OF CHAR);
+
+END Objects.
+
+(* Remarks:
+
+1. Objects and Messages
+Objects and the messages sent to them are both types in the Oberon system. Just
+as we can extend an object by defining an object-subtype, we can extend a message
+by defining a message sub-type. As root of the object and message type hierarchies
+we have the types Objects.Object and Object.ObjMsg respectively. We will refering
+to extensions of these types as Objects and Messages respectively. This way
+of organizing things allows us to send a message of any type to an object of
+any type (even when the receiving object might not make sense of the message).
+As an examples of an object we can mention the Frames of module Display (visual
+objects). Frames have a set of associated messages called frame messages (i.e.
+messages sent to frames). A base type called Display.FrameMsg is an extension
+of Object.ObjMsg and the base of the frame messages. The module Objects define
+the object messages, i.e. the messages that all objects understand. Objects
+are allocated on the heap and messages temporarily on the stack.
+
+2. Message Handlers
+Message handlers process the message sent to an object. A message handler is
+a procedure with the definition Objects.Handler. A message handler receives
+as first parameter the object the message is sent to, and as second parameter
+the message itself. The message handler does message type tests to discrimate
+between the different message types it receives, and acts accordingly to each
+message type (most of the actions are prescribed the messages defined in modules
+like Objects and Display). The message handler of a newly created object is
+"installed" in an object by assigning it to the field handle of the object.
+A typical handler might look as follows:
+
+ PROCEDURE MyHandler(obj: Object; VAR M: ObjMsg);
+ BEGIN
+ IF M IS Objects.AttrMsg THEN
+ WITH M: Objects.AttrMsg DO
+ ...
+ END
+ ELSIF M IS Objects.CopyMsg THEN
+ WITH M: Objects.CopyMsg DO
+ ...
+ END
+ ELSE
+ (* message not understood by handler. *)
+ END
+ END MyHandler;
+
+To create a new object, we first have to introduce a new object type, allocate
+a new instance on the heap and attach the message handler:
+
+ TYPE
+ MyObj = POINTER TO MyObjDesc;
+ MyObjDesc = RECORD (Objects.ObjDesc) (* Extension of Objects.ObjDesc. *)
+ A, B: LONGINT; (* Object instance variables. *)
+ END;
+
+ PROCEDURE CreateObj;
+ VAR obj: MyObj;
+ BEGIN
+ NEW(obj); (* allocate a new object on the heap *)
+ obj.handle := MyHandler; (* attach the message handler. *)
+ END CreateObj;
+
+Here we created a new object type with two additional instance variables A and
+B. To open up access to the instance variables in the message handler, we will
+need to modify the message handler slightly:
+
+ PROCEDURE MyHandler(obj: Object; VAR M: ObjMsg);
+ BEGIN
+ WITH obj: MyObj DO (* Open up access to the instance variables of MyObj. *)
+ IF M IS Objects.AttrMsg THEN
+ WITH M: Objects.AttrMsg DO
+ ...
+ END
+ ELSIF M IS Objects.CopyMsg THEN
+ WITH M: Objects.CopyMsg DO
+ ...
+ END
+ ELSE
+ (* message not understood by handler. *)
+ END
+ END
+ END MyHandler;
+
+This change also means that MyHandler can only be safely attached to objects
+(or extensions) of type MyObj; attaching the handler to objects of other types
+will cause a runtime exception (trap) when trying to open access to the fields
+of MyObj. Sending a message to an object involves allocating it on the stack,
+filling out the message fields, and calling the object message handler. For
+example:
+
+ VAR obj: MyObj;
+
+ PROCEDURE GetName;
+ VAR M: Objects.AttrMsg; (* Allocate message on the stack. *)
+ BEGIN
+ M.id := Objects.get; M.name := "Name"; M.res := -1; (* Fill out message fields
+*)
+ obj.handle(obj, M); (* Send message. *)
+ Out.String(M.s); Out.Ln; (* Process result. *)
+ END GetName;
+
+You are allowed to define new message types for your own objects, in a similar
+manner as shown in the message definitions above. Note how many of the messages
+have id fields; these indicate different sub-operations a message requests.
+The id values are declared per message as INTEGER constants at the beginning
+of the module.
+
+3. Forwarding and Broadcasts
+Objects may forward messages to other objects. This is typically done when an
+object cannot handle a message itself or does not even know the message. Sometimes
+messages are sent in such a way that each object does some handle of a message,
+and then forwards it anyway to all other objects it controls. This we call message
+broadcasting. Messages thus pass from one object to another in ways only known
+to the objects themselves. The route a message follows we call the message path.
+
+4. Time stamps
+During a message broadcast, more than one message path may lead to the same
+object, resulting in the object receiving a the message many times (i.e. exactly
+once for each message path). To allow an object to determine if it has already
+processed a message, each message that is broadcast is given a timestamp. The
+receiving object remembers the message timestamp in its field stamp, and can
+compare it against a later message received. Due to message broadcasts occuring
+during a message broadcast itself (i.e. recursive broadcasts), you should not
+assume that message arrive in time stamp sequence. The stamp is a LONGINT value
+incremented on each broadcast by the procedure Stamp.
+
+5. The Message Thread
+The message thread informs an object of the path a message followed to reach
+it, and can be used to implement path dependent behaviour. The dlink field in
+the ObjMsg points to the last forwarder of the message. The dlink field of the
+latter object contains the previous object in the path, and so onwards until
+the beginning of the path (the thread points backwards). Due to recursive message
+broadcasts the dlink field in the message and the objects themselves should
+be saved on the stack before the values are changed:
+
+ (* Forward a message from one object to another. *)
+ PROCEDURE SendMsg(from, to: Objects.Object; VAR M: Objects.ObjMsg);
+ VAR p, p0; Objects.Object;
+ BEGIN
+ p := from.dlink; p0 := M.dlink; (* save *)
+ from.dlink := M.dlink; (* hook sender in dlink chain *)
+ M.dlink := from; (* set sender of the message *)
+ to.handle(to, M);
+ from.dlink := p; M.dlink := p0 (* restore *)
+ END SendMsg;
+
+A message sender may refuse to add itself to the message thread (for optimization
+purposes). This has no effect but to make it invisible to further recipients
+in the message path. The message thread is typically used in the display space
+(see module Display) to find out how a message travelled from the display root
+to an object located somewhere in the display space.
+
+6. The slink field
+The slink field links objects together in a list so that they can be passed
+around as a group. Never assume that the slink list remains the same before
+and after a message broadcast.
+
+7. Libraries
+Libraries are indexed collections of objects. An object belonging to a library
+is said to be bound to the library (otherwise it is free). When bound, an objects
+obtains an index or reference number (>= 0) in its library (and its lib and
+ref fields are set accordingly). The Objects module implements the standard
+object libraries. These allow you to store the library and its contents in an
+atomic action to disk. On disk, reference numbers instead of pointers are used
+to refer to objects. Thus pointers and reference numbers are swizzled (exchanged)
+when loading or storing libraries. The procedures Gadgets.ReadRef and Gadgets.WriteRef
+use the library mechanism to transparently read and write object pointers to
+disk. The library dictionary mechanism allows you to attach names to objects
+(more concretely to reference numbers). An object belonging to public library
+L and having the name O in the dictionary, is refered to as "L.O" (note the
+similarity with "M.P"). Sometimes the dictionary is also used to attach keys
+(< 0) to strings. Keys are used to save string space when storing libraries.
+Libraries are divided into public and private libraries. Public libraries are
+named (i.e. L.name # "") and are cached in memory on loading. The garbage collector
+will uncache a library automatically if it is not required any more. The Libraries.Panel
+allow you to manipulate the contents of public libraries. Private libraries
+are primarily used as a means to make objects persistent in documents and are
+never cached. The default public library file extension is "Lib". It is possible
+to add new types of libraries by registering new library extensions and the
+associated library generator.
+
+8. The Object Messages
+All objects should implement handlers for the so-called object messages defined
+in this module. The object messages are the LinkMsg (for structure building
+and exploration), the CopyMsg (for copying an object), the BindMsg (for binding
+an object to a library), the AttrMsg (for setting and getting attributes), the
+FileMsg (for loading and storing), and the FindMsg (for locating named objects).
+
+9. The LinkMsg
+The LinkMsg is used to link objects between each other i.e. setting a pointer
+in one object to point to another. The links must be identified by name. Most
+displayable gadgets have a "Model" link that points to a model gadget.
+
+10. The CopyMsg
+Shallow copy means copying an object but reusing its descendants, and deep copy
+means copying all objects reachable from a certain root object. Due to the DAG
+nature of the display space, the deep copy message arrives once or more times
+at an object, in which case it only should copy itself once to guarantee structure
+preserving copies. The following shows that an object should cache the first
+copy that it makes of itself in the dlink field, which is then returned on receiving
+the message a second time:
+
+ VAR F0: Frame; (* the copy goes here *)
+
+ IF M IS Objects.CopyMsg THEN
+ WITH M: Objects.CopyMsg DO
+ IF M.stamp = F.stamp THEN M.obj := F.dlink (* copy msg arrives again *)
+ ELSE (* first time copy message arrives *)
+ NEW(F0); F.stamp := M.stamp; F.dlink := F0; CopyFrame(M, F, F0); M.obj
+:= F0
+ END
+ END
+ END
+
+11. The BindMsg
+The BindMsg is a request to an object to bind itself to a library. By convention,
+an object can migrate from library to library, except when bound to a public
+library. Binding allocates a reference number to an object which is conveniently
+used as a pointer alias between objects stored in a file.
+
+ PROCEDURE BindObj(obj: Objects.Object; lib: Objects.Library);
+ VAR ref: INTEGER; name: ARRAY 32 OF CHAR;
+ BEGIN
+ IF lib # NIL THEN
+ IF (obj.lib = NIL) OR (obj.lib.name[0] = 0X) & (obj.lib # lib) THEN (* free,
+or belongs to a private library *)
+ lib.GenRef(lib, ref); (* allocate reference number *)
+ IF ref >= 0 THEN (* successful *)
+ lib.PutObj(lib, ref, obj);
+ END
+ END
+ END
+ END BindObj;
+
+12. The AttrMsg
+The attribute message is used to enumerate, set or retrieve an object attribute.
+The class field of the AttrMsg indicate what the type of an attribute is. Each
+object should have a Name attribute and a Gen attribute (both of type String).
+The name attribute refers to the intrinsic name of an object (it should not
+be confused with the name the object might have in a dictionary). Copying an
+object results in two objects with the same names. The FindMsg locates an object
+with a certain intrinsic name. The Gen attribute indicates the name of the object
+generator (in the form "M.P"). Calling the generator of an object results in
+the freshly created object attached to Objects.NewObj, from where it is picked
+up by commands like Gadgets.Insert.
+
+13. The FileMsg
+The FileMsg is a request to an object to write or read its state to or from
+a Rider. An object should always read and write the same number of bytes, otherwise
+traps may result. It is recommended to use version numbers to distinguish objects
+of different generations from each other and so allow for smooth upgrading to
+new file formats for older objects. The FileMsg is typically used when reading
+or writing a library from or to disk.
+
+14. The FindMsg
+The FindMsg is a request to an object to locate the object with the indicated
+intrinsic name. Should an object not know of an object with such a name, it
+should forward the message to all objects it controls (children). By convention,
+searching should be done in a bread-first manner between descendants of a container.
+
+15. Keys
+Each library has a dictionary of (key, name) pairs. The key is either positive
+or zero, in which case it is regarded as a reference number in the library (with
+associated object name), or negative, in which case it is simply a short way
+of refering to a string (an atom). The latter reduces the space used when the
+same string appears many times in a library file.
+
+16. Dummies
+Dummies are objects created in place of objects that cannot be loaded into memory
+(module missing). Pointers to Dummies are often set to NIL by the application
+itself.
+
+17. Extended Libraries
+It is possible to add new library types to the system. New types are distinguished
+by filename extensions that are registered by Objects.Register. The NewProc
+is called by Objects.ThisLibrary to create an empty instance of the new library
+type. The name field is filled in, after which the Load procedure of the library
+is called to load the library from disk. In accordance, the Store procedure
+stores the library under its name to disk. The LoadLibrary and StoreLibrary
+procedures implement the default behaviour for the standard object libraries.
+
+*)
+
diff --git a/examples/AGRS/Parser.Mod b/examples/AGRS/Parser.Mod
new file mode 100644
index 0000000..d5831bc
--- /dev/null
+++ b/examples/AGRS/Parser.Mod
@@ -0,0 +1,802 @@
+MODULE Parser;
+IMPORT AGRS,Names,Library,Texts,SYSTEM;
+
+
+CONST
+ MaxStrLength= 60;
+ SetBits*= MAX(SET)+1;
+
+TYPE
+
+ ParserProc= PROCEDURE(VAR r:Texts.Reader; l:LONGINT): AGRS.Term;
+ ParseWrapper*= POINTER TO RECORD(AGRS.TermDesc)
+ handler*: ParserProc;
+ END;
+
+VAR
+ sentenceName*,spaceCharsName*,customParsersName*,parseName*: AGRS.Name;
+ temp,buildingName*,rulesName,varName,blockName,className: AGRS.Name;
+
+ sentenceParser*,attributeParser*,standardParser,customParser: ParseWrapper;
+ rulesParser,varParser,blockParser,classParser: ParseWrapper;
+ numberParser,stringParser,charParser,charSetParser: ParseWrapper;
+
+ sentence: Texts.Text; (* Tekst koji se parsira. *)
+ spaceChars: Library.CharSet; (* Delimiteri. *)
+ collection: AGRS.ClosedClass; (* CustomParsers znacenje. *)
+ idTerm: AGRS.Term;
+
+ attrPosition: INTEGER; (* Redni broj trenutnog atributa. *)
+
+
+PROCEDURE Rewind*(VAR rd: Texts.Reader; newPos: LONGINT);
+BEGIN
+ Texts.OpenReader(rd,sentence,newPos);
+END Rewind;
+
+
+PROCEDURE BackSpace(VAR rd: Texts.Reader);
+BEGIN
+ Texts.OpenReader(rd,sentence,Texts.Pos(rd)-1);
+END BackSpace;
+
+
+PROCEDURE ParseEmpty*(VAR rd: Texts.Reader; limit: LONGINT): BOOLEAN;
+VAR
+ ch: CHAR;
+BEGIN
+ WHILE ~rd.eot & (Texts.Pos(rd)<limit) DO
+ Texts.Read(rd,ch);
+ IF (rd.elem=NIL) & ~(ORD(ch) MOD SetBits IN
+ spaceChars.value[ORD(ch) DIV SetBits]) THEN
+ BackSpace(rd);
+ RETURN FALSE
+ END;
+ END;
+ RETURN TRUE
+END ParseEmpty;
+
+
+PROCEDURE ExactParse(parser: ParserProc; VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ result: AGRS.Term;
+BEGIN
+ result:= parser(rd,limit);
+ IF (result.indirection#AGRS.failName) & ParseEmpty(rd,limit) THEN
+ RETURN result
+ ELSE
+ RETURN AGRS.Failure
+ END
+END ExactParse;
+
+
+PROCEDURE ScanCharacter(chSeek: CHAR;
+ VAR rd: Texts.Reader; limit: LONGINT): BOOLEAN;
+VAR
+ chRead: CHAR;
+BEGIN
+ WHILE Texts.Pos(rd)<limit DO
+ Texts.Read(rd,chRead);
+ IF chSeek=chRead THEN
+ RETURN TRUE
+ END;
+ END;
+ RETURN FALSE
+END ScanCharacter;
+
+
+PROCEDURE ParseTheCharacter(chExpect: CHAR;
+ VAR rd: Texts.Reader; limit: LONGINT): BOOLEAN;
+VAR
+ chRead: CHAR;
+BEGIN
+ IF Texts.Pos(rd)<limit THEN
+ Texts.Read(rd,chRead);
+ IF chExpect=chRead THEN
+ RETURN TRUE
+ END;
+ END;
+ RETURN FALSE
+END ParseTheCharacter;
+
+
+PROCEDURE ParseTheString*(strExpect: ARRAY OF CHAR;
+ VAR rd: Texts.Reader; limit: LONGINT): BOOLEAN;
+VAR
+ chRead: CHAR;
+ i: INTEGER;
+BEGIN
+ i:= 0;
+ WHILE (Texts.Pos(rd)<limit) & (i<LEN(strExpect))
+ & (strExpect[i]#0X) DO
+ Texts.Read(rd,chRead);
+ IF strExpect[i]#chRead THEN
+ RETURN FALSE
+ END;
+ INC(i);
+ END;
+ RETURN strExpect[i]=0X
+END ParseTheString;
+
+
+PROCEDURE ParseNumber(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ ch: CHAR;
+ minus: BOOLEAN;
+ x: INTEGER;
+BEGIN
+ Texts.Read(rd,ch);
+ IF ch='-' THEN
+ minus:= TRUE;
+ Texts.Read(rd,ch);
+ ELSE
+ minus:= FALSE;
+ IF ch='+' THEN
+ Texts.Read(rd,ch);
+ END
+ END;
+ IF (ch<'0') OR (ch>'9') THEN
+ RETURN AGRS.Failure
+ END;
+ x:= 0;
+ WHILE (ch>='0') & (ch<='9') & (Texts.Pos(rd)<=limit) DO
+ IF x <= (MAX(INTEGER)-ORD(ch)+ORD('0')) DIV 10 THEN
+ x:= 10*x+ORD(ch)-ORD('0');
+ END;
+ Texts.Read(rd,ch);
+ END;
+ IF minus THEN
+ x:= -x;
+ END;
+ BackSpace(rd);
+ RETURN Library.NewNumber(x)
+END ParseNumber;
+
+
+PROCEDURE ParseChar(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ delimiter,chRead: CHAR;
+BEGIN
+ Texts.Read(rd,delimiter);
+ IF delimiter = "'" THEN
+ Texts.Read(rd,chRead);
+ Texts.Read(rd,delimiter);
+ IF (delimiter="'") & (Texts.Pos(rd)<=limit) THEN
+ RETURN Library.NewChar(chRead)
+ END;
+ END;
+ RETURN AGRS.Failure
+END ParseChar;
+
+
+PROCEDURE ParseCharSet(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ ch,second: CHAR;
+ s: Library.CharSet;
+ complement: BOOLEAN;
+BEGIN
+ Texts.Read(rd,ch);
+ IF ch='~' THEN
+ complement:= TRUE;
+ Texts.Read(rd,ch);
+ ELSE
+ complement:= FALSE;
+ END;
+ IF ch#'{' THEN
+ RETURN AGRS.Failure
+ END;
+ IF ParseEmpty(rd,limit) THEN
+ RETURN AGRS.Failure
+ END;
+ s:= Library.NewCharSet();
+ Texts.Read(rd,ch);
+ IF ch#'}' THEN
+ LOOP
+ IF ch='\' THEN
+ Texts.Read(rd,ch);
+ CASE ch OF
+ |'0': ch:= 0X;
+ |'s','S': ch:= ' ';
+ |'t','T': ch:= 9X;
+ |'n','N':
+ ch:= 0DX;
+ s.Include(0AX);
+ ELSE
+ RETURN AGRS.Failure;
+ END;
+ END;
+ Texts.Read(rd,second);
+ IF second='-' THEN
+ Texts.Read(rd,second);
+ IF second<ch THEN
+ RETURN AGRS.Failure
+ END;
+ WHILE ch<=second DO
+ s.Include(ch);
+ ch:= CHR(ORD(ch)+1);
+ END;
+ Texts.Read(rd,second);
+ ELSE
+ s.Include(ch);
+ END;
+ IF second#',' THEN
+ IF second='}' THEN
+ EXIT
+ ELSE
+ RETURN AGRS.Failure
+ END;
+ END;
+ IF ParseEmpty(rd,limit) THEN
+ RETURN AGRS.Failure
+ END;
+ Texts.Read(rd,ch);
+ END;
+ END;
+ IF Texts.Pos(rd)>limit THEN
+ RETURN AGRS.Failure
+ END;
+ IF complement THEN
+ s.Complement();
+ END;
+ RETURN s
+END ParseCharSet;
+
+
+PROCEDURE ParseIdentifier*(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ wd: AGRS.Name;
+ str: ARRAY MaxStrLength OF CHAR;
+ ch: CHAR;
+ i: INTEGER;
+BEGIN
+ i:= 0;
+ REPEAT
+ Texts.Read(rd,ch);
+ str[i]:= ch;
+ INC(i);
+ UNTIL (ch<'0') OR (CAP(ch)>'Z') OR
+ ((ch>'9') & (CAP(ch)<'A')) OR (Texts.Pos(rd)>limit);
+ IF i=1 THEN
+ RETURN AGRS.Failure;
+ END;
+ BackSpace(rd);
+ str[i-1]:= 0X;
+ wd:= Names.FindPublicName(str);
+ IF wd=NIL THEN
+ Names.AddArgument(wd,str);
+ END;
+ RETURN wd
+END ParseIdentifier;
+
+
+PROCEDURE ParseString(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ ch,between: CHAR;
+ str: ARRAY MaxStrLength OF CHAR;
+ length: INTEGER;
+BEGIN
+ Texts.Read(rd,between);
+ IF (between="'") OR (between='"') THEN
+ length:= 0;
+ Texts.Read(rd,ch);
+ WHILE (ch#between) & (ch#0DX) & (length<MaxStrLength)
+ & (Texts.Pos(rd)<limit) DO
+ str[length]:= ch;
+ INC(length);
+ Texts.Read(rd,ch);
+ END;
+ IF ch=between THEN
+ str[length]:= 0X;
+ RETURN Library.NewString(Names.NewStringCopy(str))
+ END;
+ END;
+ RETURN AGRS.Failure
+END ParseString;
+
+
+PROCEDURE ParseCustom(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ id,result: AGRS.Term;
+ startPos: LONGINT;
+
+
+BEGIN
+ startPos:= Texts.Pos(rd);
+ id:= ParseIdentifier(rd,limit);
+ Rewind(rd,startPos);
+ IF id.indirection=AGRS.failName THEN
+ RETURN AGRS.Failure
+ END;
+ sentenceName.Assign(Library.SubText(sentence,startPos,limit));
+ idTerm.Init(id);
+ result:= customParsersName.Evaluate(idTerm);
+ sentenceName.Restore();
+ Rewind(rd,limit);
+ RETURN result
+END ParseCustom;
+
+
+PROCEDURE ParseSentence(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ result: AGRS.Term;
+ startPos,endPos: LONGINT;
+
+ PROCEDURE ParseSequence(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+ VAR
+ first,rest: AGRS.Term;
+ newTerm: AGRS.SubTerm;
+ scanner: Texts.Reader;
+ BEGIN
+ startPos:= Texts.Pos(rd);
+ Rewind(scanner,startPos);
+ WHILE ScanCharacter(';',scanner,limit) DO
+ Rewind(rd,startPos);
+ first:= ParseCustom(rd,Texts.Pos(scanner)-1);
+ IF first.indirection#AGRS.failName THEN
+ Rewind(rd,Texts.Pos(scanner));
+ IF ~ParseEmpty(rd,limit) THEN
+ rest:= ParseSequence(rd,limit);
+ IF rest.indirection#AGRS.failName THEN
+ NEW(newTerm);
+ newTerm.Init(first);
+ newTerm.InitQuery(rest);
+ RETURN newTerm
+ END;
+ END;
+ END;
+ END;
+ Rewind(rd,startPos);
+ Rewind(scanner,startPos);
+ WHILE ScanCharacter(')',scanner,limit) DO
+ endPos:= Texts.Pos(scanner);
+ END;
+ RETURN ParseSentence(rd,endPos-1);
+ END ParseSequence;
+BEGIN
+ startPos:= Texts.Pos(rd);
+ result:= ExactParse(ParseChar,rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ RETURN result
+ END;
+ Rewind(rd,startPos);
+ result:= ExactParse(ParseString,rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ RETURN result
+ END;
+ Rewind(rd,startPos);
+ result:= ExactParse(ParseNumber,rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ RETURN result
+ END;
+ Rewind(rd,startPos);
+ result:= ExactParse(ParseCharSet,rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ RETURN result
+ END;
+ Rewind(rd,startPos);
+ result:= ParseCustom(rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ RETURN result
+ END;
+ IF ParseTheCharacter('(',rd,limit) & ~ParseEmpty(rd,limit) THEN
+ result:= ParseSequence(rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ IF ~ParseEmpty(rd,limit) THEN
+ IF ParseTheCharacter(')',rd,limit) THEN
+ RETURN result
+ END;
+ END;
+ END;
+ END;
+ RETURN AGRS.Failure
+END ParseSentence;
+
+
+PROCEDURE ParseAttribute(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ startPos: LONGINT;
+ id,meaning,built: AGRS.Term;
+ newTerm: AGRS.Tree;
+ attrPos: INTEGER;
+BEGIN
+ startPos:= Texts.Pos(rd);
+ id:= ParseIdentifier(rd,limit);
+ IF (id.indirection#AGRS.failName) & ~ParseEmpty(rd,limit)
+ & ParseTheCharacter('=',rd,limit) & ~ParseEmpty(rd,limit) THEN
+ meaning:= ParseSentence(rd,limit);
+ IF meaning.indirection=AGRS.failName THEN
+ RETURN AGRS.Failure
+ END;
+ ELSIF attrPosition>0 THEN
+ Rewind(rd,startPos);
+ IF ParseEmpty(rd,limit) THEN
+ RETURN AGRS.Failure
+ END;
+ attrPos:= attrPosition;
+ meaning:= ParseSentence(rd,limit);
+ IF meaning.indirection=AGRS.failName THEN
+ RETURN AGRS.Failure
+ END;
+ id:= Names.FindOrdinalName(attrPos);
+ ELSE
+ RETURN AGRS.Failure
+ END;
+ built:= buildingName.indirection;
+ WITH built: AGRS.Tree DO
+ built.AddProperty(id(AGRS.Name),meaning);
+ RETURN built
+ ELSE
+ NEW(newTerm);
+ newTerm.Init(built);
+ newTerm.AddProperty(id(AGRS.Name),meaning);
+ RETURN newTerm
+ END;
+END ParseAttribute;
+
+
+PROCEDURE ParseProperties(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ startPos: LONGINT;
+ attrPos: INTEGER;
+ result: AGRS.Term;
+ attributeReader: Texts.Reader;
+BEGIN
+ startPos:= Texts.Pos(rd);
+ IF ParseTheCharacter(')',rd,limit) THEN
+ RETURN buildingName.indirection
+ END;
+ attrPos:= attrPosition+1;
+ Rewind(rd,startPos);
+ WHILE ScanCharacter(',',rd,limit) DO
+ attrPosition:= attrPos;
+ Rewind(attributeReader,startPos);
+ result:= ParseAttribute(attributeReader,Texts.Pos(rd)-1);
+ IF result.indirection#AGRS.failName THEN
+ IF ParseEmpty(rd,limit) THEN
+ RETURN AGRS.Failure
+ END;
+ attrPosition:= attrPos;
+ buildingName.Assign(result);
+ result:= ParseProperties(rd,limit);
+ buildingName.Restore();
+ IF result.indirection#AGRS.failName THEN
+ RETURN result
+ END;
+ END;
+ END;
+ Rewind(rd,startPos);
+ Rewind(attributeReader,startPos);
+ WHILE ScanCharacter(')',rd,limit) DO
+ startPos:= Texts.Pos(rd);
+ END;
+ attrPosition:= attrPos;
+ RETURN ParseAttribute(attributeReader,startPos-1)
+END ParseProperties;
+
+
+PROCEDURE ParseStandard(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ id,result: AGRS.Term;
+ startPos: LONGINT;
+ result1: AGRS.SubTerm;
+ result2: AGRS.Field;
+ result3: AGRS.Tree;
+BEGIN
+ id:= ParseIdentifier(rd,limit);
+ IF id.indirection=AGRS.failName THEN
+ RETURN AGRS.Failure
+ END;
+ IF ParseEmpty(rd,limit) THEN
+ RETURN id
+ END;
+ startPos:= Texts.Pos(rd);
+ IF ParseTheCharacter('.',rd,limit) THEN
+ result:= ParseStandard(rd,limit);
+ IF result.indirection#AGRS.failName THEN
+ IF (result IS AGRS.Name) OR (result IS AGRS.Field) THEN
+ NEW(result2);
+ result2.Init(id);
+ result2.InitQuery(result);
+ RETURN result2
+ ELSE
+ NEW(result1);
+ result1.Init(id);
+ result1.InitQuery(result);
+ RETURN result1
+ END;
+ END;
+ RETURN AGRS.Failure
+ ELSE
+ Rewind(rd,startPos);
+ IF ParseTheCharacter('(',rd,limit) THEN
+ IF ParseEmpty(rd,limit) THEN
+ RETURN AGRS.Failure
+ END;
+ startPos:= Texts.Pos(rd);
+ IF ParseTheCharacter(')',rd,limit) THEN
+ NEW(result);
+ result.Init(id);
+ ELSE
+ Rewind(rd,startPos);
+ NEW(result3);
+ result3.Init(id);
+ buildingName.Assign(result3);
+ attrPosition:= 0;
+ result:= ParseProperties(rd,limit);
+ buildingName.Restore();
+ END;
+ RETURN result
+ ELSE
+ Rewind(rd,startPos);
+ RETURN id
+ END;
+ END;
+END ParseStandard;
+
+
+PROCEDURE ParseRule(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ startPos: LONGINT;
+ lhs,rhs,rest: AGRS.Term;
+ ruleReader: Texts.Reader;
+BEGIN
+ startPos:= Texts.Pos(rd);
+ WHILE ScanCharacter('=',rd,limit) DO
+ Rewind(ruleReader,startPos);
+ lhs:= ParseStandard(ruleReader,Texts.Pos(rd)-1);
+ IF (lhs.indirection#AGRS.failName)
+ & ~ParseEmpty(ruleReader,limit)
+ & ParseTheCharacter('=', ruleReader,limit)
+ & ~ParseEmpty(ruleReader,limit) THEN
+ startPos:= Texts.Pos(ruleReader);
+ WHILE ScanCharacter(',',rd,limit) DO
+ Rewind(ruleReader,startPos);
+ rhs:= ParseSentence(ruleReader,Texts.Pos(rd)-1);
+ IF (rhs.indirection#AGRS.failName)
+ & ~ParseEmpty(ruleReader,limit)
+ & ParseTheCharacter(',', ruleReader,limit)
+ & ~ParseEmpty(ruleReader,limit) THEN
+ rest:= ParseRule(ruleReader,limit);
+ IF rest.indirection#AGRS.failName THEN
+ Rewind(rd,Texts.Pos(ruleReader));
+ RETURN AGRS.MakeAlternative(lhs,rhs) (* ,rest *)
+ END;
+ END;
+ END;
+ Rewind(rd,startPos);
+ Rewind(ruleReader,startPos);
+ WHILE ScanCharacter(')',rd,limit) DO
+ startPos:= Texts.Pos(rd);
+ END;
+ rhs:= ParseSentence(ruleReader,startPos-1);
+ IF rhs.indirection=AGRS.failName THEN
+ RETURN AGRS.Failure
+ END;
+ IF lhs IS AGRS.Name THEN
+ RETURN rhs
+ ELSE
+ RETURN AGRS.MakeAlternative(lhs,rhs) (* ,NIL *)
+ END;
+ END;
+ END;
+ RETURN AGRS.Failure
+END ParseRule;
+
+
+PROCEDURE ParseRules(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+BEGIN
+ IF ParseTheString('RULE',rd,limit) & ~ParseEmpty(rd,limit)
+ & ParseTheCharacter('(',rd,limit) & ~ParseEmpty(rd,limit) THEN
+ RETURN ParseRule(rd,limit)
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END ParseRules;
+
+PROCEDURE ParseVar(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+BEGIN
+ IF ParseTheString('VAR',rd,limit) THEN
+ RETURN AGRS.Variable
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END ParseVar;
+
+PROCEDURE ParseBlock(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ startPos: LONGINT;
+ rest,id: AGRS.Term;
+ vars: AGRS.Tree;
+BEGIN
+ IF ParseTheString('LOCAL',rd,limit) THEN
+ Names.LocalBlock;
+(* Names.LocalNames; *)
+ NEW(vars);
+ vars.Init(Names.SystemRoot);
+ LOOP
+ IF ParseEmpty(rd,limit) THEN
+ EXIT
+ END;
+ id:= ParseIdentifier(rd,limit);
+ IF (id.indirection=AGRS.failName) OR ParseEmpty(rd,limit) THEN
+ EXIT
+ END;
+ vars.AddProperty(id(AGRS.Name),AGRS.Variable);
+ startPos:= Texts.Pos(rd);
+ IF ~ParseTheCharacter(',',rd,limit) THEN
+ Rewind(rd,startPos);
+ IF ParseTheString('IN',rd,limit) & ~ParseEmpty(rd,limit) THEN
+(* Names.EndNames; *)
+ rest:= ParseSentence(rd,limit);
+ Names.EndBlock;
+ IF rest.indirection=AGRS.failName THEN
+ RETURN AGRS.Failure
+ ELSE
+ RETURN AGRS.MakeLocalBlock(vars,rest)
+ END;
+ ELSE
+ EXIT
+ END;
+ END;
+ END;
+(* Names.EndNames; *)
+ Names.EndBlock;
+ END;
+ RETURN AGRS.Failure
+END ParseBlock;
+
+PROCEDURE ParseClass(VAR rd: Texts.Reader; limit: LONGINT): AGRS.Term;
+VAR
+ startPos: LONGINT;
+ tree: AGRS.Term;
+ result,tree1: AGRS.Class;
+BEGIN
+ startPos:= Texts.Pos(rd);
+ IF ParseTheString('CLASS',rd,limit) THEN
+ Rewind(rd,startPos);
+ tree:= ParseStandard(rd,limit);
+ IF tree IS AGRS.Tree THEN
+ NEW(result);
+ tree1:= SYSTEM.VAL(AGRS.Class,tree);
+ result^:= tree1^;
+ RETURN result
+ END;
+ END;
+ RETURN AGRS.Failure
+END ParseClass;
+
+
+PROCEDURE pParse;
+VAR
+ txt,parsed: AGRS.Term;
+ sentenceReader: Texts.Reader;
+BEGIN
+ txt:= sentenceName.Value();
+ WITH txt: Library.Text DO
+ sentence:= txt.base;
+ Texts.OpenReader(sentenceReader,sentence,txt.startOffset);
+ IF ~ParseEmpty(sentenceReader,txt.endOffset) THEN
+ parsed:= ParseSentence(sentenceReader,txt.endOffset);
+ IF parsed.indirection#AGRS.failName THEN
+ IF ~AGRS.Continued() THEN
+ AGRS.result:= parsed;
+ END;
+ RETURN
+ END;
+ END;
+ parsed:= Library.NewError(Library.SyntaxError);
+ parsed.Reduce;
+ ELSE
+ parsed:= Library.NewError(Library.NotTextType);
+ parsed.Reduce;
+ END;
+END pParse;
+
+
+PROCEDURE (t: ParseWrapper) Reduce*;
+VAR
+ txt,parsed: AGRS.Term;
+ rd: Texts.Reader;
+BEGIN
+ txt:= sentenceName.Value();
+ WITH txt: Library.Text DO
+ sentence:= txt.base;
+ Texts.OpenReader(rd,sentence,txt.startOffset);
+ parsed:= ExactParse(t.handler,rd,txt.endOffset);
+ ELSE
+ parsed:= Library.NewError(Library.NotTextType);
+ END;
+ IF ~AGRS.Continued() THEN
+ AGRS.result:= parsed;
+ END;
+END Reduce;
+
+BEGIN
+(* Inicijalizacija parametara i pomocnih promjenljivih. *)
+ spaceChars:= Library.NewCharSet();
+ spaceChars.Include(' ');
+ spaceChars.Include(0X);
+ spaceChars.Include(9X);
+ spaceChars.Include(0AX);
+ spaceChars.Include(0DX);
+ Names.DefinePublicName(spaceCharsName,'SpaceCharacters',spaceChars);
+
+ NEW(idTerm);
+
+ NEW(sentenceParser);
+ sentenceParser.Init(Names.SystemRoot);
+ sentenceParser.handler:= ParseSentence;
+ Names.DefinePublicName(temp,'SentenceParser',sentenceParser);
+
+ NEW(standardParser);
+ standardParser.Init(Names.SystemRoot);
+ standardParser.handler:= ParseStandard;
+ Names.DefinePublicName(temp,'StandardParser',standardParser);
+
+ NEW(customParser);
+ customParser.Init(Names.SystemRoot);
+ customParser.handler:= ParseCustom;
+ Names.DefinePublicName(temp,'CustomParser',customParser);
+
+ NEW(attributeParser);
+ attributeParser.Init(Names.SystemRoot);
+ attributeParser.handler:= ParseAttribute;
+ Names.DefinePublicName(temp,'AttributeParser',customParser);
+
+ NEW(numberParser);
+ numberParser.Init(Names.SystemRoot);
+ numberParser.handler:= ParseNumber;
+ Names.DefinePublicName(temp,'NumberParser',numberParser);
+
+ NEW(stringParser);
+ stringParser.Init(Names.SystemRoot);
+ stringParser.handler:= ParseString;
+ Names.DefinePublicName(temp,'StringParser',stringParser);
+
+ NEW(charParser);
+ charParser.Init(Names.SystemRoot);
+ charParser.handler:= ParseChar;
+ Names.DefinePublicName(temp,'CharParser',charParser);
+
+ NEW(charSetParser);
+ charSetParser.Init(Names.SystemRoot);
+ charSetParser.handler:= ParseCharSet;
+ Names.DefinePublicName(temp,'CharSetParser',charSetParser);
+
+ NEW(rulesParser);
+ rulesParser.Init(Names.SystemRoot);
+ rulesParser.handler:= ParseRules;
+ Names.DefinePublicName(temp,'RuleParser',rulesParser);
+
+ NEW(varParser);
+ varParser.Init(Names.SystemRoot);
+ varParser.handler:= ParseVar;
+ Names.DefinePublicName(temp,'VarParser',varParser);
+
+ NEW(blockParser);
+ blockParser.Init(Names.SystemRoot);
+ blockParser.handler:= ParseBlock;
+ Names.DefinePublicName(temp,'BlockParser',blockParser);
+
+ NEW(classParser);
+ classParser.Init(Names.SystemRoot);
+ classParser.handler:= ParseClass;
+ Names.DefinePublicName(temp,'ClassParser',classParser);
+
+ Names.AddSystemName(parseName,'Parse',pParse);
+ Names.AddArgument(sentenceName,'Sentence');
+ Names.AddArgument(rulesName,'RULE');
+ Names.AddArgument(varName, 'VAR');
+ Names.AddArgument(blockName, 'LOCAL');
+ Names.AddArgument(className, 'CLASS');
+ NEW(collection);
+ collection.Init(Names.SystemRoot);
+ collection.AddProperty(rulesName,rulesParser);
+ collection.AddProperty(varName,varParser);
+ collection.AddProperty(blockName,blockParser);
+ collection.AddProperty(className,classParser);
+ collection.AddProperty(AGRS.otherwise,standardParser);
+ Names.DefinePublicName(customParsersName,'CustomParsers',collection);
+ NEW(buildingName);
+ buildingName.Init(Names.SystemRoot);
+END Parser.
diff --git a/examples/AGRS/Parser2.Mod b/examples/AGRS/Parser2.Mod
new file mode 100644
index 0000000..153eea3
--- /dev/null
+++ b/examples/AGRS/Parser2.Mod
@@ -0,0 +1,428 @@
+MODULE Parser2;
+IMPORT AGRS,Names,Library,Grammars;
+
+CONST
+ MaxStrLength=Grammars.MaxStrLength;
+VAR
+ sentenceName,sExprName,exprName,atomicName: AGRS.Name;
+ treeName,tree1Name,attributesName,attributes1Name,subSentenceName: AGRS.Name;
+ attributeName: AGRS.Name;
+ sequenceName,qualificationName,fieldName: AGRS.Name;
+ disjunctionName: AGRS.Name;
+ charName,stringName,numberName: AGRS.Name;
+ argNoName,numberToIdName,lhsName,rhsName,dummyName: AGRS.Name;
+ customName,customParsersName: AGRS.Name;
+ customIdTerm: AGRS.Field;
+ collection: AGRS.ClosedClass;
+ ruleParser,altBuilder,varParser,blockParser,classParser: AGRS.Name;
+ rulesName,varName,blockName,className,guardName: AGRS.Name;
+ rulesParser,alternativeName,blockLocalsName,guardParser: AGRS.Name;
+
+PROCEDURE NewDisjunction(alt1,alt2: AGRS.Term): AGRS.Term;
+VAR
+ newTerm: AGRS.Disjunction;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(alt1);
+ newTerm.InitAlternative(alt2);
+ RETURN newTerm
+END NewDisjunction;
+
+PROCEDURE NewContinuation(base,cont: AGRS.Term): AGRS.Term;
+VAR
+ newTerm: AGRS.SubTerm;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(base);
+ newTerm.InitQuery(cont);
+ RETURN newTerm
+END NewContinuation;
+
+PROCEDURE NewTreeRoot(root: AGRS.Term): AGRS.Tree;
+VAR
+ newTerm: AGRS.Tree;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(root);
+ RETURN newTerm
+END NewTreeRoot;
+
+PROCEDURE NewClassRoot(root: AGRS.Term): AGRS.Tree;
+VAR
+ newTerm: AGRS.Class;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(root);
+ RETURN newTerm
+END NewClassRoot;
+
+PROCEDURE NewTree(base: AGRS.Tree; prop: AGRS.Name; value: AGRS.Term): AGRS.Tree;
+BEGIN
+ base.AddProperty(prop,value);
+ RETURN base
+END NewTree;
+
+PROCEDURE NewGrammarTree(root,value: AGRS.Term): AGRS.Tree;
+BEGIN
+ RETURN NewTree(NewTreeRoot(root),Grammars.grammarName,value)
+END NewGrammarTree;
+
+PROCEDURE NewOption(grammar: AGRS.Term): AGRS.Tree;
+BEGIN
+ RETURN NewGrammarTree(Grammars.optionName,grammar)
+END NewOption;
+
+PROCEDURE NewCharTerminal(expect: CHAR): AGRS.Tree;
+BEGIN
+ RETURN NewGrammarTree(Grammars.charTerminalParser,
+ Library.NewChar(expect))
+END NewCharTerminal;
+
+PROCEDURE NewStringTerminal(expect: ARRAY OF CHAR): AGRS.Term;
+BEGIN
+ RETURN NewGrammarTree(Grammars.terminalName,
+ NewTree(NewTreeRoot(Grammars.stringParser),
+ Grammars.treeName,Library.NewString(Names.NewStringCopy(expect))))
+END NewStringTerminal;
+
+PROCEDURE NewAttribute(property: AGRS.Name; grammar: AGRS.Term): AGRS.Term;
+VAR
+ temp: AGRS.Term;
+BEGIN
+ NEW(temp);
+ temp.Init(property);
+ RETURN NewTree(NewGrammarTree(Grammars.attrName,grammar),
+ Grammars.propertyName,temp)
+END NewAttribute;
+
+PROCEDURE NumberToId;
+VAR
+ n,newTerm: AGRS.Term;
+BEGIN
+ n:= argNoName.Value();
+ WITH n: Library.Number DO
+ NEW(newTerm);
+ newTerm.Init(Names.FindOrdinalName(n.value));
+ Grammars.propertyName.Assign(newTerm);
+ AGRS.Continue;
+ Grammars.propertyName.Restore;
+ ELSE
+ AGRS.Fail;
+ END;
+END NumberToId;
+
+PROCEDURE ParseChar;
+VAR
+ chRead,chResult: CHAR;
+BEGIN
+ Grammars.Read(chRead);
+ IF chRead="'" THEN
+ Grammars.Read(chResult);
+ Grammars.Read(chRead);
+ IF chRead="'" THEN
+ IF Grammars.treeName.indirection=AGRS.Variable THEN
+ Grammars.treeName.Assign(Library.NewChar(chResult));
+ AGRS.Continue;
+ Grammars.treeName.Restore;
+ RETURN
+ END;
+ END;
+ END;
+ AGRS.Fail;
+END ParseChar;
+
+PROCEDURE ParseString;
+VAR
+ ch,between: CHAR;
+ str: ARRAY MaxStrLength OF CHAR;
+ length: INTEGER;
+BEGIN
+ Grammars.Read(between);
+ IF (between="'") OR (between='"') THEN
+ length:= 0;
+ Grammars.Read(ch);
+ WHILE (ch#between) & (ch#0DX) & (length<MaxStrLength) DO
+ str[length]:= ch;
+ INC(length);
+ Grammars.Read(ch);
+ END;
+ IF ch=between THEN
+ str[length]:= 0X;
+ IF Grammars.treeName.indirection=AGRS.Variable THEN
+ Grammars.treeName.Assign(
+ Library.NewString(Names.NewStringCopy(str)));
+ AGRS.Continue;
+ Grammars.treeName.Restore;
+ RETURN
+ END;
+ END;
+ END;
+ AGRS.Fail;
+END ParseString;
+
+PROCEDURE ParseNumber;
+VAR
+ ch: CHAR;
+ minus: BOOLEAN;
+ x: INTEGER;
+ c: AGRS.TermStack;
+BEGIN
+ Grammars.Read(ch);
+ IF ch='-' THEN
+ minus:= TRUE;
+ Grammars.Read(ch);
+ ELSE
+ minus:= FALSE;
+ IF ch='+' THEN
+ Grammars.Read(ch);
+ END
+ END;
+ IF (ch<'0') OR (ch>'9') THEN
+ AGRS.Fail;
+ RETURN
+ END;
+ x:= 0;
+ WHILE (ch>='0') & (ch<='9') DO
+ IF x <= (MAX(INTEGER)-ORD(ch)+ORD('0')) DIV 10 THEN
+ x:= 10*x+ORD(ch)-ORD('0');
+ END;
+ Grammars.Read(ch);
+ END;
+ IF minus THEN
+ x:= -x;
+ END;
+ Grammars.BackSpace;
+ IF Grammars.treeName.indirection=AGRS.Variable THEN
+ Grammars.treeName.Assign(Library.NewNumber(x));
+ c:= AGRS.continuation;
+ AGRS.Continue;
+ Grammars.treeName.Restore;
+ ELSE
+ AGRS.Fail;
+ END;
+END ParseNumber;
+
+PROCEDURE ParseCustom;
+VAR
+ id,result: AGRS.Term;
+BEGIN
+ id:= customIdTerm.Actual();
+ IF id.indirection=AGRS.Failure THEN
+ AGRS.Fail;
+ ELSE
+ AGRS.Push(id);
+ customParsersName.Reduce;
+ END;
+END ParseCustom;
+
+PROCEDURE ParseClass;
+VAR
+ result: AGRS.Class;
+ t: AGRS.Term;
+BEGIN
+ NEW(result);
+ result.Init(className);
+ Grammars.treeName.Assign(result);
+ treeName.Reduce;
+ Grammars.treeName.Restore;
+ t:= AGRS.result;
+END ParseClass;
+
+PROCEDURE BuildAlternative;
+BEGIN
+ Grammars.treeName.Assign(
+ AGRS.MakeAlternative(lhsName.indirection,rhsName.indirection));
+ AGRS.Continue;
+ Grammars.treeName.Restore;
+END BuildAlternative;
+
+BEGIN
+ Grammars.DefineParser(charName,'P_CharacterAtom',ParseChar);
+ Grammars.DefineParser(stringName,'P_StringAtom',ParseString);
+ Grammars.DefineParser(numberName,'P_NumberAtom',ParseNumber);
+ Grammars.DefineParser(customName,'P_Custom',ParseCustom);
+ Grammars.DefineParser(classParser,'P_ParseCLASS',ParseClass);
+ Names.AddSystemName(altBuilder,'P_BuildAlternative',BuildAlternative);
+
+ Names.AddArgument(sentenceName,'P_Sentence');
+ Names.AddArgument(sExprName,'P_SExpr');
+ Names.AddArgument(exprName,'P_Expr');
+ Names.AddArgument(treeName,'P_Tree');
+ Names.AddArgument(tree1Name,'P_Tree1');
+ Names.AddArgument(attributesName,'P_Attributes');
+ Names.AddArgument(attributes1Name,'P_Attributes1');
+ Names.AddArgument(subSentenceName,'P_SubSentence');
+ Names.AddArgument(attributeName,'P_Attribute');
+ Names.AddArgument(disjunctionName,'P_Disjunction');
+ Names.AddArgument(sequenceName,'P_Sequence');
+ Names.AddArgument(qualificationName,'P_Qualification');
+ Names.AddArgument(fieldName,'P_Field');
+ Names.AddArgument(argNoName,'P_ArgNo');
+ Names.AddSystemName(numberToIdName,'P_NumberToName',NumberToId);
+ Names.AddArgument(lhsName,'P_LHS');
+ Names.AddArgument(rhsName,'P_RHS');
+ Names.AddArgument(alternativeName,'P_Alternative');
+ Names.AddArgument(varParser,'P_Var');
+ Names.AddArgument(ruleParser,'P_Rule');
+ Names.AddArgument(rulesParser,'P_Rules');
+ Names.AddArgument(guardParser,'P_Guard');
+ Names.AddArgument(rulesName,'RULE');
+ Names.AddArgument(varName,'VAR');
+ Names.AddArgument(blockName,'LOCAL');
+ Names.AddArgument(className,'CLASS');
+ Names.AddArgument(guardName,'GUARD');
+ Names.AddArgument(customParsersName,'P_CustomParsers');
+ Names.AddArgument(dummyName, '#Let');
+ Names.AddArgument(blockParser,'P_ParseBLOCK');
+ Names.AddArgument(blockLocalsName,'P_BlockLocals');
+ sentenceName.Init(NewDisjunction(sExprName,disjunctionName));
+ sExprName.Init(NewDisjunction(exprName,sequenceName));
+ Names.DefinePublicName(atomicName,'P_Atomic',
+ NewDisjunction(
+ charName,NewDisjunction(
+ stringName,
+ numberName)));
+ exprName.Init(NewDisjunction(
+ atomicName,NewDisjunction(
+ customName,NewDisjunction(
+ Grammars.nameParser,NewDisjunction(
+ qualificationName,NewDisjunction(
+ fieldName,
+ subSentenceName))))));
+ tree1Name.Init(AGRS.MakeLocalBlock(
+ NewTree(NewTreeRoot(dummyName),
+ argNoName,Library.NewNumber(0)),
+ attributesName));
+ treeName.Init(NewContinuation(
+ Grammars.idParser,NewContinuation(
+ NewCharTerminal('('),NewContinuation(
+ NewOption(tree1Name),
+ NewCharTerminal(')')))));
+ attributes1Name.Init(NewContinuation(
+ attributeName,
+ NewOption(NewContinuation(
+ NewCharTerminal(','),
+ attributesName))));
+ attributesName.Init(AGRS.MakeLocalBlock(
+ NewTree(NewTreeRoot(dummyName),
+ argNoName,NewTree(
+ NewTree(NewTreeRoot(Library.addName.indirection),
+ Library.argName1,argNoName),
+ Library.argName2,Library.NewNumber(1))),
+ attributes1Name));
+(* attributesName.Init(NewTree(
+ NewTreeRoot(attributes1Name),
+ argNoName,NewTree(
+ NewTree(
+ NewTreeRoot(Library.addName.indirection),
+ Library.argName1,argNoName),
+ Library.argName2,Library.NewNumber(1))));
+*)
+ subSentenceName.Init(NewContinuation(
+ NewCharTerminal('('),NewContinuation(
+ sentenceName,
+ NewCharTerminal(')'))));
+ attributeName.Init(NewDisjunction(
+ NewGrammarTree(
+ Grammars.genericAttrName,NewContinuation(
+ NewAttribute(Grammars.propertyName,
+ Grammars.nameParser),NewContinuation(
+ NewCharTerminal('='),
+ NewAttribute(Grammars.valueName,exprName)))),
+ NewContinuation(
+ numberToIdName,
+ NewGrammarTree(Grammars.attrName,exprName))));
+ disjunctionName.Init(NewGrammarTree(
+ Grammars.disjunctionName,NewContinuation(
+ NewAttribute(Library.argName1,sExprName),NewContinuation(
+ NewCharTerminal('|'),
+ NewAttribute(Library.argName2,sentenceName)))));
+ sequenceName.Init(NewGrammarTree(
+ Grammars.continuationName,NewContinuation(
+ NewAttribute(Library.argName1,exprName),NewContinuation(
+ NewCharTerminal(';'),
+ NewAttribute(Library.argName2,sExprName)))));
+ qualificationName.Init(NewGrammarTree(
+ Grammars.continuationName,NewContinuation(
+ NewAttribute(Library.argName1,Grammars.nameParser),NewContinuation(
+ NewCharTerminal('.'),
+ NewAttribute(Library.argName2,NewDisjunction(
+ treeName,
+ qualificationName))))));
+ fieldName.Init(NewGrammarTree(
+ Grammars.fieldName,NewContinuation(
+ NewAttribute(Library.argName1,Grammars.nameParser),NewContinuation(
+ NewCharTerminal('.'),
+ NewAttribute(Library.argName2,NewDisjunction(
+ Grammars.nameParser,
+ fieldName))))));
+ blockParser.Init(NewContinuation(
+ NewStringTerminal('LOCAL'),
+ NewGrammarTree(
+ Grammars.blockName,NewContinuation(
+ NewTree(
+ NewTreeRoot(Names.localName),
+ Names.bodyName,blockLocalsName),
+ NewAttribute(Grammars.rootName,sentenceName)))));
+ blockLocalsName.Init(NewContinuation(
+ NewGrammarTree(
+ Grammars.genericAttrName,NewContinuation(
+ NewAttribute(Grammars.propertyName,
+ Grammars.nameParser),
+ NewAttribute(Grammars.valueName,
+ NewTree(
+ NewTreeRoot(dummyName),
+ Grammars.treeName,AGRS.Variable)))),
+ NewDisjunction(
+ NewStringTerminal('IN'),
+ NewContinuation(
+ NewCharTerminal(','),
+ blockLocalsName))));
+ varParser.Init(NewContinuation(
+ NewStringTerminal('VAR'),
+ NewTree(
+ NewClassRoot(dummyName),
+ Grammars.treeName,AGRS.Variable)));
+ ruleParser.Init(NewContinuation(
+ NewStringTerminal('RULE'),NewContinuation(
+ NewCharTerminal('('),
+ rulesParser)));
+ rulesParser.Init(NewGrammarTree(
+ Grammars.disjunctionName,NewContinuation(
+ NewAttribute(Library.argName1,alternativeName),
+ NewAttribute(Library.argName2,NewDisjunction(
+ NewContinuation(
+ NewCharTerminal(')'),
+ NewTree(NewClassRoot(Grammars.constructName),
+ Grammars.rootName,AGRS.failName)),
+ NewContinuation(
+ NewCharTerminal(','),
+ rulesParser))))));
+ alternativeName.Init(NewContinuation(
+ NewTree(NewTreeRoot(dummyName), (* shall it stay class? *)
+ Grammars.treeName,NewClassRoot(dummyName)),NewContinuation(
+ NewAttribute(lhsName,treeName),NewContinuation(
+ NewCharTerminal('='),NewContinuation(
+ NewAttribute(rhsName,sExprName),NewContinuation(
+ Grammars.treeName,
+ altBuilder))))));
+ guardParser.Init(NewContinuation(
+ NewStringTerminal('GUARD'),
+ NewTree(
+ NewClassRoot(dummyName),
+ Grammars.treeName,AGRS.GuardTrap)));
+ Grammars.grammarName.Init(sentenceName);
+ NEW(customIdTerm);
+ customIdTerm.Init(Grammars.idParser);
+ customIdTerm.InitQuery(Grammars.treeName);
+ NEW(collection);
+ collection.Init(Names.SystemRoot);
+ collection.AddProperty(rulesName,ruleParser);
+ collection.AddProperty(varName,varParser);
+ collection.AddProperty(blockName,blockParser);
+ collection.AddProperty(className,classParser);
+ collection.AddProperty(guardName,guardParser);
+ collection.AddProperty(AGRS.otherwise,treeName);
+ customParsersName.Init(collection);
+END Parser2.
+
diff --git a/examples/AGRS/Perm.Mod b/examples/AGRS/Perm.Mod
new file mode 100644
index 0000000..90fefed
--- /dev/null
+++ b/examples/AGRS/Perm.Mod
@@ -0,0 +1,215 @@
+MODULE Permanence;
+IMPORT AGRS,Names,Library,Parser,Texts,Directories,Grammars;
+
+CONST
+ PathDelimiter= '\';
+ MaxPathLength= 200;
+
+TYPE
+ Term= AGRS.Term;
+ FilePrimitive= POINTER TO FilePrimitiveDesc;
+ FilePrimitiveDesc= RECORD(AGRS.SubTermDesc)
+ END;
+ FolderPrimitive= POINTER TO RECORD(FilePrimitiveDesc)
+ END;
+VAR
+ folderRoot, directoryName, extensionName: AGRS.Name;
+ environmentName*: AGRS.Name;
+ directory: AGRS.Class;
+ dirTerm, currentFolder: AGRS.Term;
+ i,length: INTEGER;
+
+(*
+PROCEDURE Position(t: AGRS.Var; VAR file: Files.File; VAR startPos,endPos: LONGINT);
+PROCEDURE Replace(t: AGRS.Var; file: File.File; startPos,endPos: LONGINT; VAR replacement: ARRAY OF CHAR);
+PROCEDURE WriteText*(t: AGRS.Var; VAR definition: ARRAY OF CHAR);
+PROCEDURE ReadBuffer*(t: AGRS.Var; VAR definition: ARRAY OF CHAR; startPos: LONGINT);
+PROCEDURE ReadText*(t: AGRS.Var): CharPtr;
+PROCEDURE WriteTerm*(t: AGRS.Var; definition: AGRS.Term);
+PROCEDURE WriteDefinition*(t: AGRS.Var);
+PROCEDURE Definition*(t: AGRS.Var): AGRS.Term;
+
+PROCEDURE WriteHandler;
+VAR
+ path: AGRS.SubTerm;
+BEGIN
+ path:= AGRS.EnvironmentPath(directoryName);
+ WriteDefinition(path);
+ RETURN Library.doneName
+END WriteHandler;
+*)
+
+PROCEDURE CorrectExtension(VAR filename: ARRAY OF CHAR): BOOLEAN;
+VAR
+ extension: AGRS.Term;
+ suffix: Names.CharPtr;
+ pos1,pos2: INTEGER;
+BEGIN
+ extension:= extensionName.Value();
+ WITH extension: Library.String DO
+ suffix:= extension.value;
+ pos1:= 0;
+ pos2:= 0;
+ WHILE filename[pos1]#0X DO
+ INC(pos1);
+ END;
+ WHILE suffix[pos2]#0X DO
+ INC(pos2);
+ END;
+ ASSERT(pos2>3);
+ WHILE (filename[pos1]=suffix[pos2]) & (pos1>0) & (pos2>0) DO
+ DEC(pos1);
+ DEC(pos2);
+ END;
+ IF (pos2=0) & (filename[pos1]=suffix[pos2]) THEN
+ filename[pos1]:= 0X;
+ RETURN TRUE
+ END;
+ END;
+ RETURN FALSE
+END CorrectExtension;
+
+PROCEDURE GetPath(pathTerm: Term; VAR pathString: ARRAY OF CHAR);
+VAR
+ i,length: INTEGER;
+ dir: Names.CharPtr;
+
+ PROCEDURE WritePath(t: Term);
+ VAR
+ t2: Term;
+ BEGIN
+ t2:= t;
+ WITH t2: FilePrimitive DO
+ WritePath(t2.indirection);
+ WritePath(t2.query);
+ ELSE
+ dir:= Names.NameSpelling(t(AGRS.Name));
+ i:= 0;
+ WHILE dir[i]#0X DO
+ pathString[length]:= dir[i];
+ INC(length);
+ INC(i);
+ END;
+ pathString[length]:= PathDelimiter;
+ INC(length);
+ END;
+ END WritePath;
+BEGIN
+ length:= 0;
+ WritePath(pathTerm);
+ pathString[length-1]:= 0X;
+END GetPath;
+
+PROCEDURE InitFile(dir: Directories.Directory; filename: ARRAY OF CHAR;
+ isDir: BOOLEAN; VAR cont: BOOLEAN);
+VAR
+ def: AGRS.Name;
+ newTerm1: FolderPrimitive;
+ newTerm: FilePrimitive;
+BEGIN
+ cont:= TRUE;
+ IF isDir THEN
+ IF filename[0]='.' THEN
+ RETURN
+ END;
+ NEW(newTerm1);
+ newTerm:= newTerm1;
+ ELSE
+ IF ~CorrectExtension(filename) THEN
+ RETURN
+ END;
+ NEW(newTerm);
+ END;
+ def:= Names.FindPublicNameNoCase(filename);
+ IF def=NIL THEN
+ Names.AddArgument(def,filename);
+ END;
+ newTerm.Init(currentFolder);
+ newTerm.InitQuery(def);
+ directory.AddProperty(def,newTerm);
+END InitFile;
+
+PROCEDURE InitFiles(t: AGRS.Term): AGRS.Term;
+VAR
+ path: ARRAY MaxPathLength OF CHAR;
+BEGIN
+ currentFolder:= t;
+ NEW(directory);
+ directory.Init(folderRoot);
+ directory.AddProperty(directoryName,t);
+ GetPath(t,path);
+ Directories.Enumerate(Directories.This(path),InitFile);
+ RETURN directory
+END InitFiles;
+
+PROCEDURE RefreshFolder(dir,value: AGRS.Term);
+BEGIN
+ IF dir IS FolderPrimitive THEN
+ dir:= dir(FolderPrimitive).query;
+ END;
+ dir.indirection(AGRS.Class).
+ AddProperty(AGRS.lastResult(AGRS.Name),value);
+END RefreshFolder;
+
+PROCEDURE (t: FolderPrimitive) Reduce*;
+VAR
+ newDir: Term;
+BEGIN
+ newDir:= InitFiles(t);
+ RefreshFolder(t.indirection,newDir);
+ t.query(AGRS.Name).Assign(newDir);
+ newDir.Reduce;
+ t.query(AGRS.Name).Restore;
+END Reduce;
+
+PROCEDURE (t: FilePrimitive) Reduce*;
+VAR
+ f: Texts.Text;
+ i,j: INTEGER;
+ strPtr: Names.CharPtr;
+ filename: ARRAY MaxPathLength OF CHAR;
+ result: AGRS.Term;
+BEGIN
+ GetPath(t,filename);
+ j:= 0;
+ WHILE filename[j]#0X DO
+ INC(j);
+ END;
+(*
+ strPtr:= Names.NameSpelling(AGRS.lastResult(AGRS.Name));
+ i:= 0;
+ WHILE strPtr[i]#0X DO
+ filename[j]:= strPtr[i];
+ INC(i);
+ INC(j);
+ END;
+*)
+ result:= extensionName.Value();
+ WITH result: Library.String DO
+ strPtr:= result.value;
+ i:= 0;
+ WHILE strPtr[i]#0X DO
+ filename[j]:= strPtr[i];
+ INC(i);
+ INC(j);
+ END;
+ END;
+ filename[j]:= 0X;
+ NEW(f);
+ Texts.Open(f,filename);
+ Grammars.sentenceName.Assign(Library.SubText(f,0,f.len));
+ result:= Grammars.parseName.Value();
+ Grammars.sentenceName.Restore();
+ RefreshFolder(t.indirection,result);
+ result.Reduce;
+END Reduce;
+
+BEGIN
+ Names.AddArgument(folderRoot, 'FolderClass');
+ Names.AddArgument(directoryName, 'Directory');
+ Names.AddArgument(extensionName, 'FileExtension');
+ Names.AddArgument(environmentName, 'Env');
+ extensionName.Init(Library.NewString(Names.NewStringCopy('.ATG')));
+ environmentName.Init(InitFiles(environmentName));
+END Permanence.
+
diff --git a/examples/AGRS/Permanence.Mod b/examples/AGRS/Permanence.Mod
new file mode 100644
index 0000000..9b2529a
--- /dev/null
+++ b/examples/AGRS/Permanence.Mod
@@ -0,0 +1,220 @@
+MODULE Permanence;
+IMPORT AGRS,Names,Library,Parser,Texts,Directories,Grammars;
+
+CONST
+ PathDelimiter= '\';
+ MaxPathLength= 200;
+
+TYPE
+ Term= AGRS.Term;
+ FilePrimitive= POINTER TO FilePrimitiveDesc;
+ FilePrimitiveDesc= RECORD(AGRS.SubTermDesc)
+ END;
+ FolderPrimitive= POINTER TO RECORD(FilePrimitiveDesc)
+ END;
+VAR
+ folderRoot, directoryName, extensionName: AGRS.Name;
+ environmentName*: AGRS.Name;
+ directory: AGRS.Class;
+ dirTerm, currentFolder: AGRS.Term;
+ i,length: INTEGER;
+
+(*
+PROCEDURE Position(t: AGRS.Var; VAR file: Files.File; VAR startPos,endPos: LONGINT);
+PROCEDURE Replace(t: AGRS.Var; file: File.File; startPos,endPos: LONGINT; VAR replacement: ARRAY OF CHAR);
+PROCEDURE WriteText*(t: AGRS.Var; VAR definition: ARRAY OF CHAR);
+PROCEDURE ReadBuffer*(t: AGRS.Var; VAR definition: ARRAY OF CHAR; startPos: LONGINT);
+PROCEDURE ReadText*(t: AGRS.Var): CharPtr;
+PROCEDURE WriteTerm*(t: AGRS.Var; definition: AGRS.Term);
+PROCEDURE WriteDefinition*(t: AGRS.Var);
+PROCEDURE Definition*(t: AGRS.Var): AGRS.Term;
+
+PROCEDURE WriteHandler;
+VAR
+ path: AGRS.SubTerm;
+BEGIN
+ path:= AGRS.EnvironmentPath(directoryName);
+ WriteDefinition(path);
+ RETURN Library.doneName
+END WriteHandler;
+*)
+
+PROCEDURE CorrectExtension(VAR filename: ARRAY OF CHAR): BOOLEAN;
+VAR
+ extension: AGRS.Term;
+ suffix: Names.CharPtr;
+ pos1,pos2: INTEGER;
+BEGIN
+ extension:= extensionName.Value();
+ WITH extension: Library.String DO
+ suffix:= extension.value;
+ pos1:= 0;
+ pos2:= 0;
+ WHILE filename[pos1]#0X DO
+ INC(pos1);
+ END;
+ WHILE suffix[pos2]#0X DO
+ INC(pos2);
+ END;
+ ASSERT(pos2>3);
+ WHILE (filename[pos1]=suffix[pos2]) & (pos1>0) & (pos2>0) DO
+ DEC(pos1);
+ DEC(pos2);
+ END;
+ IF (pos2=0) & (filename[pos1]=suffix[pos2]) THEN
+ filename[pos1]:= 0X;
+ RETURN TRUE
+ END;
+ END;
+ RETURN FALSE
+END CorrectExtension;
+
+PROCEDURE GetPath(pathTerm: Term; VAR pathString: ARRAY OF CHAR);
+VAR
+ i,length: INTEGER;
+ dir: Names.CharPtr;
+
+ PROCEDURE WritePath(t: Term);
+ VAR
+ t2: Term;
+ BEGIN
+ t2:= t;
+ WITH t2: FilePrimitive DO
+ WritePath(t2.indirection);
+ WritePath(t2.query);
+ ELSE
+ dir:= Names.NameSpelling(t(AGRS.Name));
+ i:= 0;
+ WHILE dir[i]#0X DO
+ pathString[length]:= dir[i];
+ INC(length);
+ INC(i);
+ END;
+ pathString[length]:= PathDelimiter;
+ INC(length);
+ END;
+ END WritePath;
+BEGIN
+ length:= 0;
+ WritePath(pathTerm);
+ pathString[length-1]:= 0X;
+END GetPath;
+
+PROCEDURE InitFile(dir: Directories.Directory; filename: ARRAY OF CHAR;
+ isDir: BOOLEAN; VAR cont: BOOLEAN);
+VAR
+ def: AGRS.Name;
+ newTerm1: FolderPrimitive;
+ newTerm: FilePrimitive;
+BEGIN
+ cont:= TRUE;
+ IF isDir THEN
+ IF filename[0]='.' THEN
+ RETURN
+ END;
+ NEW(newTerm1);
+ newTerm:= newTerm1;
+ ELSE
+ IF ~CorrectExtension(filename) THEN
+ RETURN
+ END;
+ NEW(newTerm);
+ END;
+ def:= Names.FindPublicNameNoCase(filename);
+ IF def=NIL THEN
+ Names.AddArgument(def,filename);
+ END;
+ newTerm.Init(currentFolder);
+ newTerm.InitQuery(def);
+ directory.AddProperty(def,newTerm);
+END InitFile;
+
+PROCEDURE InitFiles(t: AGRS.Term): AGRS.Term;
+VAR
+ path: ARRAY MaxPathLength OF CHAR;
+BEGIN
+ currentFolder:= t;
+ NEW(directory);
+ directory.Init(folderRoot);
+ directory.AddProperty(directoryName,t);
+ GetPath(t,path);
+ Directories.Enumerate(Directories.This(path),InitFile);
+ RETURN directory
+END InitFiles;
+
+PROCEDURE (t: FilePrimitive) RefreshValue(value: AGRS.Term);
+VAR
+ dir: AGRS.Term;
+BEGIN
+ dir:= t.indirection;
+ IF dir IS FolderPrimitive THEN
+ dir:= dir(FolderPrimitive).query;
+ END;
+ dir:= dir(AGRS.Name).indirection;
+ dir(AGRS.Class).AddProperty(t.query(AGRS.Name),value);
+END RefreshValue;
+
+PROCEDURE (t: FolderPrimitive) Reduce*;
+VAR
+ newDir: Term;
+BEGIN
+ newDir:= InitFiles(t);
+ t.RefreshValue(newDir);
+ t.query(AGRS.Name).Assign(newDir);
+ newDir.Reduce;
+ t.query(AGRS.Name).Restore;
+END Reduce;
+
+PROCEDURE (t: FilePrimitive) Reduce*;
+VAR
+ f: Texts.Text;
+ i,j: INTEGER;
+ strPtr: Names.CharPtr;
+ filename: ARRAY MaxPathLength OF CHAR;
+ result: AGRS.Term;
+BEGIN
+ GetPath(t,filename);
+ j:= 0;
+ WHILE filename[j]#0X DO
+ INC(j);
+ END;
+(*
+ strPtr:= Names.NameSpelling(AGRS.lastResult(AGRS.Name));
+ i:= 0;
+ WHILE strPtr[i]#0X DO
+ filename[j]:= strPtr[i];
+ INC(i);
+ INC(j);
+ END;
+*)
+ result:= extensionName.Value();
+ WITH result: Library.String DO
+ strPtr:= result.value;
+ i:= 0;
+ WHILE strPtr[i]#0X DO
+ filename[j]:= strPtr[i];
+ INC(i);
+ INC(j);
+ END;
+ END;
+ filename[j]:= 0X;
+ NEW(f);
+ Texts.Open(f,filename);
+ Grammars.sentenceName.Assign(Library.SubText(f,0,f.len));
+ result:= Grammars.parseName.Value();
+ Grammars.sentenceName.Restore();
+ IF result.indirection#AGRS.failName THEN
+ t.RefreshValue(result);
+ END;
+ result.Reduce;
+END Reduce;
+
+BEGIN
+ Names.AddArgument(folderRoot, 'FolderClass');
+ Names.AddArgument(directoryName, 'Directory');
+ Names.AddArgument(extensionName, 'FileExtension');
+ Names.AddArgument(environmentName, 'Env');
+ extensionName.Init(Library.NewString(Names.NewStringCopy('.ATG')));
+ environmentName.Init(InitFiles(environmentName));
+END Permanence.
+
diff --git a/examples/AGRS/Pictures.Def b/examples/AGRS/Pictures.Def
new file mode 100644
index 0000000..e1bc302
--- /dev/null
+++ b/examples/AGRS/Pictures.Def
@@ -0,0 +1,137 @@
+(*
+https://web.archive.org/web/20050219180235/http://www.oberon.ethz.ch:80/ethoberon/defs/Pictures.Def.html
+*)
+DEFINITION Pictures; (* portable, except where noted *)
+
+(*Module Pictures implement an abstract data type (and object type) for manipulating
+colored bitmaps of various color depths.
+*)
+ IMPORT Files, Display, Objects;
+
+ CONST
+ redraw = 4; resize = 5; (* UpdateMsg id. *)
+ PictFileId = - 4093; (* First two bytes of a .Pict file (0F0H, 3H). *)
+
+ TYPE
+ Picture = POINTER TO PictureDesc;
+ UpdateMsg = RECORD ( Display.FrameMsg )
+ id, u, v, w, h: INTEGER;
+ pict: Picture;
+ END;
+
+ PictureDesc = RECORD ( Objects.ObjDesc )
+ width, height, depth: INTEGER; (* Width, height in pixels, and depth in
+bits per pixel (1, 4, or 8). *)
+ address: LONGINT; (* non-portable *) (* Pointer to bitmap data. *)
+ END;
+
+ VAR
+ dots: Display.Pattern;
+ colorD: INTEGER; (* Default bitmap color depth. *)
+
+(* Get the color index of the bitmap pixel at X, Y. *)
+ PROCEDURE Get (P: Picture; X, Y: INTEGER): INTEGER;
+
+(* Put a pixel of color col at x, y using mode. *)
+ PROCEDURE Dot (P: Picture; col: INTEGER; X, Y, mode: INTEGER);
+
+(* Starting at position x, y, determine the longest run of the same colored
+pixels (col) on the same scanline. Afterwards x indicates the first pixel of
+a different color thatn col. *)
+ PROCEDURE GetRun (P: Picture; VAR col: INTEGER; VAR X: INTEGER; Y: INTEGER);
+
+(* Copy a the block sx, sy, w, h from picture sP to position dx, dy in destination
+picture dP. Source and destination picture may be the same. *)
+ PROCEDURE CopyBlock (sP, dP: Picture; SX, SY, W, H, DX, DY, mode: INTEGER);
+
+(* Copy the pattern pat in color col to position x, y using mode. *)
+ PROCEDURE CopyPattern (P: Picture; col: INTEGER; pat: LONGINT; X, Y, mode: INTEGER);
+
+(* Block fill area x, y, w, h in color col using mode. *)
+ PROCEDURE ReplConst (P: Picture; col, X, Y, W, H, mode: INTEGER);
+
+(* Pattern fill pattern pat in the area x, y, w, h in color col using mode.
+*)
+ PROCEDURE ReplPattern (P: Picture; col: INTEGER; pat: LONGINT; X, Y, W, H, mode: INTEGER);
+
+(* Copy area SX, SY, SW, SH of source picture sP to area DX, DY, DW, DH of destination
+picture dP. Appropriate scaling is done. *)
+ PROCEDURE Copy (sP, dP: Picture; SX, SY, SW, SH, DX, DY, DW, DH, mode: INTEGER);
+
+(* Define the color palette for color index col. *)
+ PROCEDURE SetColor (P: Picture; col, red, green, blue: INTEGER);
+
+(* Retrieve the color palette entry for color index col. *)
+ PROCEDURE GetColor (P: Picture; col: INTEGER; VAR red, green, blue: INTEGER);
+
+(* Indicate that a change has been made to the area X, Y, W, H of P. This results
+in an UpdateMsg with id = redraw to be broadcasted into the display space. *)
+ PROCEDURE Update (P: Picture; X, Y, W, H: INTEGER);
+
+(* Copy the area x, y, w, h of picture P to position dx, dy on the display.
+*)
+ PROCEDURE DisplayBlock (P: Picture; X, Y, W, H, DX, DY, mode: INTEGER);
+
+(* Create a picture of size width x height with depth bits per pixel. The picture
+palette is initialized to a default state. If not enough memory is available
+to allocate the bitmap data, the width, height, and depth of the picture is
+set to zero. *)
+ PROCEDURE Create (P: Picture; width, height, depth: INTEGER);
+
+(* Like Dot, for a line of pixels. *)
+ PROCEDURE PutLine (P: Picture; VAR data: ARRAY OF INTEGER; x, y, w: INTEGER);
+
+(* Like Get, for a line of pixels. *)
+ PROCEDURE GetLine (P: Picture; VAR data: ARRAY OF INTEGER; x, y, w: INTEGER);
+
+(* Stores picture run length encoded to file F (including tag). *)
+ PROCEDURE Store (P: Picture; F: Files.File; pos: LONGINT; VAR len: LONGINT);
+
+(* Load a run length encoded picture from position pos from file F. Pos should
+be AFTER the two byte picture identification of a picture file. *)
+ PROCEDURE Load (P: Picture; F: Files.File; pos: LONGINT; VAR len: LONGINT);
+
+(* Open the picture file with name from disk. Any graphic file format listed
+in the PictureConverters section of Oberon.Text can be loaded (e.g. GIF, JPEG,
+XBM, BMP). *)
+ PROCEDURE Open (P: Picture; name: ARRAY OF CHAR; color: BOOLEAN);
+
+(* Returns the address of the bitmap data of a picture. *)
+ PROCEDURE Address (P: Picture): LONGINT; (* non-portable *)
+
+(* Default picture object handler. *)
+ PROCEDURE Handle (obj: Objects.Object; VAR msg: Objects.ObjMsg);
+
+(* Generator for a picture object. *)
+ PROCEDURE NewPicture;
+END Pictures.
+
+(* Remarks
+
+1. The origin (0, 0) is the bottom left corner of a bitmap. A picture has a
+bitmap and a color palette. The color palette specifies the reg, green, blue
+components (in the range 0 - 255) of the color indexes in the bitmap data. Only
+palettized bitmaps are supported in depths of 1, 4, and 8 bits per pixel. On
+most Oberon platforms the color palette of a picture is ignored when displaying
+the picture. Instead the picture is displayed with the current screen palette.
+To see the true colors of a picture, the picture palette has to be copied into
+the screen palette.
+
+2. The drawing modes are the same as that of module Display (replace, paint,
+invert). After drawing into a picture, a module should indicate using procedure
+Update what area of the picture should be displayed fresh.
+
+3. On many Oberon platforms the address of the bitmap data is set to zero. This
+indicates that it is impossible to access the bitmap directly.
+
+4. Native Oberon only supports bit depths of 8 bits per pixel.
+
+5. When opening a GIF picture with Pictures.Open, the GIF background color is
+burned in to color 14 (light grey).
+
+6. Implementation restriction
+Picture objects cannot be named or have attributes (see module Attributes).
+Picture objects only understand the messages Objects.FileMsg, Objects.CopyMsg
+and Objects.BindMsg.
+
+*)
diff --git a/examples/AGRS/SYSTEM.Def b/examples/AGRS/SYSTEM.Def
new file mode 100644
index 0000000..84509bb
--- /dev/null
+++ b/examples/AGRS/SYSTEM.Def
@@ -0,0 +1,18 @@
+DEFINITION SYSTEM;
+
+TYPE BYTE * = CHAR;
+TYPE IntPtr = POINTER TO INTEGER;
+
+PROCEDURE ADR(v: INTEGER): LONGINT;
+PROCEDURE BIT(a: LONGINT; n: SHORTINT): BOOLEAN;
+PROCEDURE CC(n: SHORTINT): BOOLEAN;
+PROCEDURE LSH(x: INTEGER; n: SHORTINT): INTEGER;
+PROCEDURE ROT(x: INTEGER; n: SHORTINT): INTEGER;
+PROCEDURE VAL(T: INTEGER; x: INTEGER) : INTEGER;
+
+PROCEDURE GET(a: LONGINT; VAR v: INTEGER);
+PROCEDURE PUT(a: LONGINT; v: INTEGER);
+PROCEDURE MOVE(s, d: LONGINT; n: INTEGER);
+PROCEDURE NEW(v: IntPtr; n: INTEGER);
+
+END SYSTEM.
diff --git a/examples/AGRS/Speller.Mod b/examples/AGRS/Speller.Mod
new file mode 100644
index 0000000..2e22c81
--- /dev/null
+++ b/examples/AGRS/Speller.Mod
@@ -0,0 +1,405 @@
+MODULE Speller;
+IMPORT AGRS,Names,Library,Texts,TextFrames;
+
+
+CONST
+ SetBits= MAX(SET)+1;
+ TabChar= 9X;
+TYPE
+
+ SpellingHandlerType= PROCEDURE(t: AGRS.Term): AGRS.Term;
+ SpellingWrapper= POINTER TO RECORD(AGRS.TermDesc)
+ handler: SpellingHandlerType;
+ END;
+VAR
+ FindSpelling: SpellingHandlerType;
+ spelledTextName,spellingName*,spellingsName*: AGRS.Name;
+ thoughtName*,nameSpellingName,indentionName: AGRS.Name;
+ standardSpellingName: AGRS.Name;
+
+
+ sys: SpellingWrapper;
+ collection: AGRS.ClosedClass;
+
+ spelled: Texts.Text; (* Akumulira spelovani tekst. *)
+ wr: Texts.Writer;
+ firstAttr: BOOLEAN; (* Da li je prvi spelovani atribut ili ne. *)
+
+(* Sljedece je u planu.
+
+ grammarSpellMeanings: AGRS.Class;
+ grammarSpellingName: AGRS.Name;
+
+PROCEDURE GrammarTermSpellings(query: AGRS.Term): AGRS.Term;
+VAR
+ result: AGRS.Term;
+BEGIN
+ IF query=NIL THEN
+ NEW(result);
+ result.Init(AGRS.lastName);
+ ELSE
+ result:= Grammars.grammarsName.Evaluate(query);
+ Grammars.grammarName.Assign(result);
+ Library.thoughtName.Assign(query);
+ result:= grammarSpellingName.Value();
+ Library.thoughtName.Restore();
+ Grammars.grammarName.Restore();
+ END;
+ RETURN result
+END GrammarTermSpellings;
+
+PROCEDURE GrammarSpelling(): AGRS.Term;
+BEGIN
+ RETURN grammarSpellMeanings.Evaluate(grammarName);
+END GrammarSpelling;
+*)
+
+
+PROCEDURE NewText(): Library.Text;
+VAR
+ oldLength: LONGINT;
+BEGIN
+ oldLength:= spelled.len;
+ Texts.Append(spelled,wr.buf);
+ RETURN Library.SubText(spelled,oldLength,spelled.len)
+END NewText;
+
+PROCEDURE pNameSpelling();
+VAR
+ s: AGRS.Term;
+BEGIN
+ s:= Library.NewString(Names.NameSpelling(thoughtName.indirection));
+ s.Reduce;
+END pNameSpelling;
+
+
+
+PROCEDURE SpellAttribute(name: AGRS.Name; VAR t: AGRS.Term);
+VAR
+ nameSpellPtr: Names.CharPtr;
+ spelled: Library.Text;
+ meaning,indention: AGRS.Term;
+ i: INTEGER;
+BEGIN
+ IF firstAttr THEN
+ firstAttr:= FALSE;
+ ELSE
+ Texts.Write(wr,',');
+ Texts.Write(wr,' ');
+ END;
+ Texts.WriteLn(wr);
+ indention:= indentionName.Value();
+ IF indention IS Library.Number THEN
+ FOR i:= 1 TO indention(Library.Number).value DO
+ Texts.Write(wr,TabChar);
+ END;
+ END;
+ nameSpellPtr:= Names.NameSpelling(name);
+ Texts.WriteString(wr,nameSpellPtr^);
+ Texts.Write(wr,'=');
+ spelled:= spelledTextName.indirection(Library.Text);
+ spelled.AppendBuffer(wr.buf);
+ thoughtName.Assign(t);
+ IF (t IS AGRS.SubTerm) & ~(t.indirection IS AGRS.Name) OR
+ (t IS AGRS.Disjunction) THEN
+ Texts.Write(wr,'(');
+ Texts.WriteLn(wr);
+ FOR i:= 1 TO indention(Library.Number).value+1 DO
+ Texts.Write(wr,TabChar);
+ END;
+ indentionName.Assign(
+ Library.NewNumber(indention(Library.Number).value+1));
+ spelled.AppendBuffer(wr.buf);
+ meaning:= standardSpellingName.Value();
+ indentionName.Restore();
+ Texts.Write(wr,')');
+ meaning(Library.Text).AppendBuffer(wr.buf);
+ ELSE
+ meaning:= FindSpelling(t);
+ END;
+ thoughtName.Restore();
+ IF meaning IS Library.Text THEN
+ spelled.AppendText(meaning(Library.Text));
+ ELSE
+ Texts.WriteString(wr,'!@# Unspellable! ');
+ spelled.AppendBuffer(wr.buf);
+ END;
+END SpellAttribute;
+
+
+PROCEDURE StandardSpelling(query: AGRS.Term): AGRS.Term;
+VAR
+ result: Library.Text;
+ nameSpellPtr: Names.CharPtr;
+ rest,indention: AGRS.Term;
+ i: INTEGER;
+BEGIN
+ IF query IS AGRS.SystemTerm THEN
+ IF query=AGRS.GuardTrap THEN
+ Texts.WriteString(wr,'GUARD');
+ ELSE
+ Texts.WriteString(wr,'#SYSTEM!');
+ END;
+ RETURN NewText()
+ END;
+ indention:= indentionName.Value();
+ IF (query IS AGRS.SubTerm) OR (query IS AGRS.Field) OR
+ (query IS AGRS.Disjunction) THEN
+ rest:= FindSpelling(query.indirection);
+ IF query IS AGRS.Disjunction THEN
+ Texts.WriteString(wr,' | ');
+ result:= rest(Library.Text);
+ rest:= query(AGRS.Disjunction).alternative;
+ ELSE
+ IF query.indirection IS AGRS.Name THEN
+ Texts.Write(wr,'.');
+ ELSE
+ Texts.Write(wr,';');
+ Texts.WriteLn(wr);
+ FOR i:= 1 TO indention(Library.Number).value DO
+ Texts.Write(wr,TabChar);
+ END;
+ END;
+ result:= rest(Library.Text);
+ rest:= query(AGRS.SubTerm).query;
+ END;
+ result.AppendBuffer(wr.buf);
+ rest:= FindSpelling(rest);
+ result.AppendText(rest(Library.Text));
+ RETURN result
+ ELSIF query IS AGRS.Name THEN
+ nameSpellPtr:= Names.NameSpelling(query);
+ Texts.WriteString(wr,nameSpellPtr^);
+ RETURN NewText()
+ ELSE
+ IF query IS AGRS.Block THEN
+ Texts.WriteString(wr,'LOCAL ');
+ ELSE
+ nameSpellPtr:= Names.NameSpelling(query.indirection);
+ Texts.WriteString(wr,nameSpellPtr^);
+ END;
+ Texts.Write(wr,'(');
+ result:= NewText();
+ IF query IS AGRS.Tree THEN
+ WITH query: AGRS.Tree DO
+ spelledTextName.Assign(result);
+ firstAttr:= TRUE;
+ WITH indention: Library.Number DO
+ indentionName.Assign(
+ Library.NewNumber(indention.value+1));
+ query.ProcessAttributes(SpellAttribute);
+ indentionName.Restore();
+ ELSE
+ query.ProcessAttributes(SpellAttribute);
+ END;
+ result:= spelledTextName.indirection(Library.Text);
+ spelledTextName.Restore();
+ END;
+ END;
+ Texts.Write(wr,')');
+ result(Library.Text).AppendBuffer(wr.buf);
+ IF query IS AGRS.Block THEN
+ Texts.WriteString(wr,' IN ');
+ result(Library.Text).AppendBuffer(wr.buf);
+ rest:= FindSpelling(query.indirection);
+ result.AppendText(rest(Library.Text));
+ END;
+ RETURN result
+ END;
+END StandardSpelling;
+
+
+PROCEDURE NumberSpelling(query: AGRS.Term): AGRS.Term;
+BEGIN
+ WITH query: Library.Number DO
+ Texts.WriteInt(wr,query.value,0);
+ RETURN NewText()
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END NumberSpelling;
+
+
+PROCEDURE CharSpelling(query: AGRS.Term): AGRS.Term;
+BEGIN
+ WITH query: Library.Character DO
+ Texts.Write(wr,"'");
+ Texts.Write(wr,query.value);
+ Texts.Write(wr,"'");
+ RETURN NewText()
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END CharSpelling;
+
+
+PROCEDURE CharSetSpelling(query: AGRS.Term): AGRS.Term;
+VAR
+ ch: CHAR;
+ first: BOOLEAN;
+BEGIN
+ WITH query: Library.CharSet DO
+ ch:= MIN(CHAR);
+ Texts.Write(wr,'{');
+ first:= TRUE;
+ LOOP
+ IF ((ch=0DX) & (0AH MOD SetBits IN query.value[0AH DIV SetBits])) THEN
+ ch:= CHR(ORD(ch)+1);
+ END;
+ IF ORD(ch) MOD SetBits IN query.value[ORD(ch) DIV SetBits] THEN
+ IF ~first THEN
+ Texts.Write(wr,',');
+ END;
+ first:= FALSE;
+ IF (ch<=' ') THEN
+ Texts.Write(wr,'\');
+ CASE ch OF
+ |9X: Texts.Write(wr,'T');
+ |' ': Texts.Write(wr,'S');
+ |0AX,0DX: Texts.Write(wr,'N');
+ |0X: Texts.Write(wr,'0');
+ ELSE
+ Texts.Write(wr,'?');
+ END;
+ ELSE
+ IF (ch=',') OR (ch='}') OR (ch='{') OR (ch='\') THEN
+ Texts.Write(wr,'\');
+ END;
+ Texts.Write(wr,ch);
+ IF (ORD(ch)+1) MOD SetBits IN
+ query.value[(ORD(ch)+1) DIV SetBits] THEN
+ REPEAT
+ ch:= CHR(ORD(ch)+1);
+ UNTIL ~(ORD(ch) MOD SetBits IN
+ query.value[ORD(ch) DIV SetBits]);
+ ch:= CHR(ORD(ch)-1);
+ Texts.Write(wr,'-');
+ IF (ch=',') OR (ch='}') OR (ch='{') OR (ch='\') THEN
+ Texts.Write(wr,'\');
+ END;
+ Texts.Write(wr,ch);
+ END;
+ END;
+ END;
+ IF ch<MAX(CHAR) THEN
+ ch:= CHR(ORD(ch)+1);
+ ELSE
+ EXIT
+ END
+ END;
+ Texts.Write(wr,'}');
+ RETURN NewText()
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END CharSetSpelling;
+
+
+PROCEDURE StringSpelling(query: AGRS.Term): AGRS.Term;
+BEGIN
+ WITH query: Library.String DO
+ Texts.Write(wr,'"');
+ Texts.WriteString(wr,query.value^);
+ Texts.Write(wr,'"');
+ RETURN NewText()
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END StringSpelling;
+
+
+PROCEDURE ErrorSpelling(query: AGRS.Term): AGRS.Term;
+BEGIN
+ WITH query: Library.Error DO
+ CASE query.value OF
+ Library.NotLogicalType: Texts.WriteString(wr,'Not the logical type!');
+ |Library.NotNumberType: Texts.WriteString(wr,'Not the number type!');
+ |Library.NotStringType: Texts.WriteString(wr,'Not the string type!');
+ |Library.NotCharacterType: Texts.WriteString(wr,'Not the character type!');
+ |Library.NotTextType: Texts.WriteString(wr,'Not the text type!');
+ |Library.SyntaxError: Texts.WriteString(wr,'Syntax error!');
+ |Library.NotFound: Texts.WriteString(wr,'Undefined word meaning!');
+ END;
+ RETURN NewText()
+ ELSE
+ RETURN AGRS.Failure
+ END;
+END ErrorSpelling;
+
+PROCEDURE VarSpelling(query: AGRS.Term): AGRS.Term;
+BEGIN
+ HALT(255);
+ Texts.WriteString(wr,'VAR');
+ RETURN NewText()
+END VarSpelling;
+
+
+PROCEDURE TextSpelling(query: AGRS.Term): AGRS.Term;
+BEGIN
+ RETURN query.Value()
+END TextSpelling;
+
+
+PROCEDURE pSpelling(query: AGRS.Term): AGRS.Term;
+VAR
+ result: AGRS.Term;
+BEGIN
+ IF query IS AGRS.Atomic THEN
+ thoughtName.Assign(query);
+ result:= spellingsName.Evaluate(query);
+ thoughtName.Restore;
+ RETURN result
+ ELSE
+ RETURN StandardSpelling(query);
+ END;
+END pSpelling;
+
+
+PROCEDURE (t: SpellingWrapper) Reduce;
+VAR
+ text: AGRS.Term;
+BEGIN
+ text:= t.handler(thoughtName.indirection);
+ text.Reduce;
+END Reduce;
+
+PROCEDURE NewSpeller(h: SpellingHandlerType): AGRS.Term;
+VAR
+ newTerm: SpellingWrapper;
+BEGIN
+ NEW(newTerm);
+ newTerm.Init(Names.SystemRoot);
+ newTerm.handler:= h;
+ RETURN newTerm
+END NewSpeller;
+
+BEGIN
+
+ spelled:= TextFrames.Text("");
+ Texts.OpenWriter(wr);
+ NEW(spelledTextName);
+ spelledTextName.Init(Names.SystemRoot);
+ NEW(collection);
+ collection.Init(Names.SystemRoot);
+ collection.AddProperty(Library.numberName,
+ NewSpeller(NumberSpelling));
+ collection.AddProperty(Library.stringName,NewSpeller(StringSpelling));
+ collection.AddProperty(Library.textName,NewSpeller(TextSpelling));
+ collection.AddProperty(Library.charName,NewSpeller(CharSpelling));
+ collection.AddProperty(Library.charSetName,NewSpeller(CharSetSpelling));
+ collection.AddProperty(Library.errorName,NewSpeller(ErrorSpelling));
+ collection.AddProperty(Names.VariableRoot,NewSpeller(VarSpelling));
+ Names.DefinePublicName(standardSpellingName,'StandardSpelling',
+ NewSpeller(StandardSpelling));
+ collection.AddProperty(AGRS.otherwise,standardSpellingName);
+ Names.DefinePublicName(spellingsName,'Spellings',collection);
+ Names.DefinePublicName(indentionName,'Indention',
+ Library.NewNumber(0));
+ Names.AddSystemName(nameSpellingName,'NameSpelling',pNameSpelling);
+ Names.DefinePublicName(spellingName,'Spelling',
+ NewSpeller(pSpelling));
+ Names.AddArgument(spelledTextName,'SpelledTree');
+ Names.AddArgument(thoughtName,'Thought');
+ FindSpelling:= pSpelling;
+END Speller.
+
diff --git a/examples/AGRS/TextFrames.Def b/examples/AGRS/TextFrames.Def
new file mode 100644
index 0000000..51696d6
--- /dev/null
+++ b/examples/AGRS/TextFrames.Def
@@ -0,0 +1,69 @@
+(*
+https://web.archive.org/web/20041227181940/http://www.oberon.ethz.ch:80/ethoberon/defs/TextFrames.Def.html
+*)
+
+DEFINITION TextFrames; (* portable *)
+
+ IMPORT Objects, Display, Texts, Oberon;
+
+ TYPE
+ Location = RECORD
+ org, pos: LONGINT;
+ dx, x, y: INTEGER;
+ END;
+
+ Frame = POINTER TO FrameDesc;
+ FrameDesc = RECORD ( Display.FrameDesc )
+ text: Texts.Text;
+ org: LONGINT;
+ col: INTEGER;
+ lsp: INTEGER;
+ left, right, top, bot: INTEGER;
+ markH: INTEGER;
+ time: LONGINT;
+ mark, car, sel: INTEGER;
+ carloc: Location;
+ selbeg, selend: Location;
+ END;
+
+ VAR
+ menuH, barW, left, right, top, bot, lsp: INTEGER;
+ PROCEDURE Mark (F: Frame; mark: INTEGER);
+ PROCEDURE Restore (F: Frame);
+ PROCEDURE Suspend (F: Frame);
+ PROCEDURE Extend (F: Frame; newY: INTEGER);
+ PROCEDURE Reduce (F: Frame; newY: INTEGER);
+ PROCEDURE Show (F: Frame; pos: LONGINT);
+ PROCEDURE Pos (F: Frame; X, Y: INTEGER): LONGINT;
+ PROCEDURE SetCaret (F: Frame; pos: LONGINT);
+ PROCEDURE TrackCaret (F: Frame; X, Y: INTEGER; VAR keysum: SET);
+ PROCEDURE RemoveCaret (F: Frame);
+ PROCEDURE SetSelection (F: Frame; beg, end: LONGINT);
+ PROCEDURE TrackSelection (F: Frame; X, Y: INTEGER; VAR keysum: SET);
+ PROCEDURE RemoveSelection (F: Frame);
+ PROCEDURE TrackLine (F: Frame; X, Y: INTEGER; VAR org: LONGINT; VAR keysum: SET);
+ PROCEDURE TrackWord (F: Frame; X, Y: INTEGER; VAR pos: LONGINT; VAR keysum: SET);
+ PROCEDURE GetAttr (F: Frame; VAR s: ARRAY OF CHAR);
+ PROCEDURE Call (F: Frame; pos: LONGINT; new: BOOLEAN);
+ PROCEDURE Write (F: Frame; ch: CHAR; lib: Objects.Library; col, voff: SHORTINT);
+ PROCEDURE Defocus (F: Frame);
+ PROCEDURE Neutralize (F: Frame);
+ PROCEDURE Modify (F: Frame; id, dY, Y, H: INTEGER);
+ PROCEDURE Open (
+ F: Frame; H: Objects.Handler; T: Texts.Text; org: LONGINT;
+ col, left, right, top, bot, lsp: INTEGER);
+ PROCEDURE Copy (F: Frame; VAR F1: Frame);
+ PROCEDURE CopyOver (F: Frame; text: Texts.Text; beg, end: LONGINT);
+ PROCEDURE GetSelection (F: Frame; VAR M: Oberon.SelectMsg);
+ PROCEDURE GetCaret (F: Frame; VAR M: Oberon.CaretMsg);
+ PROCEDURE Update (F: Frame; beg, end, len: LONGINT);
+ PROCEDURE Edit (F: Frame; X, Y: INTEGER; Keys: SET);
+ PROCEDURE Handle (F: Objects.Object; VAR M: Objects.ObjMsg);
+ PROCEDURE Text (name: ARRAY OF CHAR): Texts.Text;
+ PROCEDURE NewMenu (name, commands: ARRAY OF CHAR): Frame;
+ PROCEDURE NewText (text: Texts.Text; pos: LONGINT): Frame;
+
+(* Replace the default system editor with a textframe. *)
+ PROCEDURE ReplaceSystemEditor;
+
+END TextFrames.
diff --git a/examples/AGRS/Texts.Def b/examples/AGRS/Texts.Def
new file mode 100644
index 0000000..61bd517
--- /dev/null
+++ b/examples/AGRS/Texts.Def
@@ -0,0 +1,348 @@
+(*
+https://web.archive.org/web/20041227181940/http://www.oberon.ethz.ch:80/ethoberon/defs/Texts.Def.html
+*)
+DEFINITION Texts; (* portable *)
+
+(* The Texts module implements the text abstract data type. Texts are sequences
+of
+characters and objects, with different colors, different fonts, and vertical
+offsets.
+*)
+ IMPORT Files, Objects, Display;
+
+ CONST
+ (* Scanner symbol classes.*)
+ Inval = 0; (* Invalid symbol. *)
+ Name = 1; (* Name s (of length len).*)
+ String = 2; (* Quoted string s (length len). *)
+ Int = 3; (* Integer i (decimal or hexadecimal). *)
+ Real = 4; (* Real number x. *)
+ LongReal = 5; (* Long real number y. *)
+ Char = 6; (* Special character c. *)
+ Object = 7; (* Object obj. *)
+
+ TYPE
+ Text = POINTER TO TextDesc;
+ TextDesc = RECORD ( Objects.ObjDesc )
+ len: LONGINT; (* Text consists of characters 0 to T.len - 1. *)
+ END;
+
+ UpdateMsg = RECORD ( Display.FrameMsg ) (* Message broadcast to indicate
+that part of a text changed. *)
+ text: Text; (* The text that changed. *)
+ beg, end, len: LONGINT (* Change location. *)
+ END;
+
+ Finder = RECORD (* Finder of (non-character) objects located in text. *)
+ eot: BOOLEAN; (* End-of-text reached during search. *)
+ pos: LONGINT; (* Offset of Finder in text. *)
+ END;
+
+ Reader = RECORD (* Character-wise reader of a text stream. *)
+ lib: Objects.Library; (* Library of last character/object read. *)
+ col: SHORTINT; (* Color index of last character read. *)
+ voff: SHORTINT; (* vertical offset of last character read. *)
+ eot: BOOLEAN (* Reader has reached end of the text stream. *)
+ END;
+
+ Scanner = RECORD ( Reader ) (* Scanner for symbol streams. *)
+ nextCh: CHAR; (* Character immediately following the last symbol scanned.
+*)
+ line: INTEGER; (* # carriage returns scanned so far. *)
+ class: INTEGER; (* Scan result: Int, Real, String etc. *)
+ i: LONGINT;
+ x: REAL;
+ y: LONGREAL;
+ c: CHAR;
+ len: SHORTINT; (* Length of name or string scanned. *)
+ s: ARRAY 64 OF CHAR;
+ obj: Objects.Object
+ END;
+
+ Buffer = POINTER TO BufDesc; (* Temporary container of text stretches. *)
+ BufDesc = RECORD
+ len: LONGINT; (* # characters in buffer. *)
+ END;
+
+ Writer = RECORD (* Used to write a stream of textual data in a buffer. *)
+ buf: Buffer; (* Associated buffer. *)
+ lib: Objects.Library; (* Current font/library of characters written. *)
+ col: SHORTINT; (* Current color of text being written. *)
+ voff: SHORTINT (* Current vertical offset of text being written. *)
+ END;
+
+ VAR (* First character of a text block. *)
+ TextBlockId: CHAR;
+
+(* Load text block from ASCII file f to text T. *)
+ PROCEDURE LoadAscii (T: Text; f: Files.File);
+
+(* Load text block from file f at position pos to text T (assumes that the text
+id has been read already). len returns length. *)
+ PROCEDURE Load (T: Text; f: Files.File; pos: LONGINT; VAR len: LONGINT);
+
+(* Store text T on disk file f at position pos. Writes the first id character
+too. len is the number of bytes written. *)
+ PROCEDURE Store (T: Text; f: Files.File; pos: LONGINT; VAR len: LONGINT);
+
+(* Open text T from file specified by name. A new text is opened when name =
+"". *)
+ PROCEDURE Open (T: Text; name: ARRAY OF CHAR);
+
+(* Text generator procedure. Resulting text is assigned to Objects.NewObj. *)
+ PROCEDURE New;
+
+(* Insert buffer B in text T position pos. B is emptied. *)
+ PROCEDURE Insert (T: Text; pos: LONGINT; B: Buffer);
+
+(* Append buffer to the end of text T. B is emptied. *)
+ PROCEDURE Append (T: Text; B: Buffer);
+
+(* Delete text stretch [beg, end[. *)
+ PROCEDURE Delete (T: Text; beg, end: LONGINT);
+
+(* Replace [beg, end[ of T with contents of buffer B. B is emptied. *)
+ PROCEDURE Replace (T: Text; beg, end: LONGINT; B: Buffer);
+
+(* Change character attributes within stretch [beg, end[ of text T. sel selects
+the attributes to be changed: 0, 1, 2 IN sel = fnt, col, voff selected. *)
+ PROCEDURE ChangeLooks (T: Text; beg, end: LONGINT; sel: SET; lib: Objects.Library; col, voff: SHORTINT);
+
+(* Open a new text buffer B. *)
+ PROCEDURE OpenBuf (B: Buffer);
+
+(* Save stretch [beg, end[ of T in buffer B. *)
+ PROCEDURE Save (T: Text; beg, end: LONGINT; B: Buffer);
+
+(* Append copy of source buffer SB to destination buffer DB. *)
+ PROCEDURE Copy (SB, DB: Buffer);
+
+(* Recall previously deleted text. *)
+ PROCEDURE Recall (VAR B: Buffer);
+
+(* Default handler for text objects. This handler understands Objects.AttrMsg(for
+Gen attribute), Objects.CopyMsg, Objects.BindMsg, and Objects.FileMsg only.
+*)
+ PROCEDURE Handle (obj: Objects.Object; VAR M: Objects.ObjMsg);
+
+(* Open Finder at position pos in T. The finder is automatically advanced to
+the next object in text. *)
+ PROCEDURE OpenFinder (VAR F: Finder; T: Text; pos: LONGINT);
+
+ (* Advance Finder to next object in text and return current object. *)
+ PROCEDURE FindObj (VAR F: Finder; VAR obj: Objects.Object);
+
+(* Open text reader R and set it up at position pos in text T. *)
+ PROCEDURE OpenReader (VAR R: Reader; T: Text; pos: LONGINT);
+
+(* Read next character into ch. R.eot is set when the last character is read.
+The fields lib, voff and col of R give
+information about the last character read. *)
+ PROCEDURE Read (VAR R: Reader; VAR ch: CHAR);
+
+(* Return reader's position within the text. *)
+ PROCEDURE Pos (VAR R: Reader): LONGINT;
+
+(* Open text scanner S and set it up at position pos in text T. *)
+ PROCEDURE OpenScanner (VAR S: Scanner; T: Text; pos: LONGINT);
+
+(* Read the next symbol. Whitespace is ignored. CR increments the line counter.
+*)
+ PROCEDURE Scan (VAR S: Scanner);
+
+(* Open a new writer W. *)
+ PROCEDURE OpenWriter (VAR W: Writer);
+
+(* Set writer W to font fnt. *)
+ PROCEDURE SetFont (VAR W: Writer; fnt: Objects.Library);
+
+(* Set writer W to color col. *)
+ PROCEDURE SetColor (VAR W: Writer; col: SHORTINT);
+
+(* Set writer W to vertical offset voff. Vertical offset controls the writing
+of super- and sub-scripts. *)
+ PROCEDURE SetOffset (VAR W: Writer; voff: SHORTINT);
+
+(* Write character ch to writer W's buffer. *)
+ PROCEDURE Write (VAR W: Writer; ch: CHAR);
+
+(* Write an end-of-line character to W's buffer. *)
+ PROCEDURE WriteLn (VAR W: Writer);
+
+(* Write string s to W's buffer. *)
+ PROCEDURE WriteString (VAR W: Writer; s: ARRAY OF CHAR);
+
+(* Write integer x to W's buffer. Spaces are padded to the left until the number
+field is at least n characters long. *)
+ PROCEDURE WriteInt (VAR W: Writer; x, n: LONGINT);
+
+(* Write a hexadecimal representation of x to W's buffer. *)
+ PROCEDURE WriteHex (VAR W: Writer; x: LONGINT);
+
+(* Write the hexadecimal representation of x to W's buffer. *)
+ PROCEDURE WriteRealHex (VAR W: Writer; x: REAL);
+
+(* Write the hexadecimal representation of x to W's buffer. *)
+ PROCEDURE WriteLongRealHex (VAR W: Writer; x: LONGREAL);
+
+(* Write real x to W's buffer using n character positions. *)
+ PROCEDURE WriteReal (VAR W: Writer; x: REAL; n: LONGINT);
+
+(* Write real x in a fixed point notation. n is the overall minimal length for
+the output field,
+f the number of fraction digits following the decimal point, E the fixed exponent
+(printed only
+when E # 0). *)
+ PROCEDURE WriteRealFix (VAR W: Writer; x: REAL; n, f, E: LONGINT);
+
+(* Write LONGREAL x to W's buffer using n character positions. *)
+ PROCEDURE WriteLongReal (VAR W: Writer; x: LONGREAL; n: LONGINT);
+
+(* Write LONGREAL x in a fixed point notation. n is the overall minimal length
+for the output field, f the number of fraction digits following the decimal
+point, D the fixed exponent (printed only when D # 0). *)
+ PROCEDURE WriteLongRealFix (VAR W: Writer; x: LONGREAL; n, f, D: LONGINT);
+
+(* Write the time and date to W's buffer. *)
+ PROCEDURE WriteDate (VAR W: Writer; t, d: LONGINT);
+
+(* Write a SET value to writer W. *)
+ PROCEDURE WriteSet (VAR W: Writer; s: SET);
+
+(* Write obj to writer W. *)
+ PROCEDURE WriteObj (VAR W: Writer; obj: Objects.Object);
+END Texts.
+
+(* Remarks:
+
+1. Text streams consists of sequence of characters (type Fonts.Char) and and
+
+non-character objects (in different colors, fonts, and vertical offsets). The
+only
+way to distinguish between a character and an object in the text stream is by
+
+fetching the character/object from its library and then making a type test.
+
+The library of a character/object is given by the lib field of the reader while
+
+advancing through a text stream. The reference number of a character/object
+
+is the ordinal number of the character read (i.e. ORD(ch)). As character objects
+
+are bound to character fonts (Fonts.Font), a quick type test of the Reader lib
+
+field against Fonts.Font also settles the question. Non-character objects of
+a
+text are typically bound to the obs library field of the text descriptor.
+
+2. The non-character objects of a text stream must have reference numbers
+in the range 0 <= ref < 256, and must be bound to a library (not necessarily
+
+obs of the text descriptor). Writing non-character objects involves binding
+it
+to a library (say T.obs), changing the font of the Writer, and the writing the
+
+reference number of the non-character object into the writer's buffer.
+Afterwards the writer font is reset to its old value. More that 256 non-character
+
+objects can be written into the text by allocating a new library when the old
+
+library is full, and attaching it to the obs field of the text descriptor. The
+obs field
+just acts as a placeholder for libraries and is not used by the texts directly.
+
+3. There are two mechanisms to read from a text and one to write to a text.
+
+The Readers allow characterwise reading from a certain text position onwards.
+
+The Scanners allow reading of formatted tokens like names, strings, numbers
+and
+characters. Writers are used to write characters into temporary holding areas
+
+called buffers. Buffers contains large sequences of objects (both character
+and
+non-character) and allow low-level temporary manipulation. The difference
+between texts and buffers involve the display update operations. Each text can
+
+possibly be represented on the display by some kind of text editor or viewer.
+
+When a module manipulates a text, a message called the UpdateMsg (type
+Texts.UpdateMsg) is broadcast to all viewers or text editors representing the
+text.
+They then update their representation accordingly. To prevent broadcasts being
+
+sent for potentially each character being written into a text, the text manipulation
+
+is first done in a buffer. Operations on buffers do not result in update messages
+
+being broadcasted. Only when a buffer is applied to a text (inserted or appended),
+
+the texts broadcasts an update message. By convention, once a buffer is applied
+to a text, its contents is emptied.
+
+4. The scanner classes indicate what token was scanned. The scanner understands
+the following token types:
+
+ Name Longest sequence starting with "A".."Z", "a".."z", ".", "/", and containing
+
+ "A".."Z", "a".."z", "0".."9", "@", ".", "/", ":", "_", 80X..96X
+ String Any character sequence surrounded by double quotes, i.e. "string".
+ The quotes are not returned in the s field of the scanner descriptor.
+ Int Any valid integer number.
+ Real Any valid REAL number, including exponent E.
+ LongReal Any valid LONGREAL number, including exponent D.
+ Char A character (single) not classified as one of the above.
+
+5. The end of line character is carriage return (CR or 0DX), tabulators are
+9X.
+Unprintable characters are show on the display as smallish square boxes.
+
+6. Vertical offsets are typically measured in screen pixels (positive or negative
+
+to the text base line).
+
+7. The Finder allow quick searching for non-character objects in a text.
+
+8. The meaning of the UpdateMsg fields are defined as in the following table
+
+listed according to the procedures that broadcast the message. Note that a text
+
+stretch identified by (beg, end) does not include the character at position
+end
+in the text. Below, M is of type Texts.UpdateMsg and B stands for a buffer.
+
+ Delete(beg, end) M.beg = beg
+ M.end = end
+ M.len = 0
+ Replace(beg, end, B) M.beg = beg
+ M.end = end
+ M.len = B.len
+ ChangeLooks(beg, end) M.beg = beg
+ M.end = end
+ M.len = end - beg
+ Insert(pos, buf) M.beg = pos
+ M.end = pos
+ M.len = B.len
+
+The general scheme is that the stretch between M.beg and M.end was "deleted",
+
+and a new stretch of length M.len was inserted at M.beg. The message indicates
+
+a change AFTER it has already been made by the texts module.
+
+9. There is an asymmetry in writing and reading texts to a file. Each text "block"
+
+in a file is identified by a first character. Reading a text block requires
+that the
+starting position does not include this character, while writing a text block
+writes
+the id character automatically.
+
+10. Opening of non-text files is allowed with Texts.Open; they are simply converted
+
+to ASCII streams. Storing such an opened text will convert it into an Oberon
+text.
+Note that the EditTools package allows the manipulation of ASCII texts both
+in
+MSDOS and UNIX format.
+*)
diff --git a/examples/AGRS/Viewers.Def b/examples/AGRS/Viewers.Def
new file mode 100644
index 0000000..62e1644
--- /dev/null
+++ b/examples/AGRS/Viewers.Def
@@ -0,0 +1,100 @@
+(*
+https://web.archive.org/web/20041227180027/http://www.oberon.ethz.ch:80/ethoberon/defs/Viewers.Def.html
+*)
+DEFINITION Viewers; (* portable *)
+
+(*
+The module viewers provide the data type for implementing the tiled viewers
+
+of the Oberon system. Each track of the Oberon system consists of a number of
+viewers.
+*)
+ IMPORT Display;
+
+ TYPE
+ Viewer = POINTER TO ViewerDesc;
+ ViewerDesc = RECORD ( Display.FrameDesc )
+ state: INTEGER;
+ (* state > 1: displayed
+ state = 1: filler
+ state = 0: closed
+ state < 0: suspended.*)
+ END;
+
+ VAR
+ curW: INTEGER; (* Current width of the logical display. *)
+ minH: INTEGER; (* Minimum viewer height. *)
+
+ (* Open a new viewer V with top at Y in track X. *)
+ PROCEDURE Open (V: Viewer; X, Y: INTEGER);
+
+ (* Expand or shrink a viewer vertically to new top Y. *)
+ PROCEDURE Change (V: Viewer; Y: INTEGER);
+
+ (* Remove viewer V from the display. *)
+ PROCEDURE Close (V: Viewer);
+
+ (* Recall most recently closed viewer. *)
+ PROCEDURE Recall (VAR V: Viewer);
+
+ (* Return viewer located at display coordinates X, Y. *)
+ PROCEDURE This (X, Y: INTEGER): Viewer;
+
+ (* Return next upper neighbour of V in a track. *)
+ PROCEDURE Next (V: Viewer): Viewer;
+
+ (* In the track at X locate the following viewers: filler fil, bottom-most
+viewer, an
+ alternative viewer alt of height >= H, and the viewer with the maximum height.
+*)
+ PROCEDURE Locate (X, H: INTEGER; VAR fil, bot, alt, max: Display.Frame);
+
+ (* Append to the current logical display and init track of width W and height
+H, and install filler. *)
+ PROCEDURE InitTrack (W, H: INTEGER; Filler: Viewer);
+
+ (* Open new track overlaying span of [X, X +W[. *)
+ PROCEDURE OpenTrack (X, W: INTEGER; Filler: Viewer);
+
+ (* Close track at X and restore overlaid tracks. *)
+ PROCEDURE CloseTrack (X: INTEGER);
+END Viewers.
+
+(* Remarks:
+
+1. Each track consists of a filler and a set of viewers linked together in a
+ring
+(with the next field) with the filler as sentinel. The filler is the top-most
+viewer
+in a track and covers the remainding part of the track the viewers do not cover.
+
+The set of tracks form the root objects of the display space.
+
+2. Tracks can overlay each other. Closing a track exposes the track (and viewers)
+
+lying below it. Overlayed tracks and viewers do not receive message broadcasts
+
+in the display space. Before being overlayed, the contents of a track receive
+a
+Display.ControlMsg with id set to suspend.
+
+3. The logical display increases from X coordinate 0 onwards through multiple
+
+physical displays. Opening a new display involves adding a tracks beyond curW
+
+(typically a system and user track). Oberon uses a single coordinate system
+to
+address all the different displays. Note that many Oberon systems restrict the
+
+size of the display to the size of the host window.
+
+4. Changing the top coordinate of a viewer with Change results in a
+Display.ModifyMsg with id set to reduce or extend (in size) being sent
+to the viewer contents (located in V.dsc).
+
+5. The ratio of user and system track width is 5:3.
+
+6. Programmers seldom need to use the Viewers module. Higher level modukes
+like Documents provide a simpler display abstraction.
+
+*)
diff --git a/language-oberon.cabal b/language-oberon.cabal
index a96d8af..99702e7 100644
--- a/language-oberon.cabal
+++ b/language-oberon.cabal
@@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: language-oberon
-version: 0.1
+version: 0.1.1
synopsis: Parser and pretty-printer for the Oberon programming language
description:
The library and the executable support both the original Oberon and the Oberon-2 programming language, as described
@@ -26,7 +26,7 @@ maintainer: blamario@protonmail.com
-- copyright:
category: Language
build-type: Simple
-extra-source-files: ChangeLog.md
+extra-source-files: ChangeLog.md, examples/AGRS/*.Def, examples/AGRS/*.Mod
cabal-version: >=1.10
library
@@ -49,11 +49,11 @@ executable parse
optparse-applicative
default-language: Haskell2010
-test-suite examples
- type: exitcode-stdio-1.0
- build-depends: base >= 4.7 && < 5,
- either == 5.*, directory < 2, filepath < 1.5,
- tasty >= 0.7, tasty-hunit,
- language-oberon
- main-is: test/Test.hs
- default-language: Haskell2010
+test-suite examples
+ type: exitcode-stdio-1.0
+ build-depends: base >= 4.7 && < 5,
+ either == 5.*, directory < 2, filepath < 1.5,
+ tasty >= 0.7, tasty-hunit,
+ language-oberon
+ main-is: test/Test.hs
+ default-language: Haskell2010