ParserGenImpl:
PROGRAM
IMPORTS Atom, FS, IO, Rope, ParseTable, Lexer
EXPORTS ParserGen = BEGIN
OPEN ParserGen ;
GenParser: PUBLIC PROCEDURE [ filename : ROPE ← "grammar.text" ]
RETURNS [ l: Lexer.Handle, h : ParseTable.Handle, g : OpList, p : ProdList, c : Culprit ] =
{
-- We read a grammar description from the named file, do some consistency checks on it, construct an operator precedence graph from it, solve for the operator precedences, and build a new parse window for its language. (A parse window is a viewer into which one can type strings to be parsed.)
stream : IO.STREAM ← FS.StreamOpen [ filename ];
text : REF ANY ← IO.GetRefAny [ stream ];
IF ( [ opL : g, prL : p, c : c ] ← BldGrammarDescr [ text ] ) . c # NIL THEN ERROR;
IF ( c ← CheckFixities [ g ] ) # NIL THEN ERROR;
IF ( c ← AddPrecGraphEdges [ opL : g, prL : p ] ) # NIL THEN ERROR;
IF ( c ← SolveForPrecs [ g ] ) # NIL THEN ERROR;
h ← ParseTable.NewHandle[];
l ← Lexer.NewHandle[];
AddGrammarToParseWindow [ opL : g, handle : h, l: l ];
};
BldGrammarDescr:
PRIVATE PROCEDURE [ text : REF ANY ]
RETURNS [ opL : OpList ← NIL, prL : ProdList ← NIL, c : Culprit ← NIL ] =
{
-- The text input is the result of GetRefAny on the following:
Grammar ::= ( ClauseList )
Clause ::= (infix Op ...) | (prefix Op ...) | (postfix Op ...) |
(openfix Op ...) | (leftfix Op ...) | (rightfix Op ...) |
(Nonterm Rhs ...)
Rhs ::= (Nonterm Op Nonterm) | (Op Nonterm) | (Nonterm Op) | etc
Op ::= a string within double quotes
Nonterm ::= an identifier, not infix, prefix, etc.
-- The clauses may appear in any order except that the fixity clauses must
all appear before the production clauses. Each kind of clause may appear
more than once. The open/left/rightfix clauses must include the matching
closefix operators, as in (openfix "(" ")" "[" "]").
For example:
((infix "*" "+") (S (S "+" S) (S "*" S)))
is a description for
S ::= S + S | S * S
IF text = NIL THEN RETURN;
FOR clauseList : List ←
NARROW [ text ], clauseList.rest
UNTIL clauseList = NIL DO
{ clause : List =
NARROW [ clauseList.first ];
hdr : REF ANY ← clause.first;
tail : List ← clause.rest;
WITH hdr
SELECT
FROM
h :
ATOM =>
SELECT h
FROM
$prefix, $postfix, $infix, $openfix, $leftfix, $rightfix =>
[ h : opL, c : c ] ← ProcessFixityTuple [ opL, h, tail ];
$comment => NULL
ENDCASE =>
[ p : prL, c : c ] ← AddProdRec [ opL, prL, h, tail ]
ENDCASE => ERROR;
IF c # NIL THEN RETURN;
}
ENDLOOP;
};
ProcessFixityTuple:
PRIVATE PROCEDURE [ opL : OpList, opKind : ATOM, ops : List ]
RETURNS [ h : OpList, c : Culprit ← NIL ] =
{
-- We take the operators and add them and their fixities to opL, yielding h. Note that infix, rightfix, and postfix are mutually exclusive fixities, as are openfix, leftfix, and prefix.
opAtom : ATOM; -- current operator being added
ra : REF ANY; -- REF to OpRec for opAtom, if any, else NIL
ro : REF OpRec; -- REF to OpRec for opAtom
h ← opL; ops ← AtomizeList [ ops ]; -- convert any ROPEs to ATOMs.
WHILE ops # NIL -- for each operator: get an OpRec for it and enter its fixity.
DO
opAtom ← NARROW [ ops.first ]; ops ← ops.rest;
IF ( ra ← FindOpRec [ opAtom : opAtom, opL : h ] ) #
NIL
THEN
ro ← NARROW [ ra ]
ELSE
h ← CONS [ ro ← NEW [ OpRec ← [ op : opAtom, matches : NIL ] ], h ];
[ h : h, ro : ro, ops : ops, c : c ] ←
EnterFixity [ opL : h, kind : opKind, refOpRec : ro, restOfOps : ops ];
IF c # NIL THEN ERROR;
ENDLOOP
};
FindOpRec:
PRIVATE PROCEDURE [ opAtom : ATOM, opL : OpList ]
RETURNS [ r : REF ANY ← NIL ] =
{
-- If opL contains an OpRec with operator opAtom, return a ref to it, else return NIL.
IF opL =
NIL
THEN
r ← NIL
ELSE
IF opL.first.op = opAtom
THEN
r ← opL.first
ELSE
r ← FindOpRec [ opAtom : opAtom, opL : opL.rest ];
};
FindOpRec2:
-- like FindOpRec but deals with EdgeRecs instead of OpRecs.
PRIVATE PROCEDURE [ opAtom : ATOM, opL : LIST OF EdgeRec ]
RETURNS [ r : REF ANY ← NIL ] =
{
-- If opL contains an OpRec with operator opAtom, return a ref to it, else return NIL.
IF opL =
NIL
THEN
r ← NIL
ELSE
IF opL.first.oprec.op = opAtom
THEN
r ← opL.first.oprec
ELSE
r ← FindOpRec2 [ opAtom : opAtom, opL : opL.rest ];
};
EnterFixity:
PRIVATE PROCEDURE [ opL : OpList, kind : ATOM, refOpRec : REF OpRec, restOfOps : List ]
RETURNS [ h : OpList, ro : REF OpRec, ops : List, c : Culprit ← NIL ] =
{
-- We fill in the fixity fields for the OpRec. If the operator is openfix, leftfix, or rightfix, we make sure its matching closefix operator exists in the op list, adding it if necessary.
OurCulprit : TYPE = RECORD [ op : REF OpRec, msg : ROPE ];
closer : ATOM; -- the operator's matching closefix operator, if any.
rc : REF OpRec; -- ref to OpRec for closer.
h ← opL; ro ← refOpRec; ops ← restOfOps;
SELECT kind
FROM
$infix => ro.isInfix ← TRUE;
$prefix => ro.isPrefix ← TRUE;
$postfix => ro.isPostfix ← TRUE;
$openfix, $leftfix, $rightfix =>
{
SELECT kind
FROM
$openfix => ro.isOpenfix ← TRUE;
$leftfix => ro.isLeftfix ← TRUE;
$rightfix => ro.isRightfix ← TRUE;
ENDCASE => ERROR;
IF ops =
NIL
THEN
c ← NEW [ OurCulprit ← [ ro, "missing closefix operator" ] ]
ELSE
{
closer ← NARROW [ ops.first ]; ops ← ops.rest;
[ h : h, rc : rc, c : c ] ← GetCloserRec [ open : ro, opL : h, closer: closer ];
}
}
ENDCASE => ERROR;
};
GetCloserRec:
PRIVATE PROCEDURE [ open : REF OpRec, opL : OpList, closer : ATOM ]
RETURNS [ h : OpList, rc : REF OpRec, c : Culprit ← NIL ] =
{
-- We look for the closer in the list of operators; if it isn't there, we build a new op record for it and add it to the list. We return rc, a ref to the closer's op rec, and h, the (possibly updated) list of operators.
OurCulprit : TYPE = RECORD [ op : ATOM, msg : ROPE ];
ra : REF ANY; -- nonNIL only if the closer already exists in the opList.
ro : REF OpRec = open; -- points to the open/left/rightfix operator.
IF ( ra← FindOpRec [ opAtom : closer, opL : opL ] ) = NIL THEN
{
rc ← NEW [ OpRec ← [ op : closer, isClosefix : TRUE ] ];
h ← CONS [ rc, opL ]
}
ELSE
{
rc ← NARROW [ ra, REF OpRec ];
h ← opL
};
SELECT
TRUE
FROM
ro.matches = NIL => ro.matches ← rc;
ro.matches # rc => c ← NEW [ OurCulprit ← [ ro.op, "has more than one closer" ] ]
ENDCASE;
};
AddProdRec:
PRIVATE PROCEDURE [ opL : OpList, prL : ProdList, nterm : ATOM, rhsL : List ]
RETURNS [ p : ProdList, c : Culprit ← NIL ] =
{
-- We take nterm, a nonterminal, and rhsL, the list of its right hand sides, build a production record with them and add it to opL, yielding p. Note each rhs gets its own rule record.
rhs : List; -- the current right hand side, a list of ATOMS.
k : ATOM; -- the kind of right hand side, $infix, $prefix, etc.
rp : REF ProdRec; -- Pointer to the new production record.
rr : REF RuleRec; -- Pointer to the current rule record.
rules : RuleList ← NIL; -- The list of rule records built for the production.
p ← prL;
rhsL ← AtomizeList [ rhsL ]; -- Change any ROPEs in rhsL to ATOMs.
WHILE rhsL #
NIL
DO
rhs ← NARROW [ rhsL.first, List ];
rhsL ← rhsL.rest;
[ kind : k, c : c ] ← FindKindOfRule [ opL : opL, nterm : nterm, r : rhs.rest ];
IF c # NIL THEN RETURN;
rr ← NEW [ RuleRec ← [ kind : k, seq : rhs.rest, number: NARROW[rhs.first, REF INT]^] ];
rules ← CONS [ rr, rules ]
ENDLOOP;
rp ← NEW [ ProdRec ← [ nonTerminal : nterm, rhsList : rules ] ];
p ← CONS [ rp, prL ]
};
AtomizeList:
PRIVATE PROCEDURE [ r : List ]
RETURNS [ s : List ← NIL] =
{
-- Recursively replace ROPEs by their atoms.
IF r # NIL THEN
{
atomizedRest : List = AtomizeList [ r.rest ];
WITH r.first SELECT FROM
ra : ATOM => s ← CONS [ r.first, atomizedRest ];
rr : ROPE => s ← CONS [ Atom.MakeAtom [ rr ], atomizedRest ];
rl : List => s ← CONS [ AtomizeList [ rl ], atomizedRest ];
ri: REF INT => s ← CONS[r.first, atomizedRest];
ENDCASE => ERROR
}
};
FindKindOfRule:
PRIVATE PROCEDURE [ opL : OpList, nterm : ATOM, r : List ]
RETURNS [ kind : ATOM, c : Culprit ← NIL ] =
{
-- Look at the sequence r of symbols and figure out whether or not they look like an infix, prefix, postfix, openfix, leftfix, or rightfix rule. We assume the symbols are ATOMs.
n : INT = LengthOfList [ r ];
isOp1, isOp2, isOp3, isOp4 : BOOL;
-- isOpk is TRUE iff the k'th element of r is an operator.
OurCulprit : TYPE = RECORD [ op : ATOM, rhs : List, msg : ROPE ];
IF n = 1 THEN {c ← NIL; kind ← $unit; RETURN};
IF n < 2
THEN
c ← NEW [ OurCulprit ← [ nterm, r, "alternative too short" ] ]
ELSE
IF n > 4
THEN
c ← NEW [ OurCulprit ← [ nterm, r, "alternative too long" ] ]
ELSE
isOp1 ← IsOp [ opL : opL, ra : NthElt [ r, 1 ] ];
isOp2 ← IsOp [ opL : opL, ra : NthElt [ r, 2 ] ];
isOp3 ← IF n > 2 THEN IsOp [ opL : opL, ra : NthElt [ r, 3 ] ] ELSE FALSE;
isOp4 ← IF n > 3 THEN IsOp [ opL : opL, ra : NthElt [ r, 4 ] ] ELSE FALSE;
SELECT
TRUE
FROM
n = 2 AND isOp1 AND ~ isOp2 => kind ← $prefix;
--! but what if op1 is not prefix!
n = 2 AND ~isOp1 AND isOp2 => kind ← $postfix;
n = 3 AND isOp1 AND ~isOp2 AND isOp3 => kind ← $openfix;
n = 3 AND ~isOp1 AND isOp2 AND ~isOp3 => kind ← $infix;
n = 4 AND isOp1 AND ~isOp2 AND isOp3 AND ~isOp4 => kind ← $leftfix;
n = 4 AND ~isOp1 AND isOp2 AND ~isOp3 AND isOp4 => kind ← $rightfix
ENDCASE =>
c ← NEW [ OurCulprit ← [ nterm, r, "unknown kind of rule" ] ];
};
LengthOfList:
PRIVATE PROCEDURE [ x : List ] RETURNS [ n : INT ← 0 ] =
{
-- Return the length of the list.
IF x # NIL THEN n ← 1 + LengthOfList [ NARROW [ x, List ] . rest ]
};
NthElt:
PRIVATE PROCEDURE [ x : List, n : INT ] RETURNS [ REF ANY ] =
{
-- Returns the n'th element of the list.
RETURN [ IF n = 1 THEN x.first ELSE NthElt [ x : x.rest, n : n - 1 ] ]
};
IsOp:
PRIVATE PROCEDURE [ opL : OpList, ra : REF ANY ] RETURNS [ BOOL ] =
{
-- Return TRUE iff the given atom is an operator in the OpList.
WITH ra
SELECT
FROM
a : ATOM => RETURN [ FindOpRec [ opAtom : a, opL : opL ] # NIL ]
ENDCASE => RETURN [ FALSE ]
};
CheckFixities:
PRIVATE PROCEDURE [ opL : OpList ] RETURNS [ c : Culprit ← NIL ] =
{
-- Make sure that the fixities of each operator are acceptable: infix, rightfix, and postfix are mutually exclusive, as are openfix, leftfix, and prefix. Other combinations are ok.
OurCulprit : TYPE = RECORD [ op: ATOM, msg : ROPE ];
r : OpRec; -- current operator record.
WHILE opL #
NIL
DO
r ← opL.first^;
opL ← opL.rest;
IF ( r.isInfix
AND r.isRightfix )
OR ( r.isRightfix AND r.isPostfix )
OR ( r.isPostfix AND r.isInfix )
THEN
RETURN
[
NEW
[ OurCulprit ← [ r.op, "Infix, Rightfix, and Postfix are mutually exclusive" ] ]
]
ELSE
IF ( r.isOpenfix
AND r.isLeftfix )
OR ( r.isLeftfix AND r.isPrefix )
OR ( r.isPrefix AND r.isOpenfix )
THEN
RETURN
[
NEW
[ OurCulprit ← [ r.op, "Openfix, Leftfix, and Prefix are mutually exclusive" ] ]
]
ENDLOOP
};
AddPrecGraphEdges:
PRIVATE PROCEDURE [ opL : OpList, prL : ProdList ] RETURNS [ c : Culprit ] =
{
-- For each pair of rules, look at them to see whether or not we need an edge in the precedence graph for them; if we do, add it to the graph if it isn't already there. (NOTE : we're cheating a bit in this routine. See NeedPrecEdge for details.)
lhs1, lhs2 : ATOM; -- the nonterminals of the two rules.
rhs1, rhs2: List; -- the rhs sequences of ATOMS of the two rules.
k1, k2: ATOM; -- the kinds of the two rhs's: $infix, $prefix, etc.
op1, op2: ATOM; -- the left operators of rhs1, rhs2.
r1, r2: REF OpRec; -- the records for the left operators of rhs1, rhs2.
-- The four deep loop just goes through every pair of right hand sides from each production. Inside the loop, we check the two right hand sides and decide whether or not we need a precedence edge because of them.
FOR pL1 : ProdList ← prL, pL1.rest UNTIL pL1 = NIL
DO
lhs1 ← pL1.first.nonTerminal;
FOR rL1 : RuleList ← pL1.first.rhsList, rL1.rest UNTIL rL1 = NIL
DO
k1 ← rL1.first.kind; rhs1 ← rL1.first.seq;
IF k1 = $openfix THEN LOOP; -- openfix rules never yield precedence edges.
FOR pL2 : ProdList ← prL, pL2.rest UNTIL pL2 = NIL
DO
lhs2 ← pL2.first.nonTerminal;
FOR rL2 : RuleList ← pL2.first.rhsList, rL2.rest UNTIL rL2 = NIL
DO
k2 ← rL2.first.kind; rhs2 ← rL2.first.seq;
IF k2 = $openfix THEN LOOP; -- openfix rules never yield precedence edges.
IF NeedPrecEdge [ opL, lhs1, lhs2, k1, k2, rhs1, rhs2, prL ] THEN
{
op1 ← LOptr [ k1, rhs1 ];
op2 ← LOptr [ k2, rhs2 ];
r1 ← NARROW [ FindOpRec [ op1, opL ] ];
IF FindOpRec2 [ op2, r1.adj ] = NIL THEN
{
r2 ← NARROW [ FindOpRec [ op2, opL ] ];
r1.adj ← CONS [[rL1.first.number, rL2.first.number, r2], r1.adj ];
r2.indegree ← r2.indegree + 1;
}
}
ENDLOOP
ENDLOOP
ENDLOOP
ENDLOOP;
RETURN
};
NeedPrecEdge:
PRIVATE PROCEDURE [ opL : OpList,
lhs1, lhs2, k1, k2 : ATOM,
rhs1, rhs2 : List,
prodlist: ProdList ]
RETURNS [ b : BOOL ← TRUE ] =
{
-- Return TRUE iff we need an edge in the graph to connect the left operator of rhs1 to the left operator of rhs2. NOTE : we're cheating a bit here: the full algorithm actually uses two kinds of edges in the graph: less than ("LT") edges and less than or equal to ("LE") edges. (If operator x has a LT edge to operator y, then the precedence of x must be less than the precedence of y; LE edges are similar.) Anyway, in the full algorithm, if we have two rules where x and y are the left operators of rules 1 and 2 and Y is the lhs nonterminal of rule 2, then if (1) Y is also the rightmost operand of rule 1 and y has a left operand, then we need an LE edge from x to y. On the other hand, if (2) Y is the left operand of rule 1 and y has a right operand, then we need a LT edge from x to y. In this actual routine, we've cut some corners: we eliminate all edges from a node to itself, and we treat all the remaining edges as LT edges.
b ← k1 # $unit AND k2 # $unit AND (
( LOptr [ k1, rhs1 ] # LOptr [ k2, rhs2 ]
AND
HasUnprotectedLOpnd [k2] AND
HasUnprotectedROpnd [k1] AND
Reaches[ROpnd [k1,rhs1], lhs2, prodlist, NIL] )
OR
( HasUnprotectedROpnd [k2] AND
HasUnprotectedLOpnd [k1] AND
Reaches[LOpnd [k1,rhs1], lhs2, prodlist, NIL] ) )
};
Reaches: PROC [ x, y: ATOM, pl: ProdList, f: LIST OF ATOM] RETURNS [BOOL] =
{IF x = y THEN RETURN [TRUE]
; {p: REF ProdRec ← NARROW[FindProdRec[x, pl]]
; IF p = NIL THEN RETURN [FALSE]
; RETURN[Reach2[p.rhsList, y, pl, CONS[x, f]]]}};
Reach2: PROC[rl: RuleList, y: ATOM, pl: ProdList, f: LIST OF ATOM] RETURNS [BOOL] =
{IF rl = NIL THEN RETURN [FALSE]
; IF rl.first.kind = $unit
AND ~Memq[NARROW[rl.first.seq.first], f]
AND Reaches[NARROW[rl.first.seq.first], y, pl, f]
THEN RETURN[TRUE]
; RETURN[Reach2[rl.rest, y, pl, f]]};
Memq: PROC[a: ATOM, l: LIST OF ATOM] RETURNS [BOOL] =
{IF l = NIL THEN RETURN[FALSE];
IF l.first = a THEN RETURN[TRUE];
RETURN[Memq[a, l.rest]]};
LOptr:
PRIVATE PROCEDURE [ kind : ATOM, rhs : List ] RETURNS [ optr : ATOM ] =
{
-- We are given the kind of and symbols for the right hand side of a rule. We return the leftmost operator of the rule.
SELECT kind
FROM
$prefix, $leftfix, $openfix => optr ← NARROW [ NthElt [ rhs, 1 ] ];
$infix, $postfix, $rightfix => optr ← NARROW [ NthElt [ rhs, 2 ] ]
ENDCASE => ERROR;
};
HasUnprotectedLOpnd:
PRIVATE PROCEDURE [ kind : ATOM ] RETURNS [ BOOL ] =
{
-- Return TRUE iff the given kind of rule has an unprotected left operand. (That is, one not surrounded by matching parens/brackets/whatever.
RETURN [ kind = $infix OR kind = $postfix OR kind = $rightfix ]
};
LOpnd:
PRIVATE PROCEDURE [ kind : ATOM, rhs : List ] RETURNS [ opnd : ATOM ] =
{
-- We are given the kind of and symbols for the right hand side of a rule. We return the leftmost operand of the rule, unprotected or not.
SELECT kind
FROM
$infix, $postfix, $rightfix => opnd ← NARROW [ NthElt [ rhs, 1 ] ];
$prefix, $leftfix, $openfix => opnd ← NARROW [ NthElt [ rhs, 2 ] ];
ENDCASE => ERROR
};
HasUnprotectedROpnd:
PRIVATE PROCEDURE [ kind : ATOM ] RETURNS [ BOOL ] =
{
-- Return TRUE iff the given kind of rule has an unprotected right operand. (That is, one not surrounded by matching parens/brackets/whatever.
RETURN [ kind = $prefix OR kind = $infix OR kind = $leftfix ]
};
ROpnd:
PRIVATE PROCEDURE [ kind : ATOM, rhs : List ] RETURNS [ opnd : ATOM ] =
{
-- We are given the kind of and symbols for the right hand side of a rule. We return the rightmost operand of the rule, unprotected or not.
SELECT kind
FROM
$postfix => opnd ← NARROW [ NthElt [ rhs, 1 ] ];
$prefix, $openfix => opnd ← NARROW [ NthElt [ rhs, 2 ] ];
$infix, $rightfix => opnd ← NARROW [ NthElt [ rhs, 3 ] ];
$leftfix => opnd ← NARROW [ NthElt [ rhs, 4 ] ];
ENDCASE => ERROR;
};
SolveForPrecs:
PRIVATE PROCEDURE [ opL : OpList ] RETURNS [ c : Culprit ← NIL ] =
{
-- We need to calculate the precedences of the operators in opL so that if x -> y is an edge in the precedence graph, then x.prec < y.prec. It suffices to set prec(x) = length of longest path from a source of the graph to the node x.
-- Invariant for the algorithm: G0 = < S0, N0 > is the original graph, Sn and Nn are the sources and nonsources of Gn (all n > 0), and Gn = G0 minus the nodes in union ( S0, S1, ... Sn-1 ). The precedence of x is p iff x is in Sp.
OurCulprit : TYPE = RECORD [ opL : LIST OF REF ANY, msg : ROPE ];
S : OpList ← NIL; -- the source nodes of Gi, excluding closefix operators.
N : OpList ← NIL; -- the nonsource nodes of Gi.
n : INT; -- the current step number.
x : REF OpRec;
-- Initialize the list of source/nonsource nodes. Throw away closefix operators, since their precedences are uninteresting. (Actually, that's false: the precedence of closefix operators must be less than the precedence of the other operators. We've already initialized them that way.)
n ← closefixPrec + 1;
FOR g : OpList ← opL, g.rest UNTIL g = NIL
DO
IF ~ ( x ← g.first ) . isClosefix
THEN
IF x.indegree = 0 THEN S ← CONS [ x, S ] ELSE N ← CONS [ x, N ]
ENDLOOP;
FOR g : OpList ← S, g.rest UNTIL g = NIL DO g.first.prec ← 0 ENDLOOP;
-- Set the precedences of the nodes in Sn to n, and remove Sn from Gn, yielding Gn+1. Repeat until Sn+1 is empty.
WHILE S # NIL
DO
[ S, N ] ← DeleteSources [ S, N ];
FOR g : OpList ← S, g.rest UNTIL g = NIL DO g.first.prec ← n + 1 ENDLOOP;
n ← n + 1
ENDLOOP;
IF
N #
NIL
THEN
c ← NEW [ OurCulprit ← [ FindCycle[N], "cyclic precedences" ] ]
};
FindCycle: PROC[ops: OpList] RETURNS [cycle: LIST OF REF ANY] =
{op: ATOM ← ops.first.op;
l: LIST OF REF ANY ← NIL;
WHILE ~ Memqq[op, l]
DO {op2: ATOM;
n, m: INT;
[op2, n, m] ← FindPredecessor[op, ops];
l ← CONS[NEW[INT ← n], CONS[NEW [INT ← m], CONS[op, l]]];
op ← op2}
ENDLOOP;
cycle ← CONS[op, NIL];
WHILE l.first # op DO cycle ← CONS[l.first, cycle]; l ← l.rest ENDLOOP};
Memqq: PROC[r: REF, l: LIST OF REF] RETURNS [BOOL] =
{IF l = NIL THEN RETURN [FALSE];
IF r = l.first THEN RETURN [TRUE];
RETURN[Memqq[r, l.rest]]};
FindPredecessor: PROC[op: ATOM, ops: OpList] RETURNS [ATOM, INT, INT] =
{DO {a:LIST OF EdgeRec ← ops.first.adj;
WHILE a # NIL
DO
IF a.first.oprec.op = op THEN RETURN[ops.first.op, a.first.n, a.first.m];
a ← a.rest
ENDLOOP};
ops ← ops.rest
ENDLOOP};
DeleteSources:
PRIVATE PROCEDURE [ S, N : OpList ] RETURNS [ newS, newN : OpList ← NIL ] =
{
-- We remove the nodes in S from the precedence graph and return the new sources and nonsources of the graph.
u : REF OpRec; -- current node being deleted, if any, else NIL.
a : REF OpRec; -- current node adjacent to u, if any, else NIL.
newS ← NIL; newN ← N;
FOR undeleted : OpList ← S, undeleted.rest UNTIL undeleted = NIL
DO
u ← undeleted.first;
FOR adjacent : LIST OF EdgeRec ← u.adj, adjacent.rest UNTIL adjacent = NIL
DO
a ← adjacent.first.oprec;
IF a.indegree = 1 THEN
{
newN ← RemoveOp [ a, newN ];
newS ← CONS [ a, newS ]
};
a.indegree ← a.indegree - 1
ENDLOOP
ENDLOOP
};
RemoveOp:
PRIVATE PROCEDURE [ n : REF OpRec, x : OpList ] RETURNS [ y : OpList ] =
{
-- We remove the node n from the OpList x. If n isn't in x, we return x as is.
y ←
SELECT
TRUE
FROM
x = NIL => NIL,
n.op = x.first.op => x.rest
ENDCASE => CONS [ x.first, RemoveOp [ n, x.rest ] ];
};
AddGrammarToParseWindow:
PRIVATE PROCEDURE
[ opL : OpList, handle : ParseTable.Handle, l: Lexer.Handle ] =
{
-- Add the operators to the parse window handle so that the parse viewer will actually know about them. This is where we use the precedences of the operators.
-- NOTE : some of this is skeletoned because the parser and unparser haven't been augmented yet.
r : REF OpRec; -- index for the loops.
FOR rs : OpList ← opL, rs.rest UNTIL rs = NIL -- must add closefix operators first
DO
r ← rs.first;
{p: ParseTable.Properties
← NEW[ParseTable.PRec ← [name: r.op]];
opname: ROPE ← Atom.GetPName [r.op];
aname: ROPE ← NIL;
p.infix ← r.isInfix;
p.prefix ← r.isPrefix;
p.postfix ← r.isPostfix;
p.matchfix ← r.isOpenfix;
p.subfix ← r.isRightfix;
p.closefix ← r.isClosefix;
p.bindingPower ← r.prec;
p.unparserType ← 0;
IF Rope.Length[opname] = 2
AND l.type[Rope.Fetch[opname, 0]] = op
THEN Lexer.AddOpPair[l, opname.Fetch[0], opname.Fetch[1]];
IF Rope.Length[aname] = 2
AND l.type[Rope.Fetch[aname, 0]] = op
THEN Lexer.AddOpPair[l, aname.Fetch[0], aname.Fetch[1]];
ParseTable.Enter[handle, p]}
ENDLOOP;
FOR rs : OpList ← opL, rs.rest UNTIL rs = NIL DO
r ← rs.first;
IF r.isOpenfix OR r.isLeftfix OR r.isRightfix
THEN {p: ParseTable.Properties ← ParseTable.Search[handle, r.op, NIL];
p.closer ← ParseTable.Search[handle, r.matches.op, NIL]}
ENDLOOP };
OpDoesntLookLikeWord: PRIVATE PROCEDURE [ n : ROPE ] RETURNS [ b : BOOL ] =
{
-- Take the the open/close/left/rightfix operator name, n, and return TRUE if it doesn't look like a word. As a hack, left parens/braces/brackets don't look like word; everything else does.
b ← Rope.Equal [ n, "(" ] OR Rope.Equal [ n, "{" ] OR Rope.Equal [ n, "[" ]
};
IsGeneratedBy:
PUBLIC PROCEDURE [ prL : ProdList, lhs : ATOM, p : ParseTree ]
RETURNS [ vc : VerdictAndCulprit ] =
{
-- We are given a parse tree Car[p], a grammar (via its operators and productions), and a left hand side nonterminal of the grammar. We find out whether Car[p] is generated by the nonterminal by trying each of the right hand sides of the nonterminal's productions.
SELECT TRUE
FROM
lhs = $id =>
WITH Car [ p ]
SELECT
FROM
atom : ATOM => RETURN [ [ Yes, NIL, 0 ] ];
ENDCASE => RETURN [ [ No, Car[p], 0 ] ];
lhs = $Int =>
WITH Car [ p ]
SELECT
FROM
ri : REF INT => RETURN [ [ Yes, NIL, 0 ] ];
ENDCASE => RETURN [ [ No, Car[p] , 0] ];
lhs = $Real =>
WITH Car [ p ]
SELECT
FROM
ri : REF INT => RETURN [ [ Yes, NIL, 0 ] ];
ENDCASE => RETURN [ [ No, Car[p] , 0] ];
lhs = $Rope =>
WITH Car [ p ]
SELECT
FROM
r: ROPE => RETURN [[ Yes, NIL, 0 ]];
ENDCASE => RETURN [ [ No, Car[p] , 0] ];
FindProdRec[lhs, prL] = NIL =>
IF Car [ p ] = lhs
THEN RETURN [ [Yes, NIL, 0] ]
ELSE RETURN [ [ No, Car[p], 0] ];
TRUE =>
RETURN[
CheckRhsList [ prL, p,
NARROW[FindProdRec[lhs, prL],
REF ProdRec].rhsList]]
ENDCASE => ERROR;
};
FindProdRec:
PRIVATE PROCEDURE [ opAtom : ATOM, prL : ProdList ]
RETURNS [ r : REF ANY ← NIL ] =
{
-- If prL contains a production with lhs opAtom, return a ref to it, else return NIL.
IF prL =
NIL
THEN
r ← NIL
ELSE
IF prL.first.nonTerminal = opAtom
THEN
r ← prL.first
ELSE
r ← FindProdRec [ opAtom : opAtom, prL : prL.rest ];
};
CheckRhsList:
PRIVATE PROCEDURE [ prL : ProdList, p : ParseTree, rhsL : RuleList ]
RETURNS [ vc : VerdictAndCulprit ] =
{
-- We are given a parse tree Car[p], a grammar, and a list of alternatives. We take each alternative, find out whether or not Car[p] is generated by it, and OR the results.
IF rhsL = NIL THEN RETURN [[No, NIL, 0]];
vc ← CheckRhs [ prL, p, rhsL.first ];
IF vc.verdict = Yes THEN RETURN;
vc ← Or [ vc, CheckRhsList [ prL, p, rhsL.rest ] ]
};
CheckRhs:
PRIVATE PROCEDURE [ prL : ProdList, p : ParseTree, rhs : REF RuleRec ]
RETURNS [ vc : VerdictAndCulprit ] =
{
-- We find out whether Car[p] is generated from the right hand side rhs.
k : ATOM = rhs.kind; -- kind of rule; $infix, $prefix, etc.
s : List = rhs.seq; -- the symbols of the right hand side, each an atom.
cp : REF = Car[p]; -- Car [ p ], as a list.
optr : ATOM; -- the leading operator of cp, if one exists.
IF k = $unit THEN RETURN[IsGeneratedBy[prL, NARROW[s.first], p]];
IF ~ ISTYPE[cp, List] THEN RETURN [[No, p, 0]];
optr ← NARROW [ Car[ cp ], ATOM];
IF LOptr [ k, s ] # optr
OR LengthOfList[s] # LengthOfList[
NARROW[ cp ] ]
+ (IF k = $openfix OR k = $leftfix OR k = $rightfix THEN 1 ELSE 0)
THEN RETURN [ [ No, p, 0 ] ];
vc ← IsGeneratedBy [ prL, LOpnd [ k, s ] , Cdr [ cp ] ];
IF k = $prefix OR k = $postfix OR k = $openfix
THEN {vc.depth ← vc.depth + 1; RETURN};
vc ← And[vc, IsGeneratedBy [ prL, ROpnd [ k, s ], Cddr [ cp ] ] ];
vc.depth ← vc.depth + 1
};
And: PROC[vc1, vc2: VerdictAndCulprit] RETURNS [VerdictAndCulprit] =
{SELECT TRUE FROM
vc1.verdict = Yes AND vc2.verdict = Yes => RETURN[[Yes, NIL, 0]];
vc1.verdict = Yes AND vc2.verdict = No => RETURN[[No, vc2.culprit, vc2.depth]];
vc1.verdict = No AND vc2.verdict = Yes => RETURN[[No, vc1.culprit, vc1.depth]];
-- vc1.verdict = No AND vc2.verdict = No
vc1.depth >= vc2.depth => RETURN[[No, vc1.culprit, vc1.depth]];
vc1.depth <= vc2.depth => RETURN[[No, vc2.culprit, vc2.depth]]
ENDCASE => ERROR};
Car: PROC [r: REF ANY] RETURNS [REF ANY] = {RETURN[NARROW[r, List].first]};
Cdr: PROC [r: REF ANY] RETURNS [REF ANY] = {RETURN[NARROW[r, List].rest]};
Cddr: PROC [r: REF ANY] RETURNS [REF ANY] = {RETURN[Cdr[Cdr[r]]]};
-- Some testing routines; not normally used otherwise.
Open: PRIVATE PROCEDURE [ fileName: ROPE ] RETURNS [ IO.STREAM ] =
{
RETURN [ FS.StreamOpen [ fileName ] ]
};
GetRefAnyFrom: PRIVATE PROCEDURE [ fileName: ROPE ] RETURNS [ REF ANY ] =
{
RETURN [ IO.GetRefAny [ FS.StreamOpen [ fileName ] ] ]
};
NthOp:
PRIVATE PROCEDURE [ x : OpList, n : INT ] RETURNS [ REF OpRec ] =
{
-- Returns the n'th element of the operator list.
RETURN [ IF n = 1 THEN x.first ELSE NthOp [ x : x.rest, n : n - 1 ] ]
};
HasForm: PROC[f: REF ANY,
op: ATOM,
Arg1: SyntacticPredicate,
Arg2: SyntacticPredicate ← NIL]
RETURNS [VerdictAndCulprit] =
{WITH Car[NARROW[f]] SELECT FROM
g: LIST OF REF ANY =>
{IF Car[g] # op THEN RETURN [[OfCourseNot, g]];
IF (Arg2 = NIL) # (Cddr[g] = NIL)
THEN RETURN[[OfCourseNot, f]];
{aw: VerdictAndCulprit ← Arg1[Cdr[g]];
IF aw.verdict # Yes THEN RETURN [[No, aw.culprit]];
IF Cddr[g] = NIL THEN RETURN [[Yes, NIL]];
aw ← Arg2[Cddr[g]];
IF aw.verdict # Yes THEN RETURN [[No, aw.culprit]];
RETURN [[Yes, NIL]]}}
ENDCASE => RETURN [[OfCourseNot, f]]};
Or: PROC [aw1, aw2: VerdictAndCulprit]
RETURNS [r: VerdictAndCulprit] =
{SELECT TRUE FROM
aw1.verdict = Yes OR aw2.verdict = Yes => r ← [Yes, NIL, 0];
aw1.depth >= aw2.depth => r ← aw1;
aw1.depth <= aw2.depth => r ← aw2
ENDCASE => ERROR};
END.