<<>>
<<Pass3Xc.mesa>>
    <<Copyright Ó 1985, 1986, 1987, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
    <<Satterthwaite, June 17, 1986 3:18:13 pm PDT>>
    <<Russ Atkinson (RRA) January 3, 1991 1:33 pm PST>>
    <<>>
    DIRECTORY
        Alloc USING [Notifier],
        MimData USING [bitsToAlignment, idCARDINAL, idCHAR, idINTEGER, typeStringBody],
        MimosaCopier USING [CtxFirst, CtxNext, CtxValue, nullSEToken, SEToken],
        MimosaLog USING [Error, ErrorN, ErrorNode, ErrorNodeOp, ErrorTree, ErrorTreeOp],
        MimP3 USING [And, Attr, ClearType, emptyAttr, Exp, ForceType, fullAttr, Interval, MakeLongType, MakeRefType, MergeNP, NPUse, 
        phraseNP, RAttrPop, Rhs, RPush, RType, SequenceField, SetType, TypeExp, VoidExp],
        MimP3S USING [safety],
        Pass3Attributes USING [BaseType, CanonicalType, LongPath, LongType, OperandLhs, OperandType, OrderedType, TargetType, TypeForTree],
        SymbolOps USING [DecodeCard, DecodeTreeIndex, EqTypes, MakeNonCtxSe, NormalType, own, RCType, ReferentType, TypeForm, UnderType],
        Symbols USING [Base, CSEIndex, CTXIndex, ISEIndex, ISENull, nullType, SERecord, seType, Type, typeANY],
        Target: TYPE MachineParms USING [bitOrder, bitsPerLongPtr, bitsPerPtr, bitsPerWord],
        Tree USING [Base, Index, Link, NodeName, Null, treeType],
        TreeOps USING [FreeNode, GetNode, GetTag, IdentityMap, ListLength, NthSon, OpName, PopTree, PushNode, PushSe, PushTree, SetAttr, 
        UpdateList];
Pass3Xc: PROGRAM
    IMPORTS MimData, MimosaCopier, MimosaLog, MimP3, MimP3S, Pass3Attributes, SymbolOps, TreeOps
    EXPORTS MimP3 = {
    OPEN MimP3, Pass3Attributes, Symbols, TreeOps;

    SEToken: TYPE = MimosaCopier.SEToken;

    tb: Tree.Base;    -- tree base address (local copy)
    seb: Symbols.Base;    -- se table base address (local copy)

    ExpCNotify: PUBLIC Alloc.Notifier = {
        <<called by allocator whenever table area is repacked>>
        seb Ź base[seType];
        tb Ź base[Tree.treeType];
        };
<<Local Utilites>>
    NormType: PROC [type: Type] RETURNS [CSEIndex] = {
        RETURN [SymbolOps.NormalType[SymbolOps.own, type]];
        };
<<Ranges>>
    Range: PUBLIC PROC [t: Tree.Link, type: Type] RETURNS [val: Tree.Link] = {
        subType: Type;
        SELECT OpName[t] FROM
            subrangeTC => {
                node: Tree.Index = GetNode[t];
                subNode: Tree.Index = GetNode[tb[node].son[2]];
                PushTree[tb[subNode].son[1]];
                PushTree[IdentityMap[tb[node].son[1]]];
                PushNode[apply, -2];
                tb[subNode].son[1] Ź PopTree[];
                PushTree[tb[subNode].son[2]];
                PushTree[tb[node].son[1]];
                PushNode[apply, -2];
                tb[subNode].son[2] Ź PopTree[];
                tb[node].son[1] Ź tb[node].son[2] Ź Tree.Null;
                FreeNode[node];
                val Ź [subtree[subNode]];
                Interval[val, type, FALSE];
                };
            intOO, intOC, intCO, intCC => {
                val Ź t;
                Interval[val, type, FALSE];
                };
            ENDCASE => {
                val Ź TypeExp[t];
                RPush[TargetType[TypeForTree[val]], MimP3.fullAttr];
                phraseNP Ź none;
                };
        subType Ź RType[];
        IF ~OrderedType[subType] AND subType # typeANY THEN
            MimosaLog.Error[nonOrderedType];
        };
<<Operations on enumerated types>>
    Span: PUBLIC PROC [type: CSEIndex] RETURNS [first, last: SEToken] = {
        subType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, TargetType[type]];
        vCtx: CTXIndex = WITH s: seb[subType] SELECT FROM
            enumerated => s.valueCtx,
            ENDCASE => ERROR;
        WITH t: seb[type] SELECT FROM
            enumerated => {
                first Ź CtxFirst[vCtx];
                last Ź CtxLast[vCtx];
                };
            subrange => {
                IF t.mark4
                    THEN {
                        org: INT Ź IF t.biased THEN t.origin ELSE 0;
                        first Ź MimosaCopier.CtxValue[vCtx, org];
                        last Ź MimosaCopier.CtxValue[vCtx, org + t.range];
                        }
                    ELSE {
                        node: Tree.Index = LOOPHOLE[t.range];
                        subNode: Tree.Index = GetNode[tb[node].son[2]];
                        first Ź EnumeratedValue[tb[subNode].son[1], vCtx];
                        last Ź EnumeratedValue[tb[subNode].son[2], vCtx];
                        SELECT tb[subNode].name FROM
                            intOO, intOC => first Ź CtxSucc[vCtx, first];
                            ENDCASE;
                        SELECT tb[subNode].name FROM
                            intOO, intCO => last Ź CtxPred[vCtx, last];
                            ENDCASE;
                        };
                };
            ENDCASE => first Ź last Ź MimosaCopier.nullSEToken;
        };

    EnumeratedValue: PROC [t: Tree.Link, vCtx: CTXIndex] RETURNS [SEToken] = {
        ret: SEToken Ź MimosaCopier.nullSEToken;
        WITH t SELECT GetTag[t] FROM
            symbol => {
                sei: ISEIndex = index;
                SELECT TRUE FROM
                    NOT seb[sei].constant => {};
                    (seb[sei].idCtx = vCtx) OR seb[sei].mark4 =>
                        ret Ź MimosaCopier.CtxValue[vCtx, SymbolOps.DecodeCard[seb[sei].idValue]];
                    ENDCASE => ret Ź EnumeratedValue[InitTree[sei], vCtx];
                };
            subtree => {
                node: Tree.Index = index;
                IF tb[node].nSons >= 1 THEN {
                    son1: Tree.Link = tb[node].son[1];
                    name: Tree.NodeName = tb[index].name;
                    SELECT tb[node].name FROM
                        first, last => {
                            ut: CSEIndex = SymbolOps.UnderType[SymbolOps.own, TypeForTree[son1]];
                            firstToken, lastToken: SEToken;
                            [firstToken, lastToken] Ź Span[ut];
                            IF name = first THEN ret Ź firstToken ELSE ret Ź lastToken;
                            };
                        pred, succ => {
                            token: SEToken = EnumeratedValue[son1, vCtx];
                            IF name = pred
                                THEN ret Ź CtxPred[vCtx, token]
                                ELSE ret Ź CtxSucc[vCtx, token];
                            };
                        ENDCASE;
                    };
                };
            ENDCASE;
        RETURN [ret];
        };

    CtxFirst: PROC [ctx: CTXIndex] RETURNS [SEToken] = MimosaCopier.CtxFirst;

    CtxLast: PROC [ctx: CTXIndex] RETURNS [SEToken] = {
        last: SEToken Ź MimosaCopier.nullSEToken;
        FOR t: SEToken Ź MimosaCopier.CtxFirst[ctx], MimosaCopier.CtxNext[ctx, t]
        UNTIL t = MimosaCopier.nullSEToken DO
            last Ź t;
            ENDLOOP;
        RETURN [last];
        };

    CtxSucc: PROC [ctx: CTXIndex, t: SEToken] RETURNS [SEToken] = MimosaCopier.CtxNext;

    CtxPred: PROC [ctx: CTXIndex, t: SEToken] RETURNS [SEToken] = {
        pred: SEToken Ź MimosaCopier.nullSEToken;
        IF t # MimosaCopier.nullSEToken THEN {
            next: SEToken Ź MimosaCopier.CtxFirst[ctx];
            UNTIL next = t OR next = MimosaCopier.nullSEToken DO
                pred Ź next;
                next Ź MimosaCopier.CtxNext[ctx, next];
                ENDLOOP;
            };
        RETURN [pred];
        };

    InitTree: PROC [sei: ISEIndex] RETURNS [Tree.Link] = INLINE {
        RETURN [tb[SymbolOps.DecodeTreeIndex[seb[sei].idValue]].son[3]];
        };
<<Operations on addresses>>
    AddrOp: PUBLIC PROC [node: Tree.Index, target: Type] = {
        SELECT tb[node].name FROM
            addr => Addr[node, target];
            base => Base[node, target];
            length => Length[node];
            arraydesc => Desc[node, target];
            ENDCASE => ERROR;
        };

    Addr: PROC [node: Tree.Index, target: Type] = {
        type: Type;
        subType: CSEIndex = NormType[target];
        var: BOOL Ź FALSE;
        readonly: BOOL Ź FALSE;
        counted: BOOL Ź FALSE;
        son1: Tree.Link Ź tb[node].son[1] Ź Exp[tb[node].son[1], typeANY];
        each: Tree.Link Ź son1;
        WITH t: seb[subType] SELECT FROM
            ref => {
                readonly Ź t.readOnly;
                var Ź t.var;
                IF t.counted THEN
                    DO
                        SELECT OpName[each] FROM
                            uparrow => {
                                next: Tree.Link Ź NthSon[each, 1];
                                nType: CSEIndex = NormType[OperandType[next]];
                                WITH p: seb[nType] SELECT FROM
                                    ref => IF p.counted THEN counted Ź TRUE;
                                    ENDCASE;
                                EXIT;
                                };
                            cast, openx => each Ź NthSon[each, 1];
                            ENDCASE => EXIT;
                        ENDLOOP;
                };
            ENDCASE;
        IF MimP3S.safety = checked AND ~(var OR tb[node].attr1) THEN
            MimosaLog.ErrorNodeOp[unsafeOp, node, addr];
        SELECT OperandLhs[son1, readonly] FROM
            counted =>
                IF var THEN {
                    son1 Ź tb[node].son[1] Ź SafenRef[son1];
                    IF SymbolOps.RCType[SymbolOps.own, RType[]] # none THEN
                        MimosaLog.ErrorTree[unimplemented, son1];
                    };
            none => MimosaLog.ErrorTree[nonAddressable, son1];
            ENDCASE;
        type Ź MakeRefType[
            cType: RType[], hint: subType, bits: Target.bitsPerPtr,
            counted: counted AND ~var, var: var, readOnly: readonly];
        SELECT TRUE FROM
            var => {MimosaLog.ErrorNode[unimplemented, node]; tb[node].attr2 Ź FALSE};
            (tb[node].attr2 Ź LongPath[son1]) => type Ź MakeLongType[type, target];
            ENDCASE;
        RPush[type, RAttrPop[]];
        };

    SafenRef: PROC [t: Tree.Link] RETURNS [Tree.Link] = {
        v: Tree.Link Ź t;
        WITH t SELECT GetTag[t] FROM
            subtree => {
                node: Tree.Index = index;
                SELECT tb[node].name FROM
                    dot, uparrow, dindex, reloc => {
                        PushTree[tb[node].son[1]];
                        PushNode[safen, 1];
                        SetType[OperandType[tb[node].son[1]]];
                        tb[node].son[1] Ź PopTree[];
                        };
                    dollar, index, seqindex, loophole, cast, openx, pad, chop =>
                        tb[node].son[1] Ź SafenRef[tb[node].son[1]];
                    cdot =>
                        tb[node].son[2] Ź SafenRef[tb[node].son[2]];
                    apply, safen => {};
                    ENDCASE => ERROR;
                };
            ENDCASE => {};
        RETURN [v];
        };

    StripRelative: PROC [rType: Type] RETURNS [type: Type, baseType: Type] = {
        rSei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, rType];
        WITH r: seb[rSei] SELECT FROM
            relative => {type Ź r.offsetType; baseType Ź r.baseType};
            ENDCASE => {type Ź rType; baseType Ź nullType};
        };

    MakeRelativeType: PROC [type: Type, bType: Type, hint: Type] RETURNS [Type] = {
        protoType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, hint];
        WITH p: seb[protoType] SELECT FROM
            relative =>
                IF SymbolOps.EqTypes[SymbolOps.own, p.offsetType, type] AND SymbolOps.EqTypes[SymbolOps.own, p.baseType, bType] THEN RETURN [hint];
            ENDCASE;
        {
            <<RRA: is all of this still necessary? still correct?>>
            rType: CSEIndex Ź SymbolOps.MakeNonCtxSe[SERecord.cons.relative.SIZE];
            seb[rType].typeInfo Ź relative[
                baseType: bType,
                offsetType: type,
                resultType: type];
            seb[rType].mark3 Ź seb[rType].mark4 Ź TRUE;
            RETURN [rType];
            };
        };

    Base: PROC [node: Tree.Index, target: Type] = {
        type, aType, bType, subTarget: Type;
        nType: CSEIndex;
        attr: Attr;
        long: BOOL;
        son1: Tree.Link Ź tb[node].son[1];
        IF MimP3S.safety = checked THEN MimosaLog.ErrorNodeOp[unsafeOp, node, base];
        IF ListLength[son1] = 1
            THEN {
                son1 Ź tb[node].son[1] Ź Exp[son1, typeANY];
                [aType, bType] Ź StripRelative[CanonicalType[RType[]]];
                attr Ź RAttrPop[];
                nType Ź MimP3.ClearType[aType];
                subTarget Ź StripRelative[target].type;
                WITH n: seb[nType] SELECT FROM
                    array => {
                        tb[node].name Ź addr;
                        IF OperandLhs[son1] = none THEN
                            MimosaLog.ErrorTree[nonAddressable, son1];
                        long Ź LongPath[son1];
                        };
                    arraydesc => {
                        long Ź LongType[aType];
                        nType Ź SymbolOps.UnderType[SymbolOps.own, n.describedType];
                        tb[node].attr1 Ź TRUE;
                        };
                    ENDCASE => IF nType # typeANY THEN
                        MimosaLog.ErrorTreeOp[missingOp, son1, base];
                }
            ELSE {
                MimosaLog.ErrorN[listLong, ListLength[son1]-1];
                son1 Ź tb[node].son[1] Ź UpdateList[son1, VoidExp];
                long Ź FALSE;
                };
        type Ź MakeRefType[nType, BaseType[subTarget], Target.bitsPerPtr];
        IF (tb[node].attr2 Ź long) THEN type Ź MakeLongType[type, subTarget];
        IF bType # nullType THEN type Ź MakeRelativeType[type, bType, target];
        attr.const Ź FALSE;
        RPush[type, attr];
        };

    Length: PROC [node: Tree.Index] = {
        son1: Tree.Link Ź tb[node].son[1];
        attr: Attr Ź MimP3.emptyAttr;
        IF ListLength[son1] = 1
            THEN {
                type: Type;
                subType: CSEIndex Ź typeANY;
                son1 Ź tb[node].son[1] Ź Exp[son1, typeANY];
                type Ź RType[];
                attr Ź RAttrPop[];
                subType Ź MimP3.ClearType[StripRelative[CanonicalType[type]].type];
                WITH seb[subType] SELECT FROM
                    array => {
                        IF ~SymbolOps.EqTypes[SymbolOps.own, subType, type] THEN
                            son1 Ź tb[node].son[1] Ź ForceType[son1, subType];
                        attr.const Ź TRUE;
                        };
                    arraydesc => {
                        attr.const Ź FALSE;
                        tb[node].attr1 Ź TRUE;
                        };
                    ENDCASE => {
                        attr.const Ź TRUE;
                        IF type # typeANY THEN MimosaLog.ErrorTreeOp[missingOp, son1, length];
                        };
                }
            ELSE {
                attr.const Ź TRUE;
                MimosaLog.ErrorN[listLong, ListLength[son1]-1];
                son1 Ź tb[node].son[1] Ź UpdateList[son1, VoidExp];
                };
        RPush[MimData.idINTEGER, attr];
        };

    Desc: PROC [node: Tree.Index, target: Type] = {
        type, subType: Type;
        attr: Attr;
        saveNP: NPUse;
        aType, bType: Type Ź nullType;
        cType, iType: Type;
        fixed: {none, range, both} Ź none;
        packed: BOOL Ź FALSE;
        long: BOOL;
        subTarget: Type = StripRelative[target].type;
        cSei: CSEIndex;
        nTarget: CSEIndex = NormType[subTarget];
        nType: CSEIndex;
        son1: Tree.Link Ź tb[node].son[1];
        IF MimP3S.safety = checked THEN MimosaLog.ErrorNodeOp[unsafeOp, node, arraydesc];
        SELECT ListLength[son1] FROM
            1 => {
                rType: Type;
                nDerefs: CARDINAL Ź 0;
                son1 Ź tb[node].son[1] Ź Exp[son1, typeANY];
                IF OperandLhs[son1] = none THEN MimosaLog.ErrorTree[nonAddressable, son1];
                long Ź LongPath[son1];
                rType Ź RType[];
                cSei Ź SymbolOps.UnderType[SymbolOps.own, CanonicalType[rType]];
                IF ~SymbolOps.EqTypes[SymbolOps.own, cSei, rType] THEN
                    son1 Ź tb[node].son[1] Ź ForceType[son1, cSei];
                attr Ź RAttrPop[];
                nType Ź NormType[cSei];
                WHILE seb[nType].typeTag = ref AND (nDerefs Ź nDerefs+1) < 64 DO
                    long Ź LongType[cSei];
                    cSei Ź SymbolOps.UnderType[SymbolOps.own, CanonicalType[SymbolOps.ReferentType[SymbolOps.own, nType]]];
                    PushTree[son1];  PushNode[uparrow, 1];
                    SetType[cSei];  SetAttr[2, long];  SetAttr[3, FALSE];
                    son1 Ź tb[node].son[1] Ź PopTree[];
                    nType Ź NormType[cSei];
                    ENDLOOP;
                PushTree[son1];
                IF seb[cSei].typeTag = record THEN {
                    sei: ISEIndex = SequenceField[LOOPHOLE[cSei]];
                    SELECT TRUE FROM
                        (sei # ISENull) => {
                            cSei Ź SymbolOps.UnderType[SymbolOps.own, seb[sei].idType];
                            WITH s: seb[cSei] SELECT FROM
                                sequence => {
                                    PushSe[sei]; PushNode[dollar, 2];
                                    SetType[cSei];
                                    SetAttr[2, long];
                                    };
                                ENDCASE => ERROR};
                        (cSei = MimData.typeStringBody) => NULL;    -- fake sequence
                        ENDCASE => {
                            MimosaLog.ErrorTreeOp[missingOp, son1, arraydesc]; cSei Ź typeANY}
                        };
                WITH t: seb[cSei] SELECT FROM
                    array => {rType Ź aType Ź OperandType[son1]; fixed Ź both};
                    sequence => {
                        rType Ź cType Ź t.componentType;  packed Ź t.packed;
                        iType Ź seb[t.tagSei].idType;  fixed Ź both;
                        IF ~t.controlled THEN MimosaLog.ErrorTreeOp[missingOp, son1, arraydesc];
                        };
                    record => { -- StringBody
                        rType Ź cType Ź MimData.idCHAR;
                        packed Ź TRUE;
                        iType Ź MimData.idCARDINAL;
                        fixed Ź both;
                        };
                    ENDCASE => {
                        rType Ź cType Ź typeANY;
                        IF cSei # typeANY THEN MimosaLog.ErrorTreeOp[missingOp, son1, arraydesc];
                        };
                subType Ź MakeRefType[rType, typeANY, Target.bitsPerPtr];
                IF long THEN subType Ź MakeLongType[subType, typeANY];
                PushNode[addr, 1];  SetType[subType];  SetAttr[2, long];
                son1 Ź tb[node].son[1] Ź PopTree[];
                };
            3 => {
                subNode: Tree.Index = GetNode[son1];
                tb[subNode].son[1] Ź Exp[tb[subNode].son[1], typeANY];
                [subType, bType] Ź StripRelative[CanonicalType[RType[]]];
                nType Ź NormType[subType];
                attr Ź RAttrPop[];
                saveNP Ź phraseNP;
                SELECT SymbolOps.TypeForm[SymbolOps.own, nType] FROM
                    $basic, $ref, $signed, $unsigned => NULL;
                    ENDCASE => MimosaLog.ErrorTree[typeClash, tb[subNode].son[1]];
                long Ź LongType[subType];
                tb[subNode].son[2] Ź Rhs[tb[subNode].son[2], MimData.idINTEGER];
                attr Ź And[RAttrPop[], attr];
                phraseNP Ź MergeNP[saveNP][phraseNP];
                IF tb[subNode].son[3] # Tree.Null THEN {
                    tb[subNode].son[3] Ź TypeExp[tb[subNode].son[3]];
                    cType Ź TypeForTree[tb[subNode].son[3]];
                    fixed Ź range;
                    };
                };
            ENDCASE;
        IF aType = nullType THEN {
            WITH n: seb[nTarget] SELECT FROM
                arraydesc => {
                    cSei Ź SymbolOps.UnderType[SymbolOps.own, n.describedType];
                    WITH t: seb[cSei] SELECT FROM
                        array =>
                            IF fixed = none
                                OR (fixed = range
                                AND SymbolOps.EqTypes[SymbolOps.own, t.componentType, cType]) THEN {
                                    aType Ź n.describedType; GO TO old};
                        ENDCASE};
                ENDCASE;
            GO TO new;
            EXITS
                old => {};
                new => {
                    aType Ź SymbolOps.MakeNonCtxSe[SERecord.cons.array.SIZE];
                    seb[aType] Ź [mark3: TRUE, mark4: TRUE, body: cons[
                        align: unknown,
                        typeInfo: array[
                            packed: packed,
                            bitOrder: IF Target.bitOrder = msBit THEN msBit ELSE lsBit,
                            indexType: IF fixed < both THEN MimData.idCARDINAL ELSE iType,
                            componentType: IF fixed > none THEN cType ELSE typeANY]]];
                    };
            };
        {
            <<make type description>>
            WITH t: seb[nTarget] SELECT FROM
                arraydesc =>
                    IF SymbolOps.EqTypes[SymbolOps.own, t.describedType, aType] THEN GO TO old;
                ENDCASE =>
                    IF fixed = none AND target = typeANY THEN MimosaLog.ErrorNode[noTarget, node];
            GO TO new;
            EXITS
                old => type Ź nTarget;
                new => {
                    bits: NAT = Target.bitsPerWord
                    + (IF long THEN Target.bitsPerLongPtr ELSE Target.bitsPerPtr);
                    type Ź SymbolOps.MakeNonCtxSe[SERecord.cons.arraydesc.SIZE];
                    seb[type] Ź [mark3: TRUE, mark4: TRUE, body: cons[
                        align: MimData.bitsToAlignment[bits],
                        typeInfo: arraydesc[
                        length: bits,
                        readOnly: FALSE,
                        var: FALSE,
                        bitOrder: IF Target.bitOrder = msBit THEN msBit ELSE lsBit,
                        describedType: aType]]];
                    };
            };
        IF (tb[node].attr2 Ź long) THEN type Ź MakeLongType[type, subTarget];
        IF bType # nullType THEN type Ź MakeRelativeType[type, bType, target];
        attr.const Ź FALSE;
        RPush[type, attr];
        };

}.