EDIFSemanticsImpl.Mesa
Spreitzer, February 24, 1986 11:50:29 pm PST
DIRECTORY Atom, Convert, EDIFfing, EDIFGrammar, EDIFSemantics, HashTable, IO, Rope, StructuredStreams;
EDIFSemanticsImpl:
CEDAR
PROGRAM
IMPORTS Atom, Convert, EDIFGrammar, HashTable, IO, Rope
EXPORTS EDIFSemantics
= BEGIN OPEN EDIFGrammar, EDIFfing, EDIFSemantics, SS: StructuredStreams;
SyntaxError:
PUBLIC
SIGNAL [
pt: ParseTree,
msg: ROPE,
severity: Severity ← error
] = CODE;
PreProcessHead:
PROC [macros: HashTable.Table, ptl: ParseTreeList]
RETURNS [pptl: ParseTreeList] = {
pptl ← ptl;
WHILE pptl #
NIL
AND pptl.first.type = list
DO
call: REF list ParseTreePrivate = NARROW[pptl.first];
key: REF identifier ParseTreePrivate = NARROW[call.children.first];
md: MacroDef = NARROW[macros.Fetch[key.id].value];
actuals: ParseTreeList ← call.children.rest;
firstReplacement, lastReplacement: ParseTreeList;
bindings: HashTable.Table = MakeAtomDict[];
EvalGenList:
PROC [ptgl: ParseTreeGeneratorList,
GetIndex:
PROC [id:
ATOM]
RETURNS [i:
INT]]
RETURNS [head, tail: ParseTreeList ←
NIL] = {
Append: PROC [pt: ParseTree] = {l: ParseTreeList = LIST[pt]; AppendList[l, l]};
AppendList:
PROC [lHead, lTail: ParseTreeList] = {
IF tail = NIL THEN head ← lHead ELSE tail.rest ← lHead;
IF lHead # NIL THEN tail ← lTail;
};
FOR gl: ParseTreeGeneratorList ← ptgl, gl.rest
WHILE gl #
NIL
DO
g: ParseTreeGenerator = gl.first;
WITH g
SELECT
FROM
x:
REF literal ParseTreeGeneratorPrivate => {
Append[CopyTree[x.pt, call, x.quaPT]];
};
x:
REF name ParseTreeGeneratorPrivate => {
Append[CopyTree[NARROW[bindings.Fetch[x.id].value], call, x.quaPT]];
};
x:
REF buildList ParseTreeGeneratorPrivate => {
subList: ParseTreeList = EvalGenList[x.elts, GetIndex].head;
pt: ParseTree = MakeTree[list, subList, call, x.quaPT];
Append[pt];
};
x:
REF buildName ParseTreeGeneratorPrivate => {
pt: ParseTree = MakeTree[identifier, x.id, call, x.quaPT];
Append[pt];
};
x:
REF forEach ParseTreeGeneratorPrivate => {
domVals, domTail: LIST OF ParseTreeList ← NIL;
length: INT;
originalBindings: HashTable.Table = MakeAtomDict[];
FOR nl: ATOMList ← x.domain, nl.rest
WHILE nl #
NIL
DO
val: ParseTree = NARROW[bindings.Fetch[nl.first].value];
this: LIST OF ParseTreeList ← LIST[LIST[val]];
IF NOT originalBindings.Insert[nl.first, val] THEN ERROR;
WITH val
SELECT
FROM
y:
REF list ParseTreePrivate =>
WITH y.children.first
SELECT
FROM
z: REF identifier ParseTreePrivate => IF AtomNameEq[z.id, $Multiple] THEN this.first ← y.children.rest;
ENDCASE;
ENDCASE;
IF domTail = NIL THEN domVals ← this ELSE domTail.rest ← this;
domTail ← this;
SELECT nl
FROM
x.domain => length ← PTLLength[this.first];
ENDCASE => IF length # PTLLength[this.first] THEN ERROR;
ENDLOOP;
FOR i:
INT
IN [0 .. length)
DO
nl: ATOMList ← x.domain;
vl: LIST OF ParseTreeList ← domVals;
subHead, subTail: ParseTreeList;
SubGetIndex:
PROC [id:
ATOM]
RETURNS [i:
INT] = {
IF originalBindings.Fetch[id].found THEN RETURN [i];
i ← GetIndex[id];
};
WHILE vl #
NIL
DO
IF NOT bindings.Replace[nl.first, vl.first.first] THEN ERROR;
vl.first ← vl.first.rest;
vl ← vl.rest;
nl ← nl.rest;
ENDLOOP;
[subHead, subTail] ← EvalGenList[x.range, SubGetIndex];
AppendList[subHead, subTail];
ENDLOOP;
FOR nl: ATOMList ← x.domain, nl.rest
WHILE nl #
NIL
DO
IF NOT bindings.Replace[nl.first, originalBindings.Fetch[nl.first].value] THEN ERROR;
ENDLOOP;
};
x:
REF index ParseTreeGeneratorPrivate => {
i: INT = GetIndex[x.var];
pt: ParseTree = MakeTree[integer, NEW [INT ← i], call, x.quaPT];
Append[pt];
};
ENDCASE => ERROR;
ENDLOOP;
};
GetNoIndex: PROC [id: ATOM] RETURNS [i: INT] = {ERROR};
IF md = NIL THEN RETURN;
FOR fl: IdPtList ← md.requiredFormals, fl.rest
WHILE fl #
NIL
DO
actuals ← PreProcessHead[macros, actuals];
IF NOT bindings.Insert[fl.first.id, actuals.first] THEN ERROR;
actuals ← actuals.rest;
ENDLOOP;
FOR fl: IdPtList ← md.optionalFormals, fl.rest
WHILE fl #
NIL
DO
actuals ← PreProcessHead[macros, actuals];
IF actuals = NIL THEN EXIT;
IF NOT bindings.Insert[fl.first.id, actuals.first] THEN ERROR;
actuals ← actuals.rest;
ENDLOOP;
IF actuals #
NIL
AND md.extraFormals #
NIL
THEN {
tails: LIST OF ParseTreeList ← NIL;
FOR fl: IdPtList ← md.extraFormals, fl.rest
WHILE fl #
NIL
DO
tails ← CONS[NIL, tails];
ENDLOOP;
WHILE actuals #
NIL
DO
tailList: LIST OF ParseTreeList ← tails;
FOR fl: IdPtList ← md.extraFormals, fl.rest
WHILE fl #
NIL
DO
tail: ParseTreeList;
actuals ← PreProcessHead[macros, actuals];
IF actuals = NIL THEN EXIT;
tail ← LIST[actuals.first];
IF tailList.first = NIL THEN {IF NOT bindings.Insert[fl.first.id, tail] THEN ERROR} ELSE tailList.first.rest ← tail;
tailList.first ← tail;
actuals ← actuals.rest;
tailList ← tailList.rest;
ENDLOOP;
ENDLOOP;
FOR fl: IdPtList ← md.extraFormals, fl.rest
WHILE fl #
NIL
DO
ptl: ParseTreeList ← NARROW[bindings.Fetch[fl.first.id].value];
IF NOT bindings.Replace[fl.first.id, MakeMultiple[ptl, call, fl.first]] THEN ERROR;
ENDLOOP;
};
IF actuals # NIL AND NOT md.okToSkipTail THEN ERROR;
[firstReplacement, lastReplacement] ← EvalGenList[md.generators, GetNoIndex];
IF lastReplacement # NIL THEN lastReplacement.rest ← pptl.rest ELSE firstReplacement ← pptl.rest;
pptl ← firstReplacement;
ENDLOOP;
};
CopyTree:
PROC [ur, call, gen: ParseTree]
RETURNS [copy: ParseTree] = {
copy ← NEW [ParseTreePrivate ← ur^];
copy.origin ← [];
copy.replacing ← call;
copy.generator ← gen;
};
MakeTree:
PROC [type: ParseTreeNodeType, val:
REF
ANY, call, gen: ParseTree]
RETURNS [pt: ParseTree] = {
pt ←
SELECT type
FROM
string => NEW [ParseTreePrivate ← [variant: string[NARROW[val]]]],
integer => NEW [ParseTreePrivate ← [variant: integer[NARROW[val, REF INT]^]]],
identifier => NEW [ParseTreePrivate ← [variant: identifier[NARROW[val]]]],
list => NEW [ParseTreePrivate ← [variant: list[NARROW[val]]]],
ENDCASE => ERROR;
pt.replacing ← call;
pt.generator ← gen;
};
MakeMultiple:
PROC [ptl: ParseTreeList, call, gen: ParseTree]
RETURNS [pt: ParseTree] = {
subList: ParseTreeList = CONS[MakeTree[identifier, $Multiple, call, gen], ptl];
pt ← MakeTree[list, subList, call, gen];
};
DiscardTail:
PROC =
INLINE {GarBage ←
TRUE};
GarBage: BOOL ← FALSE;
Traverse:
PUBLIC
PROC [pt: ParseTree, r: Rule, level: Level, description:
ROPE, context:
REF
ANY ←
NIL, macros: HashTable.Table ←
NIL, nc: NamingContext ←
NIL]
RETURNS [match:
BOOL, result:
REF
ANY ←
NIL] = {
ptl: ParseTreeList = LIST[pt];
rem: ParseTreeList;
onces: Onces = NewOnces[];
SetResult: PROC [res: REF ANY, pt: ParseTree] = {result ← res};
IF macros = NIL THEN macros ← MakeAtomDict[];
IF nc = NIL THEN nc ← CreateHashTableNamingContext[];
[match: match, ptail: rem] ← TreeWork[ptl, NIL, r, r, level, onces, FALSE, description, NIL, context, DiscardLevel, macros, SetResult, nc];
IF rem # NIL THEN DiscardTail[];
};
TreeWork:
PUBLIC
PROC [ptl: ParseTreeList, parentTree: ParseTree, r, repeatSub: Rule, level: Level, onces: Onces, okToFail:
BOOL, description:
ROPE, sem: Semantics, context:
REF
ANY,
SetLevel:
PROC [
nLevel: Level, ups:
NAT], macros: HashTable.Table,
ConsumeResult:
PROC [res:
REF
ANY, pt: ParseTree], nc: NamingContext]
RETURNS [match:
BOOL, ptail: ParseTreeList, result:
REF
ANY] = {
urLevel: Level = level;
SubSetLevel:
PROC [
nLevel: Level, ups:
NAT] = {
level ← nLevel;
IF ups > 0 THEN SetLevel[level, ups-1]};
SetThisLevel: PROC [nLevel: Level, ups: NAT] = {level ← nLevel; SetLevel[level, ups]};
DefineMacro:
PROC [name:
ATOM, def: MacroDef] = {
IF NOT macros.Insert[name, def] THEN ERROR;
};
ptl ← PreProcessHead[macros, ptl];
match ← TRUE;
ptail ← ptl;
result ← NIL;
IF ptl =
NIL
THEN
SELECT r.class
FROM
list, choice, levelGuard, nonTerminal, terminal => {
match ← FALSE;
IF NOT okToFail THEN SyntaxError[parentTree, Rope.Cat["Can't match ", description, " to the empty list"]];
};
repeat => NULL;
ENDCASE => ERROR;
IF match
THEN
WITH r
SELECT
FROM
x:
REF list RulePrivate => {
spt: ParseTree = ptl.first;
WITH spt
SELECT
FROM
y:
REF list ParseTreePrivate => {
sptl: ParseTreeList = y.children;
Work:
PROC [cutAfterFirst:
BOOL]
RETURNS [match:
BOOL] = {
ptRest: ParseTreeList ← sptl;
WhatToDoWithSubResult: PROC [res: REF ANY, pt: ParseTree] ← DiscardResult;
cutted, lastWasStar: BOOL ← FALSE;
subResult, subContext: REF ANY ← NIL;
subDescription: ROPE ← Rope.Concat["keyword of ", description];
first, subMatch: BOOL ← match ← TRUE;
ruleRest: RuleList;
index: INT ← 0;
ConsumeSubResult:
PROC [res:
REF
ANY, pt: ParseTree] = {
sem.PerSubResult[context, subContext, res, index, pt];
};
FOR ruleRest ← x.elts, ruleRest.rest
WHILE ruleRest #
NIL
DO
[subMatch, ptRest, subResult] ← TreeWork[ptRest, spt, ruleRest.first, repeatSub, level, onces, okToFail AND NOT cutted, subDescription, NIL, subContext, SubSetLevel, macros, WhatToDoWithSubResult, nc];
IF
NOT subMatch
THEN {
IF NOT cutted THEN match ← FALSE;
EXIT};
WITH ruleRest.first
SELECT
FROM
z: REF repeat RulePrivate => lastWasStar ← z.zero;
ENDCASE => lastWasStar ← FALSE;
IF first
THEN {
first ← FALSE;
subDescription ← Rope.Concat["an argument of ", description];
IF cutAfterFirst
THEN {
cutted ← TRUE;
IF sem #
NIL
THEN {
IF sem.Before # NIL THEN subContext ← sem.Before[context, spt];
IF sem.HandleSpecially #
NIL
THEN {
keyword: ATOM = NARROW[subResult];
IF sem.PerSubResult # NIL THEN ERROR;
IF ConsumeResult # DiscardResult THEN ERROR;
[subMatch, ptRest, result, lastWasStar] ← sem.HandleSpecially[ptRest, spt, ruleRest.first, repeatSub, level, onces, subDescription, NIL, subContext, SubSetLevel, macros, ConsumeResult, nc, keyword];
EXIT;
};
IF sem.PerSubResult # NIL THEN TRUSTED {WhatToDoWithSubResult ← ConsumeSubResult};
};
};
};
index ← index + 1;
ENDLOOP;
IF subMatch
THEN {
IF ptRest #
NIL
AND lastWasStar
AND (
NOT okToFail)
AND cutAfterFirst
THEN {
SyntaxError[ptRest.first, "Unrecognized construct found after soft end", warning];
We make noise here because if author flubs something trying to match ( ... whatever*) or ( ... [whatever]), we detect no error because it's OK to have unrecognized stuff at the end of a list (yech).
};
IF ptRest # NIL THEN DiscardTail[];
IF sem # NIL AND sem.After # NIL AND cutAfterFirst THEN result ← sem.After[context, subContext, spt, SubSetLevel, DefineMacro];
IF cutAfterFirst THEN ConsumeResult[result, spt];
};
};
match ← Work[x.cutAfterFirst];
IF match AND NOT x.cutAfterFirst THEN match ← Work[TRUE];
IF match THEN ptail ← ptl.rest;
};
ENDCASE => {match ←
FALSE;
IF NOT okToFail THEN SyntaxError[spt, Rope.Cat["Expected ", description, ", found something else"]]};
};
x:
REF repeat RulePrivate => {
subOnces: Onces = NewOnces[];
i: INT ← 0;
IF NOT (x.zero OR x.moreThanOne) THEN ERROR;
FOR i ← 0, i+1
WHILE i < 1
OR x.moreThanOne
DO
subMatch: BOOL;
[subMatch, ptail,] ← TreeWork[ptail, parentTree, x.sub, x.sub, level, subOnces, okToFail OR x.zero OR i#0, description, NIL, context, SetThisLevel, macros, ConsumeResult, nc];
IF NOT subMatch THEN EXIT;
ENDLOOP;
match ←
SELECT i
FROM
=0 => x.zero,
=1 => TRUE,
>1 => x.moreThanOne,
ENDCASE => ERROR;
};
x:
REF choice RulePrivate => {
subRule: Rule ← NIL;
IF x.choices = NIL OR x.choices.rest = NIL THEN ERROR;
FOR rl: RuleList ← x.choices, rl.rest
WHILE rl #
NIL
DO
[match, ptail, result] ← TreeWork[ptl, parentTree, rl.first, repeatSub, level, onces, TRUE, "<this text will never be seen either>", NIL, context, SetThisLevel, macros, ConsumeResult, nc];
IF match THEN {subRule ← rl.first; EXIT};
REPEAT
FINISHED => IF NOT okToFail THEN SyntaxError[ptl.first, Rope.Cat["Failed to match any of the choices for ", description]];
ENDLOOP;
IF match AND sem # NIL AND sem.FilterResult # NIL THEN result ← sem.FilterResult[result, subRule, nc];
};
x:
REF levelGuard RulePrivate => {
IF level
NOT
IN [x.min .. x.max]
THEN {
match ← FALSE;
IF NOT okToFail THEN SyntaxError[ptl.first, IO.PutFR["Construct (%g) appropriate for levels [%g..%g] use in level %g", [rope[description]], [integer[x.min]], [integer[x.max]], [integer[level]]]];
}
ELSE [match, ptail, result] ← TreeWork[ptl, parentTree, x.r, repeatSub, level, onces, okToFail, description, sem, context, SetThisLevel, macros, ConsumeResult, nc];
};
x:
REF nonTerminal RulePrivate => {
def: Rule = GetRuleDef[x.category];
subSem: Semantics = GetSemantics[x.category];
IF x.onceOnly
AND OncesIncludes[onces, x.category]
THEN {
match ← FALSE;
IF NOT okToFail THEN SyntaxError[ptl.first, IO.PutFR["Multiple occurrances of %g as %g", [atom[x.category]], [rope[description]]]];
}
ELSE {
IF x.onceOnly THEN InsertOncer[onces, x.category];
[match, ptail, result] ← TreeWork[ptl, parentTree, def, repeatSub, level, onces, okToFail, Atom.GetPName[x.category], subSem, context, SetThisLevel, macros, ConsumeResult, nc];
};
};
x:
REF terminal RulePrivate => {
match ← FALSE;
SELECT x.category
FROM
String => {
WITH ptl.first
SELECT
FROM
y: REF string ParseTreePrivate => {match ← x.value = NIL OR y.s.Equal[NARROW[x.value]]; result ← y.s};
ENDCASE;
};
Integer => {
WITH ptl.first
SELECT
FROM
y: REF integer ParseTreePrivate => {match ← x.value = NIL OR y.i = NARROW[x.value, REF INT]^; result ← NEW [INT ← y.i]}
ENDCASE;
};
Identifier => {
WITH ptl.first
SELECT
FROM
y: REF identifier ParseTreePrivate => {match ← x.value = NIL OR AtomNameEq[NARROW[x.value], y.id]; result ← y.id}
ENDCASE;
};
Form => {match ← TRUE; IF x.value # NIL THEN ERROR; result ← ptl.first};
ENDCASE => ERROR;
IF match
THEN {
ConsumeResult[result, ptl.first];
ptail ← ptl.rest;
}
ELSE IF NOT okToFail THEN SyntaxError[ptl.first, IO.PutFR["Got %g when expecting %g", [rope[FmtPT[ptl.first]]], [rope[FmtTR[x]]]]];
};
ENDCASE => ERROR;
result ← result;
};
DiscardResult: PUBLIC PROC [res: REF ANY, pt: ParseTree] = {};
DiscardLevel: PROC [nLevel: Level, ups: NAT];
NewOnces:
PROC
RETURNS [onces: Onces] = {
onces ← MakeAtomDict[]};
OncesIncludes:
PROC [onces: Onces, category:
ATOM]
RETURNS [b:
BOOL] = {
b ← onces.Fetch[category].found};
InsertOncer:
PROC [onces: Onces, category:
ATOM] = {
IF NOT onces.Insert[category, $T] THEN ERROR};
FmtPT:
PROC [pt: ParseTree]
RETURNS [rope:
ROPE] = {
WITH pt
SELECT
FROM
x: REF string ParseTreePrivate => rope ← Rope.Cat["literal string ", Convert.RopeFromRope[x.s]];
x: REF integer ParseTreePrivate => rope ← Rope.Cat["literal integer ", Convert.RopeFromInt[x.i]];
x: REF identifier ParseTreePrivate => rope ← Rope.Cat["identifier ", Atom.GetPName[x.id]];
x: REF list ParseTreePrivate => rope ← "a list";
ENDCASE => ERROR;
};
FmtTR:
PROC [tr:
REF terminal RulePrivate]
RETURNS [rope:
ROPE] = {
SELECT tr.category
FROM
String => rope ← IF tr.value = NIL THEN "a string" ELSE Rope.Cat["the string ", Convert.RopeFromRope[NARROW[tr.value]]];
Integer => rope ← IF tr.value = NIL THEN "an integer" ELSE Rope.Cat["the integer ", Convert.RopeFromInt[NARROW[tr.value, REF INT]^]];
Identifier => rope ← IF tr.value = NIL THEN "an identifier" ELSE Rope.Cat["the identifier ", Atom.GetPName[NARROW[tr.value]]];
Form => rope ← IF tr.value = NIL THEN "anything" ELSE ERROR;
ENDCASE => ERROR;
};
semantics: HashTable.Table = MakeAtomDict[];
SS:
PUBLIC
PROC [category:
ATOM, semp: SemanticsPrivate] = {
sem: Semantics = NEW [SemanticsPrivate ← semp];
IF NOT semantics.Insert[category, sem] THEN ERROR;
};
GetSemantics:
PROC [category:
ATOM]
RETURNS [sem: Semantics] = {
sem ← NARROW[semantics.Fetch[category].value];
};
AtomNameEq:
PUBLIC
PROC [n1, n2:
ATOM]
RETURNS [eq:
BOOL] = {
eq ← Atom.GetPName[n1].Equal[Atom.GetPName[n2], FALSE]};
PTLLength:
PROC [ptl: ParseTreeList]
RETURNS [length:
INT] = {
length← 0;
FOR ptl ← ptl, ptl.rest WHILE ptl # NIL DO length ← length + 1 ENDLOOP;
length ← length};
HashAtomModCase:
PROC [key:
REF
ANY]
RETURNS [hash:
CARDINAL]
--HashTable.HashProc-- = {
hash ← HashTable.HashRopeModCase[Atom.GetPName[NARROW[key]]];
};
AtomEqualModCase:
PROC [a1, a2:
REF
ANY]
RETURNS [eq:
BOOL]
--HashTable.EqualProc-- = {
eq ← HashTable.RopeEqualModCase[Atom.GetPName[NARROW[a1]], Atom.GetPName[NARROW[a2]]];
};
MakeAtomDict:
PUBLIC
PROC
RETURNS [dict: HashTable.Table] = {
dict ← HashTable.Create[equal: AtomEqualModCase, hash: HashAtomModCase];
};
MakeRopeDict:
PUBLIC
PROC
RETURNS [dict: HashTable.Table] = {
dict ← HashTable.Create[equal: HashTable.RopeEqualModCase, hash: HashTable.HashRopeModCase];
};
Lookup:
PUBLIC
PROC [nc: NamingContext, name:
ATOM]
RETURNS [found:
BOOL, value:
REF
ANY] = {
FOR nc ← nc, nc.parent
WHILE nc #
NIL
DO
[found, value] ← nc.class.Lookup[nc, name];
IF found THEN RETURN;
ENDLOOP;
found ← FALSE;
value ← NIL;
};
Define:
PUBLIC
PROC [nc: NamingContext, name:
ATOM, value:
REF
ANY, re:
BOOL ←
FALSE] = {
nc.class.Define[nc, name, value, re];
};
hashTableNamingContextClass: NamingContextClass =
NEW [NamingContextClassPrivate ← [
LookupHashTableValue,
DefineHashTableValue]];
LookupHashTableValue:
PROC [nc: NamingContext, name:
ATOM]
RETURNS [found:
BOOL, value:
REF
ANY] = {
ht: HashTable.Table = NARROW[nc.data];
[found, value] ← ht.Fetch[name];
};
DefineHashTableValue:
PROC [nc: NamingContext, name:
ATOM, value:
REF
ANY, re:
BOOL ←
FALSE] = {
ht: HashTable.Table = NARROW[nc.data];
SELECT re
FROM
FALSE => IF NOT ht.Insert[name, value] THEN ERROR;
TRUE => [] ← ht.Store[name, value];
ENDCASE => ERROR;
};
CreateHashTableNamingContext:
PUBLIC
PROC [parent: NamingContext ←
NIL]
RETURNS [nc: NamingContext] = {
nc ←
NEW [NamingContextPrivate ← [
parent: parent,
class: hashTableNamingContextClass,
data: MakeAtomDict[]
]];
};
END.