--RTTDefaultImpl.mesa
-- Paul Rovner, December 21, 1982 9:59 am

DIRECTORY
    AMBridge USING[TVToLI, TVForPointerReferent, SetTVFromLI, SetTVFromLC,
                         WordSequence, WordSequenceRecord, TVForATOM, IsRemote],
    AMTypes USING[Class, UnderType, New, IndexToTV, Assign, TypeClass,
                       Error, IndexToType, TVType, TVSize, NComponents, Size],
    PrincOps USING[ProcDesc, GFTIndex, GlobalFrameHandle, ControlLink],
    RTBasic USING[Type, Index, TypedVariable, TV],
    RTCommon USING[ShortenLongPointer],
    RTSymbols USING[AcquireAtom, SymbolTableBase, GetTypeSymbols, ReleaseSTB,
                          EnumerateCtxIseis, AcquireType, SymbolIndex, SymbolIdIndex,
                          SymbolConstructorIndex, InnerCallableBodyIndex, ExtensionClass,
                          symbolIndexForTYPE, TreeIndex, TreeLink],
    RTTCache USING[RefEntry, LookupRef, GetRef, FillRefEntry],
    RTTypesPrivate USING[GetTVZones, TypedVariableRec, RecordComponentISEI];

RTTDefaultImpl: PROGRAM
   IMPORTS AMBridge, AMTypes, RTCommon, RTSymbols, RTTCache, RTTypesPrivate
   EXPORTS AMTypes, RTTypesPrivate
= BEGIN OPEN AMBridge, AMTypes, RTBasic, RTSymbols;
   
-- C O N S T A N T S
tvqZone: ZONE = RTTypesPrivate.GetTVZones[].qz; 

-- raises notImplemented
DefaultInitialValue: PUBLIC SAFE PROC[type: Type] RETURNS[tv: TypedVariable] = TRUSTED
 {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 => 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: TypedVariable;
      csei: SymbolConstructorIndex = typeSTB.UnderType[typeSEI];

      EachIndex: PROC[stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS[stop: BOOLEAN] =
       {index _ index + 1;
        iTV _ IndexToTV[tv, index];
        IF stb.seb[isei].extended
         THEN {ttype: ExtensionClass;
                  tree: TreeLink;
                  [ttype, tree] _ stb.FindExtension[isei];
                  IF ttype = default AND SetTVFromLink[iTV, stb, tree]
                   THEN RETURN[FALSE]};
       -- If no default is explicitly given for this field, perhaps its type has a default value.
        defTV _ DefaultInitialValue[AcquireType[stb, stb.seb[isei].idType]
                        ! Error => {defTV _ NIL; CONTINUE}];
        IF defTV # NIL THEN Assign[iTV, defTV];
        RETURN[FALSE]};

      -- start constructed case here
      WITH ser: typeSTB.seb[csei] SELECT FROM
        record => [] _ EnumerateCtxIseis[typeSTB, ser.fieldCtx, EachIndex];
        definition => ERROR Error[reason: notImplemented,
                                       msg: "DefaultInitialValue for interface records"];
       ENDCASE=>ERROR};  -- end constructed case

    basic =>
     {isei: SymbolIdIndex _ LOOPHOLE[typeSEI, SymbolIdIndex]; -- basic attribute guarantees that type is definition
      ttype: ExtensionClass;
      tree: TreeLink;
      DO sei: SymbolIndex = typeSTB.seb[isei].idInfo;
         IF typeSTB.seb[isei].extended THEN EXIT; -- found default
         IF typeSTB.seb[sei].seTag # id THEN GO TO noDefault;
         isei _ LOOPHOLE[sei, SymbolIdIndex];
         ENDLOOP;
      [ttype, tree] _ typeSTB.FindExtension[isei];
      IF ttype # default THEN GO TO noDefault;
      IF ~SetTVFromLink[tv, typeSTB, tree] THEN tv _ NIL
      EXITS noDefault => {tv _ NIL}};
   ENDCASE => ERROR};  -- end basic case

  ReleaseSTB[typeSTB];
  [] _ RTTCache.FillRefEntry[entry, tv];
  RETURN[tv]};
  
-- Reason for function: DefaultInitialValue[IndexToType[type, index]] doesn't work,
-- because it misses explicit field value.
-- raises typeFault, badIndex, notImplemented
IndexToDefaultInitialValue: PUBLIC SAFE PROC[type: Type, index: Index]
      RETURNS [tv: TypedVariable _ NIL] = TRUSTED
 {GetDefaultFieldValue: PROC[stb: SymbolTableBase, isei: SymbolIdIndex] =
   {IF stb.seb[isei].extended
     THEN
      {ttype: ExtensionClass;
        tree: TreeLink;
        tv _ New[IndexToType[type, index]];
        [ttype, tree] _ stb.FindExtension[isei];
        IF ttype = default THEN [] _ SetTVFromLink[tv, stb, tree]}
     ELSE  -- If no default is explicitly given for this field, perhaps its type has a default value.
      tv _ DefaultInitialValue[AcquireType[stb, stb.seb[isei].idType]]};
      
    -- START IndexToDefaultInitialValue HERE
   RTTypesPrivate.RecordComponentISEI[type, index, GetDefaultFieldValue]};
  
  -- this guy returns FALSE if it can't figure out the value of the tree,
  -- otherwise gets the value and assigns it to tv.
  SetTVFromLink: PROC[tv: TypedVariable, stb: SymbolTableBase, tree: TreeLink]
      RETURNS[success: BOOLEAN _ TRUE] = 
   {DO
      WITH oak: tree SELECT FROM
        literal =>
         {WITH wordLit: oak.info SELECT FROM
             string => RETURN[FALSE]; -- Mesa can't do it
             word =>
              WITH val: stb.ltb[wordLit.index] SELECT FROM
                  short =>
                   {class: Class = TypeClass[UnderType[TVType[tv]]];
                     IF class = longCardinal OR class = cardinal
                      THEN SetTVFromLC[tv, LONG[LOOPHOLE[val.value, CARDINAL]]]
                      ELSE SetTVFromLI[tv, LONG[LOOPHOLE[val.value, INTEGER]]];
                    RETURN[TRUE]};
                  long =>
                   {IF val.length # TVSize[tv] THEN ERROR;
                    Assign[lhs: tv,
                             rhs: TVForPointerReferent[ptr: @val.value,
                                                            type: TVType[tv],
                                                            status: readOnly]];
                    RETURN[TRUE]};
                 ENDCASE => ERROR;
            ENDCASE => ERROR};
        symbol =>
         {OPEN node: stb.seb[oak.index];
           class: Class = TypeClass[UnderType[TVType[tv]]];
           IF ~node.constant THEN RETURN[FALSE];
           IF node.extended THEN
           {ttype: ExtensionClass;
            [ttype, tree] _ stb.FindExtension[oak.index];
            IF ttype # value THEN ERROR; -- I (DCS) don't believe any of this.
            LOOP};
           IF class = longCardinal OR class = cardinal
            THEN SetTVFromLC[tv, LONG[LOOPHOLE[node.idValue, CARDINAL]]]
            ELSE SetTVFromLI[tv, LONG[LOOPHOLE[node.idValue, INTEGER]]];
           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]
                            ELSE RETURN[SetTVFromLink[tv: tv, stb: stb, tree: node.son[1]]]};
           clit, mwconst =>
             {IF node.nSons # 1 THEN ERROR;
              tree _ node.son[1];  -- the one son of an mwconst is guaranteed to be a literal
              LOOP};
           uminus =>
             {IF ~SetTVFromLink[tv: tv, stb: stb, tree: node.son[1]] THEN RETURN[FALSE];
              SetTVFromLI[tv, -TVToLI[tv]];
              RETURN[TRUE]};
           construct =>
             {uT: Type = UnderType[TVType[tv]];
               index: 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: TypedVariable _ IndexToTV[tv, i];
                     [] _ SetTVFromLink[stv, stb, stb.tb[index].son[i]];
                ENDLOOP;
              RETURN[TRUE]};
           atom =>
             {atom: ATOM _ AcquireAtom[stb, NARROW[node.son[1], TreeLink[hash]].index];
              Assign[tv, TVForATOM[atom]];
              RETURN[TRUE]};
           ENDCASE => RETURN[FALSE]};
         ENDCASE => ERROR;
    ENDLOOP};  -- end of SetTVFromLink

-- tv arg is for signal, error and proc constants, to determine the gfi or fh bias
-- raises notImplemented, typeFault
GetIdConstantValue: PUBLIC PROC[tv: TypedVariable, stb: SymbolTableBase, isei: SymbolIdIndex]
      RETURNS[ws: WordSequence] =
    { IF stb.seb[isei].idType = symbolIndexForTYPE
        THEN {ws _ NEW[WordSequenceRecord[1]];
                 ws[0] _ LOOPHOLE[AcquireType[stb, isei], WORD];
                 RETURN};
      SELECT stb.XferMode[stb.seb[isei].idType] FROM
        none =>
          { IF stb.seb[isei].extended
              THEN { newTV: TV;
                       ttype: ExtensionClass;
                       tree: TreeLink;
                       type: Type = AcquireType[stb, stb.seb[isei].idType];
                       ws _ NEW[WordSequenceRecord[Size[type]]];
                       newTV _ TVForPointerReferent[ptr: @ws[0],
                                                             type: type];
                       [ttype, tree] _ stb.FindExtension[isei];
                       IF NOT SetTVFromLink[newTV, stb, tree]
                        THEN ERROR Error[reason: notImplemented, msg: "extended constants"]}
              ELSE {ws _ NEW[WordSequenceRecord[1]];
                      ws[0] _ LOOPHOLE[stb.seb[isei].idValue, WORD];
                     };
               RETURN};

        signal, error, proc =>
          { popd: PrincOps.ProcDesc;
            pd: PrincOps.ProcDesc;
            gfiBase: PrincOps.GFTIndex;
            
            IF stb.seb[isei].extended
              THEN ERROR Error[reason: notImplemented,
                                     msg: "extended transfer constants"];

            IF IsRemote[tv]
               THEN ERROR Error[reason: notImplemented,
                                     msg: "remote transfer constants"];

            ws _ NEW[WordSequenceRecord[1]];
            WITH tv SELECT FROM
              tvr: REF RTTypesPrivate.TypedVariableRec =>
                     { WITH h: tvr.head SELECT FROM
                         gfh => gfiBase _ h.gfh.gfi;
                         fh => {bti: InnerCallableBodyIndex = LOOPHOLE[stb.seb[isei].idInfo,
                                                                                  InnerCallableBodyIndex];
                                  ws[0] _ LOOPHOLE[h.fh+stb.bb[bti].frameOffset, WORD];
                                  RETURN};
                         pointer => gfiBase _ LOOPHOLE
                                                                [RTCommon.ShortenLongPointer[h.ptr],
                                                    PrincOps.GlobalFrameHandle].gfi;
                        ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]];
                     };
             ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]];
            popd _ LOOPHOLE[stb.seb[isei].idValue, PrincOps.ProcDesc];
            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};
       ENDCASE => ERROR Error
                               [reason: notImplemented,
                                msg: "other than PROC, SIGNAL and ERROR transfer mode constants"]};
       
END.