<<-- ParserGenImpl.mesa -- Last edited by Jim Sasaki on August 24, 1983 4:03 pm>> <> DIRECTORY Rope, ViewerTools, Atom, IO, FS, ParserGen, ParseTable, Lexer; 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 ] ] }; < {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.