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.