--RTTDefaultImpl.mesa
-- Paul Rovner, December 21, 1982 3:02 pm

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],
RTSymbolDefs USING[SymbolTableBase, SymbolIndex, SymbolIdIndex,
SymbolConstructorIndex, InnerCallableBodyIndex, ExtensionClass,
symbolIndexForTYPE, TreeIndex, TreeLink],
RTSymbolOps USING[AcquireAtom, EnumerateCtxIseis, AcquireType],
RTSymbols USING[GetTypeSymbols, ReleaseSTB],
RTTCache USING[RefEntry, LookupRef, GetRef, FillRefEntry],
RTTypesPrivate USING[GetTVZones, TypedVariableRec, RecordComponentISEI];

RTTDefaultImpl: PROGRAM
IMPORTS AMBridge, AMTypes, RTCommon, RTSymbolOps, RTSymbols, RTTCache,
RTTypesPrivate
EXPORTS AMTypes, RTTypesPrivate
= BEGIN OPEN AMBridge, AMTypes, RTBasic, RTSymbolDefs, RTSymbolOps, 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.