<<>>
    <<CrankOpsImpl.mesa>>
        <<Copyright Ó 1987, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Michael Plass, March 23, 1993 11:17 am PST>>
        <<>>
    DIRECTORY Atom, Commander, CommanderOps, List, IO, CrankIO, CrankTypes, FS, MPTree, MPLeaves, ProcessProps, Rope, SymTab, CardTab, 
    CrankOps;

    CrankOpsImpl: CEDAR PROGRAM
    IMPORTS Atom, CommanderOps, List, IO, SymTab, CardTab, ProcessProps, Rope
    EXPORTS CrankOps
    ~ BEGIN OPEN CrankTypes;

        ROPE: TYPE = Rope.ROPE;

        Error: PUBLIC SIGNAL [message: ROPE, tree: REF] = CODE;

        Assert: PUBLIC PROC [true: BOOLEAN, format: ROPE Ź NIL, value: IO.Value Ź [null[]], tree: REF Ź NIL] = {
            IF NOT true THEN {
                msg: ROPE ~ IO.PutFR1[format, value];
                WITH ProcessProps.GetProp[$CommanderHandle] SELECT FROM
                    cmd: Commander.Handle => {
                        IO.PutRope[cmd.err, "Assertion failed: "];
                        IO.PutRope[cmd.err, msg];
                        IO.PutRope[cmd.err, "\n (use CrankErrorTree command to dump tree) \n"];
                        CommanderOps.PutProp[cmd, $CrankErrorTree, tree];
                        };
                    ENDCASE;
                Error[msg, tree];
                };
            };

        Help: PUBLIC PROC [format: ROPE, value: IO.Value Ź [null[]], tree: REF Ź NIL] RETURNS [result: REF Ź NIL] = {
            SIGNAL Error[IO.PutFR1[format, value], tree]; -- may assign result with debugger
            };
<<Attribute management>>
    AddAttribute: PUBLIC PROC [aNode: AttributedNode, name: ATOM, value: REF] = {
        FOR each: LIST OF REF Ź aNode.attributes, each.rest.rest UNTIL each = NIL DO
            IF each.first = name THEN ERROR; -- multiple attribute assignment
            ENDLOOP;
        aNode.attributes Ź CONS[name, CONS[value, aNode.attributes]];
        };

    GetAttribute: PUBLIC PROC [aTree: Tree, name: ATOM] RETURNS [value: REF] = {
        aNode: AttributedNode = NARROW[aTree];
        FOR each: LIST OF REF Ź aNode.attributes, each.rest.rest UNTIL each = NIL DO
            IF each.first = name THEN RETURN [each.rest.first];
            ENDLOOP;
        RETURN [NIL]
        };

    ReplaceAttribute: PUBLIC PROC [aNode: AttributedNode, name: ATOM, value: REF] = {
        <<It is questionable as to whether we should do this.>>
        FOR each: LIST OF REF Ź aNode.attributes, each.rest.rest UNTIL each = NIL DO
            IF each.first = name THEN { each.rest.first Ź value; RETURN };
            ENDLOOP;
        ERROR; -- attribute not present
        };

    AddTypeCodeAttribute: PUBLIC PROC [tree: REF, attributeName: ATOM, typeCode: TypeCode] = {
        AddAttribute[NARROW[tree], attributeName, NEW[TypeCode Ź typeCode]]
        };

    GetTypeCodeAttribute: PUBLIC PROC [tree: REF, attributeName: ATOM] RETURNS [TypeCode] = {
        IF attributeName = NIL THEN attributeName Ź $TYPECODE;
        WITH GetAttribute[tree, attributeName] SELECT FROM
            rt: REF TypeCode => RETURN [rt­];
            ENDCASE => RETURN [nullTypeCode];
        };

    GetTypeValueAttribute: PUBLIC PROC [typeGraph: TypeGraph, tree: REF] RETURNS [TypeCode] = {
        WITH UnderType[typeGraph, GetTypeCodeAttribute[tree, $TYPECODE]] SELECT FROM
            rt: REF TypeRep.type => RETURN [rt.value];
            ENDCASE => Assert[FALSE, "Type expected here",,tree];
        RETURN [nullTypeCode]
        };

<<Type-graph management>>
    NewTypeGraph: PUBLIC PROC RETURNS [TypeGraph] = {
        typeGraph: TypeGraph = NEW[TypeGraphRep Ź [n: 0, tab: CardTab.Create[], interfaceTable: SymTab.Create[case: FALSE]]];
        [] Ź NewTypeType[typeGraph, nullTypeCode]; -- Predeclare type 0 for use as $NEEDTYPECODE attribute for type expressions
        RETURN [typeGraph]
        };

    NewType: PUBLIC PROC [typeGraph: TypeGraph, type: Type] RETURNS [typeCode: TypeCode]= {
        type.typeCode Ź typeCode Ź typeGraph.n;
        [] Ź CardTab.Insert[x: typeGraph.tab, key: typeGraph.n, val: type];
        typeGraph.n Ź typeGraph.n + 1;
        };

    NewDefinitionType: PUBLIC PROC [typeGraph: TypeGraph, qualifier: ROPE, shortName: ROPE, groundType: TypeCode] RETURNS [TypeCode] = {
        tc: TypeCode = NewType[typeGraph, NEW[TypeRep.definition Ź [class: $DEFINITION, v: definition[qualifier: qualifier, shortName: 
        shortName, groundType: groundType]]]];
        RETURN [tc];
        };

    NewInitialType: PUBLIC PROC [typeGraph: TypeGraph, environmentModule: ROPE, tree: Tree, groundType: TypeCode] RETURNS [TypeCode] = {
        tc: TypeCode = NewType[typeGraph, NEW[TypeRep.initial Ź [class: $INITIAL, v: initial[environmentModule: environmentModule, tree: 
        tree, groundType: groundType]]]];
        RETURN [tc];
        };

    NewReferenceType: PUBLIC PROC [typeGraph: TypeGraph, referentType: TypeCode, class: ATOM] RETURNS [TypeCode] = {
        tc: TypeCode = NewType[typeGraph, NEW[TypeRep.reference Ź [class: class, v: reference[referentType: referentType]]]];
        RETURN [tc];
        };

    NewTypeType: PUBLIC PROC [typeGraph: TypeGraph, value: TypeCode] RETURNS [TypeCode] = {
        tc: TypeCode = NewType[typeGraph, NEW[TypeRep.type Ź [class: $TYPE, v: type[value: value]]]];
        RETURN [tc];
        };

    TypeFromTypeCode: PUBLIC PROC [typeGraph: TypeGraph, typeCode: TypeCode] RETURNS [Type] = {
        RETURN [NARROW[CardTab.Fetch[x: typeGraph.tab, key: typeCode].val]]
        };

    recursionDepthLimit: NAT Ź 75;
    ComputeExternalTypeRep: PUBLIC PROC [typeGraph: TypeGraph] = {
        FOR i: CARD IN [0..typeGraph.n) DO
            DoPointerType: PROC [t: Type, kind: ATOM, baseType: TypeCode] = {
                l: LIST OF REF ANY Ź LIST[kind, $RECURSIVE];
                t.ext Ź l;
                t.ext Ź l Ź LIST[kind, Do[baseType]];
                };
            DoFieldList: PROC [fieldList: FieldList] RETURNS [LIST OF REF] = {
                lora: LIST OF REF Ź NIL;
                FOR each: FieldList Ź fieldList, each.rest UNTIL each = NIL DO
                    pair: LIST OF REF = LIST[each.first.name, Do[each.first.rangeType]];
                    lora Ź CONS[pair, lora];
                    ENDLOOP;
                RETURN [List.DReverse[lora]]
                };
            DoVariantList: PROC [variantList: VariantList] RETURNS [LIST OF REF] = {
                lora: LIST OF REF Ź NIL;
                FOR each: VariantList Ź variantList, each.rest UNTIL each = NIL DO
                    pair: LIST OF REF = LIST[each.first.value, DoFieldList[each.first.chooses]];
                    lora Ź CONS[pair, lora];
                    ENDLOOP;
                RETURN [List.DReverse[lora]]
                };
            Do: PROC [typeCode: TypeCode] RETURNS [REF] = {
                t: Type = TypeFromTypeCode[typeGraph, typeCode];
                l: LIST OF REF ANY;
                IF t = NIL THEN RETURN [$UNKNOWN];
                <<IF t.ext = $ILLEGALRECURSION THEN ERROR;>>
                IF t.ext # NIL THEN RETURN [t.ext];
                t.ext Ź $ILLEGALRECURSION;
                recursionDepthLimit Ź recursionDepthLimit - 1;
                WITH t SELECT FROM
                    t: REF TypeRep.definition => {g: REF Ź Do[t.groundType]; t.ext Ź g};
                    t: REF TypeRep.initial => {t.ext Ź Do[t.groundType]};
                    t: REF TypeRep.qualifiedVariant => {g: REF Ź Do[t.groundType]; t.ext Ź LIST[t.class, t.qualifier, g]};
                    t: REF TypeRep.scalar => {t.ext Ź t.class};
                    t: REF TypeRep.reference => {DoPointerType[t, t.class, t.referentType]};
                    t: REF TypeRep.notImplemented => {t.ext Ź LIST[t.class, $UNIMPLEMENTED]};
                    t: REF TypeRep.control => {
                        a: REF = Do[t.argumentType];
                        r: REF = Do[t.returnType];
                        t.ext Ź LIST[t.class, a, r]
                        };
                    t: REF TypeRep.enumerated => {
                        l Ź NIL;
                        FOR each: LIST OF EnumerationItem Ź t.items, each.rest UNTIL each = NIL DO
                            l Ź CONS[each.first.name, l];
                            ENDLOOP;
                        l Ź List.DReverse[l];
                        t.ext Ź CONS[t.class, l];
                        };
                    t: REF TypeRep.subrange => {
                        g: REF Ź Do[t.groundType];
                        t.ext Ź lŹLIST[t.class, g, t.first, t.last];
                        };
                    t: REF TypeRep.union => {
                        pair: LIST OF REF = LIST[t.tagName, Do[t.tagType]];
                        t.ext Ź lŹLIST[t.class, pair, DoVariantList[t.variantList]];
                        };
                    t: REF TypeRep.sequence => {
                        t.ext Ź LIST[t.class, t.limitName, Do[t.domainType], Do[t.rangeType]]
                        };
                    t: REF TypeRep.record => {t.ext Ź CONS[t.class, DoFieldList[t.fieldList]]};
                    t: REF TypeRep.array => {
                        d: REF Ź Do[t.domainType];
                        r: REF Ź Do[t.rangeType];
                        t.ext Ź lŹLIST[t.class, d, r]
                        };
                    t: REF TypeRep.simple => {t.ext Ź t.class};
                    t: REF TypeRep.type => {t.ext Ź LIST[t.class, Do[t.value]]};
                    ENDCASE => ERROR;
                recursionDepthLimit Ź recursionDepthLimit + 1;
                RETURN [t.ext]
                };
            [] Ź Do[i];
            ENDLOOP;
        };

    AssertNotVar: PUBLIC PROC [tree: REF] = {
        Assert[GetAttribute[tree, $VAR] # $TRUE, "Not a VAR expression",,tree];
        };

    PropagateAttribute: PUBLIC PROC [dstNode: REF, dstAttributeKey: ATOM, srcNode: AttributedNode, srcAttributeKey: ATOM] = {
        v: REF = GetAttribute[srcNode, srcAttributeKey];
        IF v # NIL THEN AddAttribute[NARROW[dstNode], dstAttributeKey, v];
        };
<<Symbol table management>>
    Alias: PROC [context: Context, id: ROPE, for: ROPE] = {
        AddSymbol[context, id, LookupSymbol[context, for]];
        };

    Root: PUBLIC PROC [context: Context] RETURNS [Context] = {
        UNTIL context.parent = NIL DO context Ź context.parent ENDLOOP;
        RETURN [context]
        };

    LookupTypeCode: PUBLIC PROC [context: Context, id: ROPE] RETURNS [TypeCode] = {
        WITH LookupSymbol[context, id] SELECT FROM
            r: REF SymbolTableEntryRep.other => {
                WITH TypeFromTypeCode[context.types, r.typeCode] SELECT FROM
                    t: REF TypeRep.type => RETURN [t.value];
                    ENDCASE => NULL;
                }
            ENDCASE => NULL;
        Assert[FALSE, "Type identifier expected here, \"%g\" found", [rope[id]]];
        RETURN [nullTypeCode]
        };

    UnderType: PUBLIC PROC [typeGraph: TypeGraph, typeCode: TypeCode] RETURNS [Type] = {
        DO
            type: Type = TypeFromTypeCode[typeGraph, typeCode];
            WITH type SELECT FROM
                t: REF TypeRep.definition => typeCode Ź t.groundType;
                t: REF TypeRep.initial => typeCode Ź t.groundType;
                ENDCASE => RETURN [type];
            ENDLOOP;
        };

    BaseType: PUBLIC PROC [typeGraph: TypeGraph, typeCode: TypeCode] RETURNS [Type] = {
        DO
            type: Type = TypeFromTypeCode[typeGraph, typeCode];
            WITH type SELECT FROM
                t: REF TypeRep.definition => typeCode Ź t.groundType;
                t: REF TypeRep.initial => typeCode Ź t.groundType;
                t: REF TypeRep.subrange => typeCode Ź t.groundType;
                ENDCASE => RETURN [type];
            ENDLOOP;
        };

    Debug: PROC = {ENABLE ABORTED=>CONTINUE; ERROR};
    GetTypeRange: PUBLIC PROC [context: Context, tree: Tree] RETURNS [first: DINT Ź 0, last: DINT Ź 2**31-1] = {
        <<Tries to pull the range out of a numeric type.>>
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPLeaves.HTNode => {
                type: Type = UnderType[context.types, LookupTypeCode[context, node.name]];
                WITH type SELECT FROM
                    t: REF TypeRep.scalar => {
                        SELECT t.class FROM
                            $BYTE, $CHAR => RETURN [0, 255];
                            $CARD32 => RETURN [0, 0FFFFFFFFH];
                            $CARD16 => RETURN [0, 0FFFFH];
                            $INT16 => RETURN [-8000H, 07FFFH];
                            $DINT => RETURN [DINT.FIRST, DINT.LAST];
                            $DCARD => RETURN [0, DINT.LAST]; -- Wrong!!! need better return value.
                            ENDCASE;
                        };
                    subrange: REF TypeRep.subrange => {
                        RETURN[first: DIntFromRef[subrange.first], last: DIntFromRef[subrange.last]];
                        };
                    ENDCASE;
                };
            ENDCASE;
        {r: REF INT Ź NARROW[Help[format: "Expected numeric type here", tree: tree], REF INT];
            IF r#NIL THEN last Ź r­;
            };
        };

    <<FieldProc: TYPE = PROC [fieldIndex: INT, fieldName: ROPE, fieldTypeCode: TypeCode, tagName: ROPE, tagTypeCode: TypeCode] RETURNS 
    [quit: BOOL _ FALSE];>>
    EnumerateFieldList: PROC [typeGraph: TypeGraph, fieldList: FieldList, firstFieldIndex: INT, tags: LIST OF ROPE, action: 
    CrankOps.FieldProc] RETURNS [BOOL] = {
        fieldIndex: INT Ź firstFieldIndex;
        FOR each: FieldList Ź fieldList, each.rest UNTIL each = NIL DO
            tagName: ROPE Ź NIL;
            tagTypeCode: TypeCode Ź nullTypeCode;
            IF each.rest = NIL THEN {
                WITH UnderType[typeGraph, each.first.rangeType] SELECT FROM
                    u: REF TypeRep.union => {
                        tagName Ź u.tagName;
                        tagTypeCode Ź u.tagType;
                        IF tags # NIL THEN {
                            FOR v: VariantList Ź u.variantList, v.rest UNTIL v = NIL DO
                                IF Rope.Equal[tags.first, NARROW[v.first.value]] THEN {
                                    <<A discriminated union; the tag becomes an ordinary field, hiding the union's field name, and the fields of the union become 
                                    visible.>>
                                    IF action[fieldIndex: fieldIndex, fieldName: tagName, fieldTypeCode: tagTypeCode, tagName: NIL, tagTypeCode: nullTypeCode] THEN 
                                    RETURN [TRUE];
                                    RETURN [EnumerateFieldList[typeGraph, v.first.chooses, fieldIndex+1, tags.rest, action]];
                                    }; 
                                ENDLOOP;
                            [] Ź Help["%g does not name a variant", [rope[tags.first]]];
                            RETURN [FALSE];
                            };
                        IF tagName = NIL THEN {
                            <<overlaid variant record; all the fields are visible, but the tag is not.>>
                            FOR v: VariantList Ź u.variantList, v.rest UNTIL v = NIL DO
                                IF EnumerateFieldList[typeGraph, v.first.chooses, fieldIndex, NIL, action] THEN RETURN [TRUE];
                                ENDLOOP;
                            };
                        };
                    s: REF TypeRep.sequence => {
                        tagName Ź s.limitName;
                        tagTypeCode Ź s.domainType;
                        };
                    ENDCASE => NULL;
                };
            IF action[fieldIndex: fieldIndex, fieldName: each.first.name, fieldTypeCode: each.first.rangeType, tagName: tagName, tagTypeCode: 
            tagTypeCode] THEN RETURN [TRUE];
            fieldIndex Ź fieldIndex + 1;
            ENDLOOP;
        RETURN [FALSE];
        };

    EnumerateFields: PUBLIC PROC [typeGraph: TypeGraph, typeCode: TypeCode, action: CrankOps.FieldProc] RETURNS [BOOL] = {
        tags: LIST OF ROPE Ź NIL;
        tc: TypeCode Ź typeCode;
        DO
            WITH UnderType[typeGraph, tc] SELECT FROM
                q: REF TypeRep.qualifiedVariant => {tags Ź CONS[q.qualifier, tags]; tc Ź q.groundType};
                r: REF TypeRep.record => RETURN [EnumerateFieldList[typeGraph, r.fieldList, 0, tags, action]];
                ENDCASE => RETURN [Help["type has no fields"]#NIL];
            ENDLOOP;
        };

    QualifyVariant: PUBLIC PROC [typeGraph: TypeGraph, typeCode: TypeCode, qualifier: ROPE] RETURNS [TypeCode] = {
        q: TypeCode Ź nullTypeCode;
        q Ź NewType[typeGraph, NEW[TypeRep.qualifiedVariant Ź [class: $QUALIFIEDVARIANT, v: qualifiedVariant[qualifier: qualifier, 
        groundType: typeCode]]]];
        RETURN [q];
        };

    NewContext: PUBLIC PROC [parent: Context] RETURNS [Context] = {
        context: Context = NEW[ContextRep Ź [parent: parent, types: IF parent = NIL THEN NewTypeGraph[] ELSE parent.types, symbols: 
        SymTab.Create[], moduleName: IF parent = NIL THEN NIL ELSE parent.moduleName, fieldListLast: NIL, concreteForOpaque: IF 
        parent = NIL THEN NIL ELSE parent.concreteForOpaque, exports: IF parent = NIL THEN NIL ELSE parent.exports]];
        RETURN [context];
        };

    AddSymbol: PUBLIC PROC [context: Context, id: ROPE, val: SymbolTableEntry] = {
        Assert[SymTab.Insert[x: context.symbols, key: id, val: val], "Multiply defined identifier: %g", [rope[id]]];
        };

    AddFieldListToContext: PUBLIC PROC [context: Context, fieldList: FieldList] = {
        FOR each: FieldList Ź fieldList, each.rest UNTIL each = NIL DO
            IF each.first.name # NIL THEN {
                AddSymbol[context, each.first.name, NEW[SymbolTableEntryRep.other Ź [other[typeCode: each.first.rangeType, readonly: FALSE, 
                constantValue: NIL]]]];
                };
            ENDLOOP;
        };

    LookupSymbol: PUBLIC PROC [context: Context, id: ROPE] RETURNS [SymbolTableEntry] = {
        FOR each: Context Ź context, each.parent UNTIL each = NIL DO
            found: BOOL Ź FALSE; val: REF;
            [found, val] Ź SymTab.Fetch[x: each.symbols, key: id];
            IF found THEN RETURN [NARROW[val]]
            ENDLOOP;
        RETURN [NARROW[Help["Undefined identifier: %g", [rope[id]]]]]
        };

    ExportType: PUBLIC PROC [context: Context, concrete, opaque: TypeCode] = {
        context.concreteForOpaque Ź CONS[[concrete, opaque], context.concreteForOpaque];
        };

    GetConcreteTypeCode: PUBLIC PROC [context: Context, typeCode: TypeCode] RETURNS [TypeCode] = {
        FOR each: LIST OF ConcreteForOpaque Ź context.concreteForOpaque, each.rest UNTIL each = NIL DO
            IF each.first.opaque = typeCode THEN RETURN [each.first.concrete]
            ENDLOOP;
        RETURN [nullTypeCode]
        };
<<Attributed tree support>>
    GetIdentifier: PUBLIC PROC [tree: Tree] RETURNS [ROPE] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            rope: ROPE => RETURN [rope];
            ht: REF MPLeaves.HTNode => RETURN [ht.name];
            ENDCASE => RETURN [NARROW[Help[format: "Expected identifier here", tree: tree]]];
        };

    <<GetID: PROC [tree: Tree] RETURNS [r: ROPE _ NIL] = {>>
        <<Identifier: PROC [id: ROPE] = {r _ id};>>
        <<IF GetNodeName[tree] = $ID THEN [] _ WithId[tree, Identifier];>>
        <<};>>
    QualifyIdentifierNode: PUBLIC PROC [tree: Tree, qualifier: ROPE]  = {
        <<IF Rope.Equal[qualifier, "Imager"] AND  Rope.Equal[GetID[tree], "VEC"] THEN [] _ Help[NIL,,tree];>>
        IF qualifier # NIL THEN AddAttribute[NARROW[tree], $QUAL, qualifier];
        };

    QualifiedName: TYPE = RECORD [qualifier, shortName: ROPE];
    GetTypeName: PUBLIC PROC [context: Context, typeCode: TypeCode, retainInitalValue: BOOL] RETURNS [LIST OF REF] = {
        tc: TypeCode Ź typeCode;
        defaultName: QualifiedName Ź ["THRUTHEDESERT", "NONAME"];
        name: QualifiedName Ź defaultName;
        list: LIST OF REF Ź NIL;
        tags: LIST OF REF Ź NIL;
        initTree: Tree Ź NIL;
        DO
            WITH TypeFromTypeCode[context.types, tc] SELECT FROM
                d: REF TypeRep.definition => {
                    name Ź [d.qualifier, d.shortName];
                    tc Ź d.groundType;
                    };
                i: REF TypeRep.initial => {
                    IF initTree = NIL THEN initTree Ź i.tree;
                    tc Ź i.groundType;
                    };
                q: REF TypeRep.qualifiedVariant => {
                    tc Ź q.groundType;
                    tags Ź List.Nconc1[tags, q.qualifier];
                    };
                r: REF TypeRep.reference => {
                    list Ź CONS[$PTR, list];
                    tc Ź r.referentType;
                    };
                r: REF TypeRep.record => {
                    IF name = defaultName AND r.fieldList # NIL AND r.fieldList.rest = NIL
                        THEN tc Ź r.fieldList.first.rangeType
                        ELSE EXIT;
                    };
                ENDCASE => EXIT;
            ENDLOOP;
        IF name = defaultName THEN {
            list Ź NIL;
            WITH UnderType[context.types, typeCode] SELECT FROM
                q: REF TypeRep.reference => {
                    name Ź ["BUILTIN", "REF"];
                    };
                q: REF TypeRep.scalar => {
                    name Ź ["BUILTIN", Atom.GetPName[q.class]];
                    };
                q: REF TypeRep.control => {
                    name Ź ["BUILTIN", Atom.GetPName[q.class]];
                    };
                ENDCASE => NULL;
            };
        IF tags # NIL THEN list Ź List.Nconc1[list, CONS[$TAGS, tags]];
        IF initTree # NIL AND retainInitalValue THEN list Ź List.Nconc1[list, LIST[$INIT, initTree]];
        RETURN [CONS[name.qualifier, CONS[name.shortName, list]]];
        };

    GenSym: PUBLIC PROC [typeGraph: TypeGraph, prefix: ROPE] RETURNS [ROPE] = {
        n: INT = typeGraph.gensym;
        typeGraph.gensym Ź n + 1;
        RETURN [IO.PutFR["%g%g", [rope[prefix]], [integer[n]]]]
        };

    DIntFromRef: PUBLIC PROC [ref: REF] RETURNS [DINT Ź 0] = {
        WITH ref SELECT FROM
            r: REF INT => RETURN [r­];
            r: REF INTEGER => RETURN [r­];
            r: REF DINT => RETURN [r­];
            r: REF CARD => RETURN [r­];
            r: REF CARDINAL => RETURN [r­];
            r: REF DCARD => RETURN [r­];
            ENDCASE;
        ref Ź Help[format: "Expected number here", tree: ref];
        WITH ref SELECT FROM
            r: REF DINT => RETURN [r­];
            ENDCASE;
        };

    GetSimpleConstant: PUBLIC PROC [context: Context, tree: Tree] RETURNS [result: DINT Ź 0] = {
        <<This is used for evaluation the values in machine-dependent types.  We restrict these a bit more than we ought, for simplicity.>>
        aNode: AttributedNode = NARROW[tree];
        WITH GetAttribute[aNode, $ORDINALVALUE] SELECT FROM
            r: REF INT => RETURN [r­];
            r: REF DINT => RETURN [r­];
            r: REF CARD => RETURN [r­];
            r: REF DCARD => RETURN [r­];
            ENDCASE => NULL;
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                Child: PROC [index: NAT] RETURNS [DINT] = {
                    RETURN [GetSimpleConstant[context, node.son[index]]]
                    };
                IF node.name = mwconst THEN RETURN [Child[1]];
                IF node.name = uminus THEN RETURN [-Child[1]];
                IF node.name = plus THEN RETURN [Child[1]+Child[2]];
                IF node.name = minus THEN RETURN [Child[1]-Child[2]];
                IF node.name = times THEN RETURN [Child[1]*Child[2]];
                IF node.name = succ THEN RETURN [Child[1]+1];
                IF node.name = pred THEN RETURN [Child[1]-1];
                IF node.name = first THEN {
                    RETURN [GetTypeRange[context, node.son[1]].first];
                    };
                IF node.name = last THEN {
                    RETURN [GetTypeRange[context, node.son[1]].last];
                    };
                };
            ht: REF MPLeaves.LTNode => {
                WITH ht.value SELECT FROM
                    r: REF INT => RETURN [r­];
                    r: REF INTEGER => RETURN [r­];
                    r: REF DINT => RETURN [r­];
                    r: REF CARD => RETURN [r­];
                    r: REF CARDINAL => RETURN [r­];
                    r: REF DCARD => RETURN [r­];
                    ENDCASE => NULL;
                };
            ENDCASE => NULL;
        {r: REF INT Ź NARROW[Help[format: "Expected number here", tree: tree], REF INT];
            IF r#NIL THEN result Ź r­;
            };
        };

    GetRopeLiteral: PUBLIC PROC [tree: Tree] RETURNS [ROPE] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            lt: REF MPLeaves.LTNode => RETURN [NARROW[lt.value, REF ROPE]­];
            ENDCASE => RETURN [NARROW[Help[format: "Expected rope literal here", tree: tree]]];
        };

    GetNodeName: PUBLIC PROC [tree: Tree] RETURNS [ATOM] = {
        aNode: AttributedNode = NARROW[tree];
        RETURN [aNode.syntaxNodeName]
        };

    DoList: PUBLIC PROC [listOrItem: Tree, action: PROC [Tree]] = {
        <<Many of the abstract productions allow either an item or list of items.  This enumerates them in either case.>>
        aNode: AttributedNode = NARROW[listOrItem];
        IF listOrItem = NIL THEN RETURN;
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = list THEN {
                    FOR i: NAT IN [1..node.sonLimit) DO
                        action[node.son[i]];
                        ENDLOOP;
                    RETURN;
                    };
                };
            ENDCASE => NULL;
        recursionDepthLimit Ź recursionDepthLimit - 1;
        action[listOrItem];
        recursionDepthLimit Ź recursionDepthLimit + 1;
        };

    WithId: PUBLIC PROC [tree: Tree, action: PROC [id: ROPE]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            rope: ROPE => { action[rope]; RETURN [TRUE] };
            ht: REF MPLeaves.HTNode => { action[ht.name]; RETURN [TRUE] };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    WithLiteral: PUBLIC PROC [tree: Tree, action: PROC [literal: REF MPLeaves.LTNode]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            lt: REF MPLeaves.LTNode => { action[lt]; RETURN [TRUE] };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    GetNodeNameCode: PUBLIC PROC [tree: Tree] RETURNS [MPTree.NodeName] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => RETURN [node.name];
            ENDCASE => RETURN [none];
        };

    With0: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=0, "Expecting 0 sons",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    DoWith1: PUBLIC PROC [tree: Tree, action: PROC [REF]] = {
        [] Ź With1[tree, GetNodeNameCode[tree], action];
        };

    With1: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC [REF]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=1, "Expecting 1 son",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[node.son[1]];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    DoWith2: PUBLIC PROC [tree: Tree, action: PROC [REF, REF]] = {
        [] Ź With2[tree, GetNodeNameCode[tree], action];
        };

    With2: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC [REF, REF]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=2, "Expecting 2 sons",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[node.son[1], node.son[2]];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    DoWith3: PUBLIC PROC [tree: Tree, action: PROC [REF, REF, REF]] = {
        [] Ź With3[tree, GetNodeNameCode[tree], action];
        };

    With3: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC [REF, REF, REF]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=3 OR (node.sonLimit-1=2 AND nodeName = apply), "Expecting 3 sons",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[node.son[1], node.son[2], IF node.sonLimit-1 = 3 THEN node.son[3] ELSE NIL];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    DoWith4: PUBLIC PROC [tree: Tree, action: PROC [REF, REF, REF, REF]] = {
        [] Ź With4[tree, GetNodeNameCode[tree], action];
        };

    With4: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC [REF, REF, REF, REF]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=4, "Expecting 4 sons",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[node.son[1], node.son[2], node.son[3], node.son[4]];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    DoWith5: PUBLIC PROC [tree: Tree, action: PROC [REF, REF, REF, REF, REF]] = {
        [] Ź With5[tree, GetNodeNameCode[tree], action];
        };

    With5: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC [REF, REF, REF, REF, REF]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=5, "Expecting 5 sons",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[node.son[1], node.son[2], node.son[3], node.son[4], node.son[5]];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    DoWith6: PUBLIC PROC [tree: Tree, action: PROC [REF, REF, REF, REF, REF, REF]] = {
        [] Ź With6[tree, GetNodeNameCode[tree], action];
        };

    With6: PUBLIC PROC [tree: Tree, nodeName: MPTree.NodeName, action: PROC [REF, REF, REF, REF, REF, REF]] RETURNS [BOOL] = {
        aNode: AttributedNode = NARROW[tree];
        WITH aNode.syntaxNode SELECT FROM
            node: REF MPTree.Node => {
                IF node.name = nodeName THEN {
                    Assert[node.sonLimit-1=6, "Expecting 6 sons",, tree];
                    recursionDepthLimit Ź recursionDepthLimit - 1;
                    action[node.son[1], node.son[2], node.son[3], node.son[4], node.son[5], node.son[6]];
                    recursionDepthLimit Ź recursionDepthLimit + 1;
                    RETURN [TRUE];
                    };
                };
            ENDCASE => NULL;
        RETURN [FALSE];
        };

    END.