
    <<EDIFGrammarImpl.Mesa>>
        <<Spreitzer, February 24, 1986 10:51:04 pm PST>>

    DIRECTORY Atom, Basics, HashTable, EDIFGrammar, IO, RedBlackTree, Rope, StructuredStreams, TiogaAccess, UnparserBuffer;

    EDIFGrammarImpl: CEDAR PROGRAM
        IMPORTS Atom, HashTable, IO, RedBlackTree, Rope, StructuredStreams, TiogaAccess, UnparserBuffer
        EXPORTS EDIFGrammar
        = {OPEN EDIFGrammar, SS: StructuredStreams, UB: UnparserBuffer;

        ROPE: TYPE = Rope.ROPE;

        Grammar: TYPE = REF GrammarPrivate;
        GrammarPrivate: TYPE = RECORD [
            defQuick: HashTable.Table,
            defs, tUses, ntUses, keyUses: RedBlackTree.Table
            ];

        Usage: TYPE = REF UsagePrivate;
        UsagePrivate: TYPE = RECORD [
            subject: ATOM,
            users: ATOMList _ NIL
            ];

        g: Grammar _ NewGrammar[];

        termNames: ARRAY TerminalClass OF ATOM = [
            String: $String,
            Integer: $Integer,
            Identifier: $Identifier,
            Form: $Form
            ];

        NewGrammar: PROC RETURNS [g: Grammar] = {
            g _ NEW [GrammarPrivate _ [
                defQuick: HashTable.Create[],
                defs: RedBlackTree.Create[GetIDKey, CompareATOMs],
                tUses: RedBlackTree.Create[GetUsageKey, CompareUsages],
                ntUses: RedBlackTree.Create[GetUsageKey, CompareUsages],
                keyUses: RedBlackTree.Create[GetUsageKey, CompareUsages]
                ]];
            };

        GetIDKey: PROC [data: REF ANY] RETURNS [REF ANY] --RedBlackTree.GetKey-- = {RETURN [data]};

        CompareATOMs: PROC [k, data: REF ANY] RETURNS [c: Basics.Comparison] --RedBlackTree.Compare-- = {
            k1: ATOM = NARROW[k];
            k2: ATOM = NARROW[data];
            c _ Atom.GetPName[k1].Compare[Atom.GetPName[k2], FALSE];
            };

        GetUsageKey: PROC [data: REF ANY] RETURNS [ATOM] --RedBlackTree.GetKey-- = {
            u: Usage = NARROW[data];
            RETURN [u.subject]};

        CompareUsages: PROC [k, data: REF ANY] RETURNS [c: Basics.Comparison] --RedBlackTree.Compare-- = {
            k1: ATOM = NARROW[k];
            k2: ATOM = GetUsageKey[data];
            c _ Atom.GetPName[k1].Compare[Atom.GetPName[k2], FALSE];
            };

        GetRuleDef: PUBLIC PROC [category: ATOM] RETURNS [r: Rule] = {
            r _ NARROW[g.defQuick.Fetch[category].value];
            };

        Def: PROC [g: Grammar, category: ATOM, r: Rule] = {
            or: Rule _ GetRuleDef[category];
            NoteUse[g, category, r];
            IF or # NIL
                THEN WITH or SELECT FROM
                    olr: REF levelGuard RulePrivate => {
                        nlr: REF levelGuard RulePrivate = NARROW[r];
                        cr: Rule = ConsAlt[LIST[olr, nlr]];
                        FOR l: Level IN Level DO
                            IF l IN [olr.min .. olr.max] AND l IN [nlr.min .. nlr.max] THEN ERROR;
                            ENDLOOP;
                        IF NOT g.defQuick.Replace[category, cr] THEN ERROR;
                        };
                    ocr: REF choice RulePrivate => {
                        nlr: REF levelGuard RulePrivate = NARROW[r];
                        ocr.choices _ Append[ocr.choices, nlr];
                        };
                    ENDCASE => ERROR
            ELSE {
                IF NOT g.defQuick.Insert[category, r] THEN ERROR;
                g.defs.Insert[category, category];
                };
            };

        Append: PROC [rl: RuleList, r: Rule] RETURNS [rl2: RuleList] = {
            tail: RuleList = LIST[r];
            prev: RuleList _ NIL;
            rl2 _ rl;
            FOR rl _ rl, rl.rest WHILE rl # NIL DO prev _ rl ENDLOOP;
            IF prev # NIL THEN prev.rest _ tail ELSE rl2 _ tail;
            };

        NoteUse: PROC [g: Grammar, user: ATOM, r: Rule] = {
            Gotcha: PROC [table: RedBlackTree.Table, use: ATOM] = {
                usage: Usage _ NARROW[table.Lookup[use]];
                IF usage = NIL THEN {
                    usage _ NEW [UsagePrivate _ [use]];
                    table.Insert[usage, use];
                    };
                IF usage.users = NIL OR usage.users.first # user THEN usage.users _ CONS[user, usage.users];
                };
            SeeList: PROC [rl: RuleList] = {
                FOR rl _ rl, rl.rest WHILE rl # NIL DO NoteUse[g, user, rl.first] ENDLOOP;
                };
            WITH r SELECT FROM
                x: REF list RulePrivate => {
                    IF x.keyword # NIL THEN Gotcha[g.keyUses, x.keyword];
                    SeeList[x.elts.rest]};
                x: REF repeat RulePrivate => NoteUse[g, user, x.sub];
                x: REF choice RulePrivate => SeeList[x.choices];
                x: REF levelGuard RulePrivate => NoteUse[g, user, x.r];
                x: REF nonTerminal RulePrivate => Gotcha[g.ntUses, x.category];
                x: REF terminal RulePrivate => Gotcha[g.tUses, termNames[x.category]];
                ENDCASE => ERROR;
            };

        PrintGrammar: PROC [to: IO.STREAM, g: Grammar] = {
            out: IO.STREAM = SS.Create[UB.NewHandle[[stream[to]], 75]];
            PrintGrammarDefs[out, g];
            PrintGrammarUses[out, g];
            out.Close[]};

        PrintGrammarDefsToFile: PROC [fileName: ROPE, g: Grammar] = {
            w: TiogaAccess.Writer = TiogaAccess.Create[];
            out: IO.STREAM = SS.Create[UB.NewHandle[[access[w, $code, 4]], 75]];
            PrintGrammarDefs[out, g];
            out.Close[];
            w.WriteFile[fileName];
            };

        PrintGrammarDefs: PROC [out: IO.STREAM, g: Grammar] = {
            PrintDef: PROC [ra: REF ANY] RETURNS [stop: BOOL _ FALSE] --RedBlackTree.EachNode-- = {
                category: ATOM = NARROW[ra];
                r: Rule = GetRuleDef[category];
                SS.Begin[out];
                    {ENABLE UNWIND => SS.End[out];
                    out.PutF["%g: ", [atom[category]]];
                    PrintRule[out, r];
                    };
                SS.End[out];
                out.PutRope["\n"];
                };
            PrintUndef: PROC [ra: REF ANY] RETURNS [stop: BOOL _ FALSE] --RedBlackTree.EachNode-- = {
                usage: Usage = NARROW[ra];
                def: Rule = GetRuleDef[usage.subject];
                IF def = NIL THEN out.PutF["%g: Undefined!\n", [atom[usage.subject]]];
                };
            out.PutF["%l\nDefinitions:%l\n", [rope["lb"]], [rope["LB"]]];
            g.defs.EnumerateIncreasing[PrintDef];
            g.ntUses.EnumerateIncreasing[PrintUndef];
            };

        PrintGrammarUsesToFile: PROC [fileName: ROPE, g: Grammar] = {
            w: TiogaAccess.Writer = TiogaAccess.Create[];
            out: IO.STREAM = SS.Create[UB.NewHandle[[access[w, $code, 4]], 75]];
            PrintGrammarUses[out, g];
            out.Close[];
            w.WriteFile[fileName];
            };

        PrintGrammarUses: PROC [out: IO.STREAM, g: Grammar] = {
            PrintUse: PROC [ra: REF ANY] RETURNS [stop: BOOL _ FALSE] --RedBlackTree.EachNode-- = {
                usage: Usage = NARROW[ra];
                SS.Begin[out];
                    {ENABLE UNWIND => SS.End[out];
                    out.PutF["%g: ", [atom[usage.subject]]];
                    FOR uses: ATOMList _ usage.users, uses.rest WHILE uses # NIL DO
                        SS.Bp[out, FALSE, 4];
                        out.Put[[atom[uses.first]]];
                        IF uses.rest # NIL THEN out.PutChar[' ];
                        ENDLOOP;
                    };
                SS.End[out];
                out.PutRope["\n"];
                };
            out.PutF["%l\nUses:%l\n", [rope["lb"]], [rope["LB"]]];
            g.ntUses.EnumerateIncreasing[PrintUse];
            g.tUses.EnumerateIncreasing[PrintUse];
            };

        PrintRule: PROC [out: IO.STREAM, r: Rule] = {
            WITH r SELECT FROM
                x: REF list RulePrivate => {
                    i: INT _ 0;
                    out.PutF["'%l(%l'", [rope["b"]], [rope["B"]] ];
                    FOR rl: RuleList _ x.elts, rl.rest WHILE rl # NIL DO
                        out.PutChar[' ];
                        SS.Bp[out, FALSE, 4];
                        SS.Begin[out];
                            {ENABLE UNWIND => SS.End[out];
                            PrintRule[out, rl.first];
                            };
                        SS.End[out];
                        IF i=0 AND x.cutAfterFirst THEN out.PutRope[" !"];
                        i _ i + 1;
                        ENDLOOP;
                    out.PutF[" '%l)%l'", [rope["b"]], [rope["B"]] ];
                    };
                x: REF repeat RulePrivate => {
                    Close: PROC [c: CHAR] = {
                        out.PutF["%l%g%l", [rope["u"]], [character[c]], [rope["U"]] ]};
                    IF x.zero AND NOT x.moreThanOne
                        THEN {
                            out.PutChar['[];
                            PrintRule[out, x.sub];
                            out.PutChar[']];
                            }
                        ELSE {
                            PrintRule[out, x.sub];
                            };
                    IF x.moreThanOne THEN Close[IF x.zero THEN '* ELSE '+];
                    };
                x: REF choice RulePrivate => {
                    first: BOOL _ TRUE;
                    out.PutChar['(];
                    FOR rl: RuleList _ x.choices, rl.rest WHILE rl # NIL DO
                        SS.Bp[out, FALSE, 4];
                        SS.Begin[out];
                            {ENABLE UNWIND => SS.End[out];
                            IF first THEN first _ FALSE ELSE out.PutRope["| "];
                            PrintRule[out, rl.first];
                            };
                        SS.End[out];
                        IF rl.rest # NIL THEN out.PutRope[" "];
                        ENDLOOP;
                    out.PutChar[')];
                    };
                x: REF levelGuard RulePrivate => {
                    out.PutF["%g..%g & ", [cardinal[x.min]], [cardinal[x.max]] ];
                    PrintRule[out, x.r];
                    };
                x: REF nonTerminal RulePrivate => {
                IF x.onceOnly THEN out.PutChar['<];
                out.Put[[atom[x.category]]];
                IF x.onceOnly THEN out.PutChar['>];
                    };
                x: REF terminal RulePrivate => {
                IF x.value # NIL
                THEN {
                out.PutF["'%l", [rope["b"]]];
                WITH x.value SELECT FROM
                x: ATOM => out.Put[[atom[x]]];
                x: REF INT => out.Put[[integer[x^]]];
                x: ROPE => out.PutF["\"%g\"", [rope[x]]];
                ENDCASE => ERROR;
                out.PutF["%l'", [rope["B"]]];
                }
                ELSE out.PutF[
                "%l%g%l",
                [rope["i"]],
                [atom[termNames[x.category]]],
                [rope["I"]]
                ];
                    };
                ENDCASE => ERROR;
            };

        DL: PUBLIC PROC [category: ATOM, rest: LORA, min: Level _ 0, max: Level _ 2] RETURNS [a: ATOM] = {
            a _ DL2[category, CONS[category, rest], min, max];
            };

        DL2: PUBLIC PROC [category: ATOM, rest: LORA, min: Level _ 0, max: Level _ 2] RETURNS [a: ATOM] = {
            r: Rule = Limit[ConsList[NARROW[rest.first], rest.rest], min, max];
            Def[g, category, r];
            a _ category;
            };

        DBL2: PUBLIC PROC [category: ATOM, rest: LORA, min: Level _ 0, max: Level _ 2, cutAfterFirst: BOOL _ FALSE] RETURNS [a: ATOM] = {
            r: Rule = Limit[ConsList[NARROW[rest.first], rest.rest, cutAfterFirst], min, max];
            Def[g, category, r];
            a _ category;
            };

        DLU: PUBLIC PROC [category: ATOM, rest: LORA, min: Level _ 0, max: Level _ 2] RETURNS [a: ATOM] = {
            a _ DL2[category, CONS[NIL, rest], min, max];
            };

        DC: PUBLIC PROC [category: ATOM, choices: LORA, min: Level _ 0, max: Level _ 2] RETURNS [a: ATOM] = {
            r: Rule = Limit[ConsAlt[choices], min, max];
            Def[g, category, r];
            a _ category;
            };

        DQ: PUBLIC PROC [category: ATOM, list: LORA, other: REF ANY, min: Level _ 0, max: Level _ 2] RETURNS [a: ATOM] = {
            sub: ATOM = Atom.MakeAtom[Atom.GetPName[category].Concat["Aux"]];
            [] _ DL2[sub, list, min, max];
            a _ DC[category, LIST[sub, other], min, max];
            };

        NameDef: PUBLIC PROC RETURNS [r: Rule] = {
            r _ NEW [RulePrivate _ [variant: terminal[Identifier, NIL, TRUE]]];
            };

        NameRef: PUBLIC PROC RETURNS [r: Rule] = {
            r _ NEW [RulePrivate _ [variant: terminal[Identifier]]];
            };

        Ch: PUBLIC PROC [choices: LORA] RETURNS [r: Rule] = {
            r _ ConsAlt[choices];
            };

        Star: PUBLIC PROC [rule: REF ANY] RETURNS [r: Rule] = {
            r _ ConsStar[rule, TRUE, TRUE];
            };

        Plus: PUBLIC PROC [rule: REF ANY] RETURNS [r: Rule] = {
            r _ ConsStar[rule, FALSE, TRUE];
            };

        Limit: PUBLIC PROC [rule: REF ANY, min: Level _ 0, max: Level _ 2] RETURNS [r: Rule] = {
            sub: Rule _ ToRule[rule];
            IF min = 0 AND max = 2 THEN RETURN [sub];
            r _ NEW [RulePrivate _ [levelGuard[sub, min, max]]];
            };

        Opt: PUBLIC PROC [rule: REF ANY] RETURNS [r: Rule] = {
            r _ ConsStar[rule, TRUE, FALSE];
            };

        StarCh: PUBLIC PROC [choices: LORA] RETURNS [r: Rule] = {
            r _ ConsStar[ConsAlt[choices], TRUE, TRUE];
            };

        Oo: PUBLIC PROC [category: ATOM] RETURNS [r: Rule] = {
            ntr: REF nonTerminal RulePrivate = NARROW[ToRule[category]];
            ntr.onceOnly _ TRUE;
            r _ ntr;
            };

        LR: PUBLIC PROC [rules: LORA, cutAfterFirst: BOOL _ FALSE] RETURNS [r: Rule] = {
            r _ ConsList[NARROW[rules.first], rules.rest, cutAfterFirst];
            };

        JdC: PUBLIC PROC [left, right: ATOMList] RETURNS [crossed: LORA] = {
            crossed _ NIL;
            FOR l: ATOMList _ left, l.rest WHILE l # NIL DO
                FOR r: ATOMList _ right, r.rest WHILE r # NIL DO
                    crossed _ CONS[
                        Atom.GetPName[l.first].Concat[Atom.GetPName[r.first]],
                        crossed];
                    ENDLOOP;
                ENDLOOP;
            };

        MakeRule: PUBLIC PROC [category: ATOM] RETURNS [r: Rule] = {
            r _ ToRule[category]};

        ToRule: PROC [ra: REF ANY] RETURNS [r: Rule] = {
            WITH ra SELECT FROM
                x: Rule => r _ x;
                x: REF INT => r _ ConsTerm[Integer, x];
                x: REF TEXT => r _ ConsTerm[Identifier, Atom.MakeAtomFromRefText[x]];
                x: ROPE => r _ ConsTerm[Identifier, Atom.MakeAtom[x]];
                x: ATOM => {
                    FOR tc: TerminalClass IN TerminalClass DO
                        IF x = termNames[tc] THEN {
                            r _ ConsTerm[tc, NIL];
                            EXIT};
                        REPEAT
                            FINISHED => r _ ConsNT[x];
                        ENDLOOP;
                    };
                ENDCASE => ERROR;
            };

        ToRuleList: PROC [lora: LORA] RETURNS [rl: RuleList] = {
            tail: RuleList _ rl _ NIL;
            FOR lora _ lora, lora.rest WHILE lora # NIL DO
                this: RuleList = LIST[ToRule[lora.first]];
                IF rl = NIL THEN rl _ this ELSE tail.rest _ this;
                tail _ this;
                ENDLOOP;
            };

        ConsList: PROC [key: ATOM, rest: LORA, cutAfterFirst: BOOL _ TRUE] RETURNS [r: Rule] = {
            rl: RuleList = ToRuleList[rest];
            r _ NEW [RulePrivate _ [variant: list[
                keyword: key,
                elts: CONS[ConsTerm[Identifier, key], rl],
                cutAfterFirst: cutAfterFirst
                ]]];
            };

        <<ListDefsName: PROC [rl: RuleList] RETURNS [defs: BOOL] = {>>
            <<defs _ FALSE;>>
            <<FOR rl _ rl, rl.rest WHILE rl # NIL DO>>
                <<IF DefsName[rl.first] THEN {>>
                    <<IF defs THEN ERROR ELSE RETURN [TRUE];>>
                    <<};>>
                <<ENDLOOP;>>
            <<defs _ FALSE;>>
            <<};>>
        <<>>
        <<DefsName: PROC [r: Rule] RETURNS [defs: BOOL] = {>>
            <<defs _ FALSE;>>
            <<WITH r SELECT FROM>>
                <<x: REF list RulePrivate => defs _ ListDefsName[x.rest];>>
                <<x: REF repeat RulePrivate => IF DefsName[x.sub] THEN ERROR;>>
                <<x: REF choice RulePrivate => IF ListDefsName[x.choices] THEN ERROR;>>
                <<x: REF levelGuard RulePrivate => IF DefsName[x.r] THEN ERROR;>>
                <<x: REF nonTerminal RulePrivate => NULL;>>
                <<x: REF terminal RulePrivate => defs _ x.defsName;>>
                <<ENDCASE => ERROR;>>
            <<defs _ defs;>>
            <<};>>

        ConsStar: PROC [sub: REF ANY, zero, moreThanOne: BOOL] RETURNS [r: Rule] = {
            sr: Rule = ToRule[sub];
            IF NOT (zero OR moreThanOne) THEN RETURN [sr];
            r _ NEW [RulePrivate _ [variant: repeat[
                sub: sr,
                zero: zero,
                moreThanOne: moreThanOne
                ]]];
            };

        ConsAlt: PROC [choices: LORA] RETURNS [r: Rule] = {
            rl: RuleList = ToRuleList[choices];
            IF rl.rest = NIL THEN RETURN [rl.first];
            r _ NEW [RulePrivate _ [variant: choice[
                choices: rl
                ]]];
            };

        ConsNT: PROC [category: ATOM] RETURNS [r: Rule] = {
            r _ NEW [RulePrivate _ [variant: nonTerminal[
                category: category
                ]]];
            };

        ConsTerm: PROC [category: TerminalClass, value: REF ANY] RETURNS [r: Rule] = {
            r _ NEW [RulePrivate _ [variant: terminal[
                category: category,
                value: value
                ]]];
            };

        GetCategory: PUBLIC PROC [r: Rule] RETURNS [category: ATOM] = {
            WITH r SELECT FROM
                x: REF terminal RulePrivate => category _ termNames[x.category];
                x: REF nonTerminal RulePrivate => category _ x.category;
                ENDCASE => ERROR;
            };

        }.