
    <<Pass3V.Mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Satterthwaite, June 11, 1986 12:52:38 pm PDT>>
        <<Russ Atkinson (RRA) March 6, 1985 10:44:46 pm PST>>

    DIRECTORY
        A3 USING [CanonicalType, LongPath, MarkedType, OperandType, TargetType, TypeForTree],
        Alloc USING [Notifier],
        ComData USING [idBOOL, ownSymbols, seAnon, textIndex, typeAtomRecord],
        Copier USING [CopyUnion],
        Log USING [Error, ErrorHti, ErrorSei, ErrorTree, Warning],
        P3 USING [Attr, NarrowOp, NPUse, phraseNP, BaseTree, EnterType, Exp, FindSe, FirstId, ForceType, OpenPointer, PopCtx, PushCtx, 
        PushHtCtx, PushRecordCtx, RAttr, Rhs, RPop, RPush, Scope, SealRefStack, SearchCtxList, SetType, TopCtx, UnsealRefStack, 
        UpdateTreeAttr, UType, VoidExp],
        P3S USING [ImplicitInfo, implicit, implicitRecord, safety],
        SourceMap USING [Loc],
        Symbols USING [Base, HTIndex, Type, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex, HTNull, nullType, ISENull, CSENull, CTXNull, 
        typeANY, typeTYPE, seType, ctxType],
        SymbolOps USING [DecodeTreeIndex, DecodeType, FromType, NextSe, NormalType, RCType, ReferentType, ToType, TypeForm, TypeLink, 
        TypeRoot, UnderType],
        Tree USING [Base, Index, Link, Map, Null, Scan, treeType],
        TreeOps USING [GetHash, GetNode, GetTag, ListHead, ListTail, OpName, PopTree, PushTree, PushNode, PushSe, ScanList, SetAttr, ToLoc, 
        UpdateList],
        Types USING [Equivalent];

    Pass3V: PROGRAM
        IMPORTS A3, Copier, Log, P3, P3S, SymbolOps, TreeOps,  Types, dataPtr: ComData
        EXPORTS P3 = { 
        OPEN SymbolOps, A3, P3, Symbols, TreeOps;

    <<tables defining the current symbol table>>

        tb: Tree.Base;        -- tree base
        seb: Symbols.Base;        -- se table
        ctxb: Symbols.Base;        -- context table

        VRNotify: PUBLIC Alloc.Notifier = {
            <<called whenever the main symbol table is repacked>>
            tb _ base[Tree.treeType];  seb _ base[seType];  ctxb _ base[ctxType]};


    <<finding union and discriminated types>>
    <<N. B. the following two entries cannot assume well-formed type links>>

        VariantUnionType: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {
            rType: CSEIndex = ConsType[type];
            RETURN [WITH seb[rType] SELECT FROM
                record =>
                    IF hints.variant
                        THEN ConsType[TypeForSe[UnionField[LOOPHOLE[rType, RecordSEIndex]]]]
                        ELSE typeANY,
                ENDCASE => typeANY]};


        SelectVariantType: PUBLIC PROC [type: Type, tag: HTIndex] RETURNS [sei: ISEIndex] = {
            matched: BOOL;
            vType: CSEIndex = VariantUnionType[type];
            WITH seb[vType] SELECT FROM
                union => [matched, sei] _ SearchCtxList[tag, caseCtx];
                ENDCASE => matched _ FALSE;
            IF ~matched THEN sei _ ISENull;
            RETURN};


        SequenceField: PUBLIC PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {
            sei: ISEIndex = UnionField[rSei];
            RETURN [IF TypeForm[seb[sei].idType] = sequence THEN sei ELSE ISENull]};


        <<auxiliary procedures (for avoiding UnderType when potentially unsafe)>>

            UnionField: PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {
                sei, root, next: ISEIndex;
                ctx: CTXIndex = seb[rSei].fieldCtx;
                IF ctxb[ctx].ctxType = simple THEN
                    FOR sei _ ctxb[ctx].seList, next UNTIL sei = ISENull DO
                        next _ NextSe[sei];
                        IF next = ISENull THEN RETURN [sei];
                        ENDLOOP
                ELSE {    -- defined in another module, UnderType is safe
                    repeated: BOOL _ FALSE;
                    DO
                        sei _ root _ ctxb[ctx].seList;
                        DO
                            IF sei = ISENull THEN EXIT;
                            SELECT TypeForm[seb[sei].idType] FROM
                                union, sequence => RETURN [sei];
                                ENDCASE;
                            IF (sei _ NextSe[sei]) = root THEN EXIT;
                            ENDLOOP;
                        IF repeated THEN EXIT;
                        Copier.CopyUnion[seb[rSei].fieldCtx];  repeated _ TRUE;
                        ENDLOOP};
                RETURN [dataPtr.seAnon]};

            ResolveId: PROC [hti: HTIndex, ctx: CTXIndex] RETURNS [sei: ISEIndex] = {
                currentCtx: CTXIndex = TopCtx[];
                IF ctx = currentCtx THEN sei _ FindSe[hti].symbol
                ELSE {PopCtx[]; sei _ ResolveId[hti, ctx]; PushCtx[currentCtx]};
                RETURN};

            TypeForSe: PROC [sei: ISEIndex] RETURNS [type: Type] = INLINE {
                node: Tree.Index;
                t: Tree.Link;
                IF seb[sei].mark3 THEN RETURN [seb[sei].idType];
                node _ DecodeTreeIndex[seb[sei].idValue];
                IF tb[node].name # decl THEN RETURN [typeTYPE];
                t _ tb[node].son[2];
                type _ WITH t SELECT GetTag[t] FROM
                    hash => ResolveId[index, seb[sei].idCtx],
                    symbol => index,
                    subtree => ToType[tb[index].info],
                    ENDCASE => typeANY;
                RETURN};

            ConsType: PROC [type: Type] RETURNS [CSEIndex] = {
                WITH se: seb[type] SELECT FROM
                    id =>
                        IF se.mark3 THEN
                            RETURN [
                                IF se.idType # typeTYPE THEN typeANY 
                                ELSE ConsType[DecodeType[se.idInfo]]]
                        ELSE {
                            node: Tree.Index = DecodeTreeIndex[se.idValue];
                            RETURN [IF tb[node].name # typedecl
                                THEN typeANY
                                ELSE ConsType[ResolveTreeType[tb[node].son[2], se.idCtx]]]};
                    cons => RETURN [LOOPHOLE[type, CSEIndex]];
                    ENDCASE => ERROR};

            ResolveTreeType: PROC [t: Tree.Link, ctx: CTXIndex] RETURNS [type: Type] = {
                WITH t SELECT GetTag[t] FROM
                    hash => type _ ResolveId[index, ctx];
                    symbol => type _ index;
                    subtree => {
                        node: Tree.Index = index;
                        type _ IF ToType[tb[node].info] # nullType
                            THEN ToType[tb[node].info]
                            ELSE
                                SELECT tb[node].name FROM
                                    discrimTC =>
                                        WITH tb[node].son[2] SELECT GetTag[tb[node].son[2]] FROM
                                            hash => SelectVariantType[ResolveTreeType[tb[node].son[1], ctx], index],
                                            ENDCASE => ERROR,
                                    ENDCASE => ERROR};
                    ENDCASE => ERROR;
                RETURN};


        <<type discrimination>>

            DiscriminatedType: PUBLIC PROC [baseType: CSEIndex, t: Tree.Link]
                RETURNS [type: CSEIndex] = {
                IF t = Tree.Null THEN type _ P3S.implicitRecord
                ELSE
                    WITH t SELECT GetTag[t] FROM
                        subtree => {
                            node: Tree.Index = index;
                            temp: Tree.Link;
                            SELECT tb[node].name FROM
                                union => {
                                    type _ WITH tb[node].son[1] SELECT GetTag[tb[node].son[1]] FROM 
                                        symbol => UnderType[index], 
                                        ENDCASE => ERROR;
                                    WITH seb[type] SELECT FROM
                                        record =>
                                            IF hints.variant AND tb[node].son[2] # Tree.Null
                                                AND (temp_ListTail[tb[node].son[2]]) # Tree.Null THEN
                                                    type _ DiscriminatedType[type, temp];
                                        ENDCASE => ERROR};
                                dollar => type _ UnderType[OperandType[tb[node].son[1]]];
                                dot => {
                                    subType: CSEIndex = NormalType[OperandType[tb[node].son[1]]];
                                    type _ WITH seb[subType] SELECT FROM ref => UnderType[refType], ENDCASE => ERROR};
                                assignx => type _ DiscriminatedType[baseType, tb[node].son[2]];
                                ENDCASE => type _ baseType};
                        ENDCASE => type _ baseType;
                RETURN};


        <<discrimination operations>>

            Narrowing: PUBLIC PROC [type, target: Type] RETURNS [op: NarrowOp_[]] = {
                typeL: CSEIndex _ UnderType[target];
                typeR: CSEIndex _ UnderType[type];
                nextL, nextR: Type;
                IF ~Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]] THEN
                    DO
                        WITH tR: seb[typeR] SELECT FROM
                            any => {
                                IF ~op.indirect THEN op.error _ TRUE;
                                WITH tL: seb[typeL] SELECT FROM
                                    any => EXIT;
                                    opaque => {
                                        op.rtTest _ TRUE;
                                        IF typeL # dataPtr.typeAtomRecord THEN op.unImpl _ TRUE;
                                        EXIT};
                                    ENDCASE => {
                                        op.rtTest _ TRUE;
                                        IF ~Discriminated[typeL] THEN EXIT;
                                        nextL _ typeL;  nextR _ TypeRoot[typeL]}};
                            record =>
                                WITH tL: seb[typeL] SELECT FROM
                                    record => {
                                        IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]
                                            THEN EXIT;
                                        WITH vL: tL SELECT FROM
                                            linked => {
                                                uType: CSEIndex = VariantUnionType[vL.linkType];
                                                WITH u: seb[uType] SELECT FROM
                                                    union => IF u.controlled THEN op.tagTest _ TRUE ELSE op.computed _ TRUE;
                                                    ENDCASE => op.error _ TRUE;
                                                nextL _ vL.linkType;  nextR _ typeR};
                                            ENDCASE => op.error _ TRUE};
                                    ENDCASE => op.error _ TRUE;
                            ref =>
                                WITH tL: seb[typeL] SELECT FROM
                                    ref => {
                                        IF op.indirect OR (tL.counted # tR.counted) OR (tR.readOnly AND ~tL.readOnly)
                                            THEN op.error _ TRUE;
                                        op.indirect _ TRUE;
                                        nextL _ tL.refType;  nextR _ tR.refType};
                                    ENDCASE => op.error _ TRUE;
                            transfer =>
                                WITH tL: seb[typeL] SELECT FROM
                                    transfer => {
                                        IF op.indirect OR tL.mode # tR.mode OR tL.safe # tR.safe THEN
                                            op.error _ TRUE;
                                        SELECT tL.mode FROM
                                            proc, signal, error => NULL;
                                            ENDCASE => op.error _ TRUE;
                                        IF TypeForm[tL.typeIn] = any OR TypeForm[tL.typeOut] = any THEN
                                            op.error _ TRUE;    -- for now
                                        IF TypeForm[tR.typeIn] = any THEN
                                            op.rtTest _ TRUE
                                        ELSE IF ~Types.Equivalent[
                                            [dataPtr.ownSymbols, tL.typeIn],
                                            [dataPtr.ownSymbols, tR.typeIn]] THEN op.error _ TRUE;
                                        IF TypeForm[tR.typeOut] = any THEN
                                            op.rtTest _ TRUE
                                        ELSE IF ~Types.Equivalent[
                                            [dataPtr.ownSymbols, tL.typeOut],
                                            [dataPtr.ownSymbols, tR.typeOut]] THEN op.error _ TRUE;
                                        EXIT};
                                    ENDCASE => op.error _ TRUE;
                            long =>
                                WITH tL: seb[typeL] SELECT FROM
                                    long => {nextL _ tL.rangeType; nextR _ tR.rangeType};
                                    ENDCASE => op.error _ TRUE;
                            ENDCASE => {
                                IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]
                                    THEN EXIT;
                                op.error _ TRUE};
                        IF op.error THEN EXIT;
                        typeL _ UnderType[nextL];  typeR _ UnderType[nextR];
                        ENDLOOP;
                RETURN};

            Discriminated: PROC [type: CSEIndex] RETURNS [BOOL] = INLINE {
                RETURN [TypeLink[type] # nullType]};  -- check that at tag exists?

        <<binding of variant records>>

            Discrimination: PUBLIC PROC [node: Tree.Index, selection: Tree.Map] = {
                OPEN tb[node];
                copy: BOOL = (OpName[ListHead[son[3]]] = ditem);
                type, subType: CSEIndex;
                vCtx: CTXIndex;
                base, discBase: Tree.Link;
                attr: Attr;
                entryNP: NPUse _ none;
                unreachable: BOOL _ FALSE;

                BindError: PROC = {
                    IF son[2] # Tree.Null THEN son[2] _ VoidExp[son[2]]; vCtx _ CTXNull};

                PushCommonCtx: PROC = {
                    SELECT TRUE FROM
                        copy OR (seb[type].typeTag # record) => PushCtx[CTXNull];
                        (baseId = HTNull) => PushRecordCtx[LOOPHOLE[type], base, indirect];
                        ENDCASE => PushHtCtx[baseId, base, indirect]};

                BindItem: Tree.Scan = {
                    subNode: Tree.Index = GetNode[t];
                    saveIndex: SourceMap.Loc = dataPtr.textIndex;
                    IF tb[subNode].name = ditem THEN {
                        declNode: Tree.Index = GetNode[tb[subNode].son[1]];
                        declType: CSEIndex;
                        Item: Tree.Map = {phraseNP _ entryNP; v _ selection[t]};
                        op: NarrowOp;
                        dataPtr.textIndex _ ToLoc[tb[declNode].info];
                        IF unreachable THEN {Log.Warning[unreachable]; unreachable _ FALSE};
                        Scope[subNode, Item];
                        declType _ UnderType[TypeForTree[tb[declNode].son[2]]];
                        op _ Narrowing[subType, declType];
                        SELECT TRUE FROM
                            ~copy => Log.Error[discrimForm];
                            op.error => Log.ErrorSei[typeClash, FirstId[declNode]];
                            op.computed => Log.ErrorTree[missingBinding, base];
                            op.unImpl => Log.Warning[opaqueTest];
                            ~(op.rtTest OR op.tagTest) => unreachable _ TRUE;
                            ENDCASE;
                        tb[subNode].attr1 _ op.indirect;
                        IF (tb[subNode].attr2 _ op.rtTest) THEN EnterType[MarkedType[declType]];
                        tb[subNode].attr3 _ op.tagTest}
                    ELSE {
                        vType: CSEIndex;
                        dataPtr.textIndex _ ToLoc[tb[subNode].info];
                        IF copy THEN {Log.Error[discrimForm]; attr3 _ FALSE};
                        [tb[subNode].son[1], vType] _ BindTest[tb[subNode].son[1], vCtx];
                        IF vType = typeANY THEN PushCommonCtx[]
                        ELSE {
                            WITH discBase SELECT GetTag[discBase] FROM
                                subtree => tb[index].info _ FromType[vType];
                                ENDCASE => ERROR;
                            IF baseId = HTNull THEN PushRecordCtx[LOOPHOLE[vType], discBase, FALSE]
                            ELSE PushHtCtx[baseId, discBase, FALSE]};
                        phraseNP _ entryNP;
                        tb[subNode].son[2] _ selection[tb[subNode].son[2]];
                        PopCtx[];
                        tb[subNode].attr1 _ TRUE};
                    dataPtr.textIndex _ saveIndex};

                saveImplicit: P3S.ImplicitInfo = P3S.implicit;
                idNode: Tree.Index = GetNode[son[1]];
                baseId: HTIndex = GetHash[tb[idNode].son[1]];
                indirect: BOOL;
                SealRefStack[];
                base _ tb[idNode].son[2] _ Exp[tb[idNode].son[2], typeANY];
                type _ UType[];  attr _ RAttr[];  RPop[];
                UnsealRefStack[];
                subType _ UnderType[CanonicalType[type]];
                IF subType # type THEN tb[idNode].son[2] _ ForceType[tb[idNode].son[2], subType];
                type _ NormalType[subType];
                P3S.implicit _ [tree: base, type: subType, attr: attr];
                IF (attr3 _ copy) THEN {
                    P3S.implicit.attr.noAssign _ P3S.implicit.attr.noXfer _ TRUE;
                    SELECT TypeForm[type] FROM
                        ref => {
                            attr2 _ (TypeForm[ReferentType[type]] = any);
                            indirect _ TRUE};
                        transfer => {attr2 _ TRUE; indirect _ FALSE};
                        ENDCASE => {attr2 _ FALSE; indirect _ FALSE};
                    IF baseId # HTNull THEN Log.Error[discrimForm]}
                ELSE {
                    long: BOOL;
                    WITH t: seb[type] SELECT FROM
                        ref => {
                            indirect _ TRUE;
                            [base, type] _ OpenPointer[base, subType];
                            subType _ UnderType[OperandType[base]];
                            long _ seb[subType].typeTag = long};
                        ENDCASE => {indirect _ FALSE; long _ LongPath[base]};
                    IF P3S.safety = checked AND RCType[type] # none THEN
                        Log.ErrorTree[unsafeSelection, base];
                    WITH seb[type] SELECT FROM
                        record => {
                            tb[idNode].son[2] _ base _ BaseTree[base, subType];
                            IF hints.variant THEN {
                                uType: CSEIndex = VariantUnionType[type];
                                WITH u: seb[uType] SELECT FROM
                                    union => {
                                        tagType: Type = seb[u.tagSei].idType;
                                        vCtx _ u.caseCtx;
                                        IF son[2] = Tree.Null THEN {
                                            IF ~u.controlled THEN Log.ErrorTree[missingBinding, base];
                                            [] _ UpdateTreeAttr[base];  entryNP _ phraseNP;
                                            PushTree[base];  PushSe[u.tagSei];
                                            PushNode[IF indirect THEN dot ELSE dollar, 2];
                                            SetType[tagType]; SetAttr[2, long]; son[2] _ PopTree[]}
                                        ELSE {
                                            IF u.controlled THEN Log.ErrorTree[spuriousBinding, son[2]];
                                            PushCommonCtx[];
                                            son[2] _ Rhs[son[2], TargetType[tagType]];
                                            entryNP _ phraseNP;  RPop[];
                                            PopCtx[]}};
                                    ENDCASE => {Log.Error[noAccess]; BindError[]}}
                            ELSE {Log.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[]};
                            PushTree[base];
                            IF indirect THEN {PushNode[uparrow, 1]; SetAttr[2, long]}
                            ELSE PushNode[cast, 1];
                            discBase _ PopTree[]};
                        ENDCASE => {
                            Log.ErrorTree[noVariants, tb[idNode].son[2]];  BindError[];
                            discBase _ Tree.Null}};
                attr1 _ indirect;
                ScanList[son[3], BindItem];
                PushCommonCtx[]; phraseNP _ entryNP; son[4] _ selection[son[4]]; PopCtx[];
                RPush[CSENull, attr];
                P3S.implicit _ saveImplicit};


            BindTest: PROC [t: Tree.Link, vCtx: CTXIndex]
                RETURNS [val: Tree.Link, vType: CSEIndex] = {
                mixed: BOOL _ FALSE;

                TestItem: Tree.Map = {
                    WITH t SELECT GetTag[t] FROM
                        subtree => {
                            subNode: Tree.Index = index;
                            SELECT tb[subNode].name FROM
                                relE =>
                                    WITH tb[subNode].son[2] SELECT GetTag[tb[subNode].son[2]] FROM
                                        hash => {
                                            iType: ISEIndex;
                                            uType: CSEIndex;
                                            found: BOOL;
                                            [found, iType] _ SearchCtxList[index, vCtx];
                                            IF found THEN {
                                                uType _ UnderType[iType];
                                                tb[subNode].son[2] _ [symbol[index: iType]];
                                                SELECT vType FROM
                                                    uType => NULL;
                                                    typeANY => vType _ uType;
                                                    ENDCASE => mixed _ TRUE}
                                            ELSE IF vCtx # CTXNull THEN Log.ErrorHti[unknownVariant, index];
                                            tb[subNode].info _ FromType[dataPtr.idBOOL];
                                            tb[subNode].attr1 _ tb[subNode].attr2 _ FALSE;
                                            v _ t};
                                        ENDCASE => {
                                            v _ Rhs[t, dataPtr.idBOOL];  RPop[];
                                            Log.ErrorTree[nonVariantLabel, t]};
                                ENDCASE => {
                                    v _ Rhs[t, dataPtr.idBOOL];  RPop[];
                                    Log.ErrorTree[nonVariantLabel, t]}};
                        ENDCASE => ERROR;
                    RETURN};

                vType _ typeANY;  val _ UpdateList[t, TestItem];
                IF mixed THEN vType _ typeANY;
                RETURN};

            }.

