
    <<RTTDefaultImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<created by Paul Rovner>>
        <<Russ Atkinson, February 11, 1985 8:17:49 pm PST>>

        DIRECTORY
            AMBridge USING [IsRemote, SetTVFromLI, TVForATOM, TVForPointerReferent, TVToLI, WordSequence, WordSequenceRecord],
            AMTypes USING [Assign, Class, Error, GroundStar, IndexToTV, IndexToType, NComponents, New, Size, TVType, TypeClass, UnderClass, 
            UnderType, Index, TV, Type],
            BrandXSymbolDefs USING [ExtensionClass, InnerCallableBodyIndex, SymbolTableBase, TreeIndex, TreeLink],
            BrandYSymbolDefs USING [ExtensionClass, InnerCallableBodyIndex, SymbolTableBase, TreeIndex, TreeLink],
            PrincOps USING [ControlLink, GFTIndex, GlobalFrameHandle, ProcDesc],
            RTCommon USING [ShortenLongPointer],
            RTSymbolDefs USING [ExtensionClass, SymbolConstructorIndex, SymbolIdIndex, SymbolIndex, SymbolTableBase, TreeLink],
            RTSymbolOps USING[AcquireAtom, AcquireType, EnumerateCtxIseis, ISEExtended, ISEFindExtension, ISEInfo, ISEType, IsTypeSEI, 
            SETagIDP, SETypeXferMode, SEUnderType, ISEConstant],
            RTSymbols USING [GetTypeSymbols, ReleaseSTB],
            RTTCache USING [FillRefEntry, GetRef, LookupRef, RefEntry],
            RTTypesPrivate USING [RecordComponentISEI, TypedVariableRec],
            RTTypesRemotePrivate USING [GetRemoteGFHeader];
RTTDefaultImpl: PROGRAM
    IMPORTS AMBridge, AMTypes, RTCommon, RTSymbolOps, RTSymbols, RTTCache, RTTypesPrivate, RTTypesRemotePrivate
    EXPORTS AMTypes, RTTypesPrivate
    = BEGIN OPEN AMBridge, AMTypes, bx: BrandXSymbolDefs, by: BrandYSymbolDefs, RTSymbolDefs, RTSymbolOps, RTSymbols, 
    RTTypesRemotePrivate;

    CARD: TYPE = LONG CARDINAL;

    DefaultInitialValue: PUBLIC SAFE PROC [type: Type] RETURNS [tv: TV] = TRUSTED {
        <<Raise notImplemented if can't hack it. Return NIL if there is no DefaultInitialValue>>
        uType: Type _ UnderType[type];
        c: Class _ TypeClass[uType];
        typeSTB: SymbolTableBase;
        typeSEI: SymbolIndex;
        entry: RTTCache.RefEntry;
        valid: BOOL;

        Nature: TYPE = {basic, constructed, nil};
        n: Nature _ SELECT c FROM
            record, structure => constructed,
            unspecified, enumerated, subrange, ref, list, atom, rope, pointer, longPointer, nil, cardinal, integer, character, longInteger, 
            longCardinal, real, countedZone, uncountedZone =>
                IF TypeClass[type] = definition THEN basic ELSE nil,
            ENDCASE => ERROR Error[reason: notImplemented, msg: "DefaultInitialValue for this type"];

        IF n = nil THEN RETURN[NIL];
        entry _ RTTCache.LookupRef[type, DefaultInitialValue];
        [tv, valid] _ RTTCache.GetRef[entry];
        IF valid THEN RETURN [tv];

        [typeSTB, typeSEI] _ GetTypeSymbols[type];

        {
            ENABLE UNWIND => ReleaseSTB[typeSTB];
            tv _ New[uType];
            SELECT n FROM
                constructed => {
                    index: Index _ 0;
                    iTV, defTV: TV;
                    csei: SymbolConstructorIndex = SEUnderType[typeSTB, typeSEI];

                    EachIndex: PROC [stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS [stop: BOOL _ FALSE] = {
                        index _ index + 1;
                        iTV _ IndexToTV[tv, index];
                        IF ISEExtended[stb, isei] THEN {
                            ttype: ExtensionClass;
                            tree: TreeLink;
                            [ttype, tree] _ ISEFindExtension[stb, isei];
                            IF (WITH ttype SELECT FROM
                                t: ExtensionClass.x => t.e = default,
                                t: ExtensionClass.y => t.e = default,
                                ENDCASE => ERROR) THEN {
                                IF SetTVFromLink[iTV, stb, tree] THEN RETURN;
                                ERROR Error[reason: notImplemented, msg: "DefaultInitialValue for this type"];
                                };
                            };
                        <<If no default is explicitly given for this field, perhaps its type has a default value.>>
                        defTV _ DefaultInitialValue[TypeFromISE[stb, isei]];
                        IF defTV = NIL THEN {
                            <<stop enumeration, return NIL>>
                            tv _ NIL;
                            RETURN[TRUE]};
                        Assign[iTV, defTV]};

                    <<start constructed case here>>
                    WITH typeSTB SELECT FROM
                        t: SymbolTableBase.x =>
                            WITH ser: t.e.seb[NARROW[csei, SymbolConstructorIndex.x].e] SELECT FROM
                                record => [] _ EnumerateCtxIseis[typeSTB, [x[ser.fieldCtx]], EachIndex];
                                definition => GO TO notImplemented;
                                ENDCASE=> ERROR;
                        t: SymbolTableBase.y =>
                            WITH ser: t.e.seb[NARROW[csei, SymbolConstructorIndex.y].e] SELECT FROM
                                record => [] _ EnumerateCtxIseis[typeSTB, [y[ser.fieldCtx]], EachIndex];
                                definition => GO TO notImplemented;
                                ENDCASE=> ERROR;
                        ENDCASE => ERROR;
                    };

                basic => {
                    isei: SymbolIdIndex _ LOOPHOLE[typeSEI, SymbolIdIndex];
                    <<basic attribute guarantees that type is definition>>
                    ttype: ExtensionClass;
                    tree: TreeLink;
                    DO sei: SymbolIndex = ISEInfo[typeSTB, isei];
                        IF ISEExtended[typeSTB, isei] THEN EXIT; -- found default
                        IF NOT SETagIDP[typeSTB, sei] THEN GOTO noDefault;
                        isei _ LOOPHOLE[sei, SymbolIdIndex];
                        ENDLOOP;
                    [ttype, tree] _ ISEFindExtension[typeSTB, isei];
                    IF (WITH ttype SELECT FROM
                        t: ExtensionClass.x => t.e # default,
                        t: ExtensionClass.y => t.e # default,
                        ENDCASE => ERROR)
                        THEN GO TO noDefault;
                    IF ~SetTVFromLink[tv, typeSTB, tree] THEN GO TO notImplemented;
                    EXITS noDefault => tv _ NIL};
                ENDCASE => ERROR;
            EXITS notImplemented => {
                ReleaseSTB[typeSTB];
                Error[reason: notImplemented, msg: "DefaultInitialValue in this case"];
                };
            };

        ReleaseSTB[typeSTB];
        [] _ RTTCache.FillRefEntry[entry, tv];
        RETURN[tv];
        };

    IndexToDefaultInitialValue: PUBLIC SAFE PROC [type: Type, index: Index] RETURNS [tv: TV _ NIL] = TRUSTED {
        <<Raise notImplemented if can't hack it. Return NIL if there is no DefaultInitialValue>>
        <<(does not inherit from the type)>>
        GetDefaultFieldValue: PROC [stb: SymbolTableBase, isei: SymbolIdIndex] = {
            SELECT TRUE FROM
                ISEExtended[stb, isei] => {
                    ttype: ExtensionClass;
                    tree: TreeLink;
                    tv _ New[IndexToType[type, index]];
                    [ttype, tree] _ ISEFindExtension[stb, isei];
                    IF (WITH ttype SELECT FROM
                    t: ExtensionClass.x => t.e = none OR t.e = form,
                    t: ExtensionClass.y => t.e = none OR t.e = form,
                    ENDCASE => ERROR)
                    OR NOT SetTVFromLink[tv, stb, tree] THEN
                        ERROR Error[reason: notImplemented, msg: "IndexToDefaultInitialValue in this case"];
                    };
                ISEConstant[stb, isei] => {
                    ENABLE Error => IF reason = notImplemented THEN GOTO nimp;
                    sei: SymbolIndex = ISEType[stb, isei];
                    cType: Type _ AcquireType[stb, sei];
                    tv _ NEW[RTTypesPrivate.TypedVariableRec _ [referentType: [cType], head: [constant[]], status: const, field: constant[value: 
                    GetIdConstantValue[NIL, stb, isei]] ]];
                    EXITS nimp => NULL;
                    };
                ENDCASE => {
                    };
            };
        RTTypesPrivate.RecordComponentISEI[type, index, GetDefaultFieldValue];
        };

    SetTVFromLink: PROC [tv: TV, stb: SymbolTableBase, tree: TreeLink] RETURNS [BOOL] =  {
        <<this guy returns FALSE if it can't figure out the value of the tree,>>
        <<otherwise gets the value and assigns it to tv.>>
        WITH stb SELECT FROM
            t: SymbolTableBase.x =>
                RETURN[SetTVFromLinkX[tv, t.e, NARROW[tree, TreeLink.x].e]];
            t: SymbolTableBase.y =>
                RETURN[SetTVFromLinkY[tv, t.e, NARROW[tree, TreeLink.y].e]];
            ENDCASE => ERROR};

        SetTVFromLinkX: PROC [tv: TV, stb: bx.SymbolTableBase, tree: bx.TreeLink] RETURNS [success: BOOL _ TRUE] =  {
            type: Type = TVType[tv];
            ground: Type = GroundStar[type];
            class: Class = TypeClass[ground];
            vType: Type _ ground; -- type of value defaults to ground type of target
            DO
                WITH oak: tree SELECT FROM
                    literal => {
                        WITH wordLit: oak.index SELECT FROM
                            string => RETURN[FALSE]; -- Mesa can't do it
                            word => {
                                ptr: LONG POINTER _ NIL;
                                WITH val: stb.ltb[wordLit.lti] SELECT FROM
                                    short => {
                                        ptr _ @val.value;
                                        SELECT UnderClass[vType] FROM
                                            longInteger => vType _ CODE[INTEGER];
                                            longCardinal => vType _ CODE[CARDINAL];
                                            ENDCASE;
                                        };
                                    long => ptr _ @val.value;
                                    ENDCASE => ERROR;
                                Assign[
                                    lhs: tv,
                                    rhs: TVForPointerReferent[ptr: ptr, type: vType, status: readOnly]];
                                RETURN[TRUE];
                                };
                            ENDCASE => ERROR};
                    symbol => {
                        OPEN node: stb.seb[oak.index];
                        IF ~node.constant THEN RETURN[FALSE];
                        vType _ AcquireType[[x[stb]], [x[node.idType]]];
                        IF node.extended THEN {
                            ttype: bx.ExtensionClass;
                            [ttype, tree] _ stb.FindExtension[oak.index];
                            IF ttype # value THEN ERROR; -- I (DCS) don't believe any of this.
                            LOOP};
                        Assign[
                            lhs: tv,
                            rhs: TVForPointerReferent[ptr: @node.idValue, type: vType, status: readOnly]];
                        RETURN[TRUE]};
                    subtree => {
                        OPEN node: stb.tb[oak.index];
                        SELECT node.name FROM
                            nil => {
                                Assign[tv, NIL];
                                RETURN[TRUE]};
                            void => RETURN[FALSE];
                            lengthen => {
                                IF node.attr1  -- ptr to lengthen. forget it.
                                    THEN RETURN[FALSE];
                                tree _ node.son[1];
                                LOOP};
                            shorten, clit, mwconst => {
                                tree _ node.son[1];  -- the one son of an mwconst is guaranteed to be a literal
                                LOOP};
                            uminus => {
                                IF ~SetTVFromLinkX[tv: tv, stb: stb, tree: node.son[1]]
                                    THEN RETURN[FALSE];
                                SetTVFromLI[tv, -TVToLI[tv]];
                                RETURN[TRUE]};
                            construct => {
                                uT: Type = UnderType[type];
                                index: bx.TreeIndex _ oak.index;

                                IF stb.tb[index].nSons # 2 THEN ERROR;

                                WITH link: stb.tb[index].son[2] SELECT FROM
                                    subtree => index _ link.index;
                                    ENDCASE => ERROR;

                                SELECT TypeClass[uT] FROM
                                    record, structure => NULL;
                                    ENDCASE => ERROR;

                                IF stb.tb[index].name # list OR NComponents[uT] # stb.tb[index].nSons
                                    THEN ERROR;

                                FOR i: NAT IN [1..stb.tb[index].nSons]
                                    DO stv: TV _ IndexToTV[tv, i];
                                        IF NOT SetTVFromLinkX[stv, stb, stb.tb[index].son[i]] THEN
                                            RETURN[FALSE];
                                    ENDLOOP;
                                RETURN[TRUE]};
                            atom => {
                                atom: ATOM _ AcquireAtom[[x[stb]],
                                    [x[NARROW[node.son[1], bx.TreeLink.hash].index]]];
                                Assign[tv, TVForATOM[atom]];
                                RETURN[TRUE]};
                            ENDCASE => RETURN[FALSE]};
                        ENDCASE => ERROR;
                ENDLOOP;
            };  -- end of SetTVFromLinkX

        SetTVFromLinkY: PROC [tv: TV, stb: by.SymbolTableBase, tree: by.TreeLink] RETURNS [success: BOOL _ TRUE] =  {
            type: Type = TVType[tv];
            ground: Type = GroundStar[type];
            class: Class = TypeClass[ground];
            vType: Type _ ground; -- type of value defaults to ground type of target
            DO
                WITH oak: tree SELECT FROM
                    literal => {
                        WITH wordLit: oak.index SELECT FROM
                            string => RETURN[FALSE]; -- Mesa can't do it
                            word => {
                                ptr: LONG POINTER _ NIL;
                                WITH val: stb.ltb[wordLit.lti] SELECT FROM
                                    short => {
                                        ptr _ @val.value;
                                        SELECT UnderClass[vType] FROM
                                            longInteger => vType _ CODE[INTEGER];
                                            longCardinal => vType _ CODE[CARDINAL];
                                            ENDCASE;
                                        };
                                    long => ptr _ @val.value;
                                    ENDCASE => ERROR;
                                Assign[
                                    lhs: tv,
                                    rhs: TVForPointerReferent[ptr: ptr, type: vType, status: readOnly]];
                                RETURN[TRUE];
                                };
                            ENDCASE => ERROR};
                    symbol => {
                        OPEN node: stb.seb[oak.index];
                        IF ~node.constant THEN RETURN[FALSE];
                        vType _ AcquireType[[y[stb]], [y[node.idType]]];
                        IF node.extended THEN {
                            ttype: by.ExtensionClass;
                            [ttype, tree] _ stb.FindExtension[oak.index];
                            IF ttype # value THEN ERROR; -- I (DCS) don't believe any of this.
                            LOOP};
                        Assign[
                            lhs: tv,
                            rhs: TVForPointerReferent[ptr: @node.idValue, type: vType, status: readOnly]];
                        RETURN[TRUE]};
                    subtree => {
                        OPEN node: stb.tb[oak.index];
                        SELECT node.name FROM
                            nil => {
                                Assign[tv, NIL];
                                RETURN[TRUE]};
                            void => RETURN[FALSE];
                            lengthen, shorten => {
                                IF node.attr1  -- ptr to lengthen. forget it.
                                    THEN RETURN[FALSE];
                                tree _ node.son[1];
                                LOOP};
                            shorten, clit, mwconst => {
                                tree _ node.son[1];  -- the one son of an mwconst is guaranteed to be a literal
                                LOOP};
                            uminus => {
                                IF ~SetTVFromLinkY[tv: tv, stb: stb, tree: node.son[1]] THEN RETURN[FALSE];
                                SetTVFromLI[tv, -TVToLI[tv]];
                                RETURN[TRUE]};
                            construct => {
                                uT: Type = UnderType[type];
                                index: by.TreeIndex _ oak.index;

                                IF stb.tb[index].nSons # 2 THEN ERROR;

                                WITH link: stb.tb[index].son[2] SELECT FROM
                                    subtree => index _ link.index;
                                    ENDCASE => ERROR;

                                SELECT TypeClass[uT] FROM
                                    record, structure => NULL;
                                    ENDCASE => ERROR;

                                IF stb.tb[index].name # list OR NComponents[uT] # stb.tb[index].nSons
                                    THEN ERROR;

                                FOR i: INTEGER IN [1..stb.tb[index].nSons]
                                    DO stv: TV _ IndexToTV[tv, i];
                                        IF NOT SetTVFromLinkY[stv, stb, stb.tb[index].son[i]] THEN
                                            RETURN[FALSE];
                                    ENDLOOP;
                                RETURN[TRUE]};
                            atom => {
                                atom: ATOM _ AcquireAtom[[y[stb]],
                                    [y[NARROW[node.son[1], by.TreeLink.hash].index]]];
                                Assign[tv, TVForATOM[atom]];
                                RETURN[TRUE]};
                            ENDCASE => RETURN[FALSE]};
                        ENDCASE => ERROR;
                ENDLOOP;
            };

    TypeFromISE: PROC [stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS [Type] = {
        RETURN [RTSymbolOps.AcquireType[stb, RTSymbolOps.ISEType[stb, isei]]];
        };

    GetIdConstantValue: PUBLIC PROC [tv: TV, stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS [ws: WordSequence] = {
        <<tv arg is for signal, error and proc constants, to determine the gfi or fh bias>>
        <<raises notImplemented, typeFault>>
        IF IsTypeSEI[ISEType[stb, isei]] THEN {
            ws _ NEW[WordSequenceRecord[1]];
            ws[0] _ LOOPHOLE[AcquireType[stb, LOOPHOLE[isei, SymbolIndex]], WORD];
            RETURN};
        SELECT SETypeXferMode[stb, ISEType[stb, isei]] FROM
            none => {
                IF ISEExtended[stb, isei]
                    THEN {
                        newTV: TV;
                        tree: TreeLink;
                        type: Type = AcquireType[stb, ISEType[stb, isei]];
                        ws _ NEW[WordSequenceRecord[Size[type]]];
                        newTV _ TVForPointerReferent[ptr: @ws[0], type: type];
                        [, tree] _ ISEFindExtension[stb, isei];
                        IF NOT SetTVFromLink[newTV, stb, tree] THEN
                            ERROR Error[reason: notImplemented, msg: "extended constants"]}
                    ELSE {
                        word: WORD _ LOOPHOLE[(WITH stb SELECT FROM
                            t: SymbolTableBase.x => t.e.seb[NARROW[isei, SymbolIdIndex.x].e].idValue,
                            t: SymbolTableBase.y => t.e.seb[NARROW[isei, SymbolIdIndex.y].e].idValue,
                            ENDCASE => ERROR)];
                        ws _ NEW[WordSequenceRecord[1]];
                        ws[0] _ word;
                        };
                    RETURN};
            signalOrError, proc => {
                popd: PrincOps.ProcDesc;
                pd: PrincOps.ProcDesc;
                gfiBase: PrincOps.GFTIndex;

                IF tv = NIL THEN RETURN;
                IF ISEExtended[stb, isei] THEN
                    ERROR Error[reason: notImplemented, msg: "extended transfer constants"];
                ws _ NEW[WordSequenceRecord[1]];
                IF IsRemote[tv]
                    THEN {
                        WITH tv SELECT FROM
                            tvr: REF RTTypesPrivate.TypedVariableRec => {
                                WITH h: tvr.head SELECT FROM
                                    remoteGFH =>
                                        gfiBase _ GetRemoteGFHeader[h.remoteGlobalFrameHandle].gfi;
                                    remoteFH =>  -- nested proc
                                        WITH stb SELECT FROM
                                            t: SymbolTableBase.x => {
                                                bti: bx.InnerCallableBodyIndex = LOOPHOLE[
                                                    t.e.seb[NARROW[isei, SymbolIdIndex.x].e].idInfo, bx.InnerCallableBodyIndex];
                                                ws[0] _ LOOPHOLE[
                                                    h.remoteFrameHandle.fh+t.e.bb[bti].frameOffset,
                                                    WORD];
                                                RETURN};
                                            t: SymbolTableBase.y => {
                                                bti: by.InnerCallableBodyIndex = LOOPHOLE[
                                                    t.e.seb[NARROW[isei, SymbolIdIndex.y].e].idInfo, by.InnerCallableBodyIndex];
                                                ws[0] _ LOOPHOLE[
                                                    h.remoteFrameHandle.fh+t.e.bb[bti].frameOffset,
                                                    WORD];
                                                RETURN};
                                            ENDCASE => ERROR;
                                    ENDCASE => GO TO typeFault;
                                };
                            ENDCASE => GO TO typeFault;
                        }
                    ELSE {
                        <<local case>>
                        WITH tv SELECT FROM
                            tvr: REF RTTypesPrivate.TypedVariableRec => {
                                WITH h: tvr.head SELECT FROM
                                    gfh => gfiBase _ h.gfh.gfi;
                                    fh => WITH stb SELECT FROM
                                        t: SymbolTableBase.x => {
                                            bti: bx.InnerCallableBodyIndex
                                                = LOOPHOLE[
                                                    t.e.seb[NARROW[isei,SymbolIdIndex.x].e].idInfo,
                                                    bx.InnerCallableBodyIndex];
                                            ws[0] _ LOOPHOLE[h.fh+t.e.bb[bti].frameOffset, WORD];
                                            RETURN};
                                        t: SymbolTableBase.y => {
                                            bti: by.InnerCallableBodyIndex
                                                = LOOPHOLE[
                                                    t.e.seb[NARROW[isei,SymbolIdIndex.y].e].idInfo,
                                                    by.InnerCallableBodyIndex];
                                            ws[0] _ LOOPHOLE[h.fh+t.e.bb[bti].frameOffset, WORD];
                                            RETURN};
                                        ENDCASE => ERROR;
                                    pointer => gfiBase _ LOOPHOLE [
                                        RTCommon.ShortenLongPointer[h.ptr],
                                        PrincOps.GlobalFrameHandle].gfi;
                                    ENDCASE => GO TO typeFault;
                                };
                            ENDCASE => GO TO typeFault;
                        };
                WITH stb SELECT FROM
                    t: SymbolTableBase.x =>
                        popd _ LOOPHOLE[t.e.seb[NARROW[isei, SymbolIdIndex.x].e].idValue];
                    t: SymbolTableBase.y =>
                        popd _ LOOPHOLE[t.e.seb[NARROW[isei, SymbolIdIndex.y].e].idValue];
                    ENDCASE => ERROR;
                pd _ PrincOps.ControlLink[procedure[gfi: 0, ep: 0, tag: TRUE]];
                pd.ep _ popd.ep;
                pd.gfi _ popd.gfi - 1--Groan-- + gfiBase;
                ws[0] _ LOOPHOLE[pd, WORD];
                RETURN
                EXITS typeFault => ERROR Error[reason: typeFault, type: TVType[tv]];
                };
            ENDCASE => ERROR Error [
                reason: notImplemented,
                msg: "other than PROC, SIGNAL and ERROR transfer mode constants"];
        };

    END.