summaryrefslogtreecommitdiff
path: root/examples/AGRS/AGRS.Mod
diff options
context:
space:
mode:
Diffstat (limited to 'examples/AGRS/AGRS.Mod')
-rw-r--r--examples/AGRS/AGRS.Mod1033
1 files changed, 1033 insertions, 0 deletions
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.
+