
    <<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 [    ConsumeResult: PROC [res: REF ANY, pt: ParseTree], nc: NamingContext] RETURNS [match: BOOL, ptail: ParseTreeList, result: REF 
    ANY] = {
        urLevel: Level = level;
        SubSetLevel: PROC [
            level _ 
            IF ups > 0 THEN SetLevel[level, ups-1]};
        SetThisLevel: PROC [
        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 [

    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.