RTTDefaultImpl.mesa
Paul Rovner, January 28, 1983 3:26 pm
Russ Atkinson, April 28, 1983 5:14 pm
DIRECTORY
AMBridge
USING [
IsRemote, SetTVFromLI, TVForATOM, TVForPointerReferent, TVToLI, WordSequence, WordSequenceRecord],
AMTypes
USING [
Assign, Class, Error, GroundStar, IndexToTV, IndexToType, NComponents, New, Size, TVType, TypeClass, UnderType],
BrandXSymbolDefs
USING [
ExtensionClass, InnerCallableBodyIndex, SymbolTableBase, TreeIndex, TreeLink],
BrandYSymbolDefs
USING [
ExtensionClass, InnerCallableBodyIndex, SymbolTableBase, TreeIndex, TreeLink],
PrincOps USING [ControlLink, GFTIndex, GlobalFrameHandle, ProcDesc],
RTBasic USING [Index, TV, Type, TypedVariable],
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 [GetTVZones, 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, RTBasic, RTSymbolDefs, RTSymbolOps, RTSymbols, RTTypesRemotePrivate;
C O N S T A N T S
CARD: TYPE = LONG CARDINAL;
tvqZone: ZONE = RTTypesPrivate.GetTVZones[].qz;
DefaultInitialValue:
PUBLIC
SAFE
PROC
[type: Type] RETURNS[tv: TypedVariable] = 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: TypedVariable;
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
ELSE
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]};
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 =>
ERROR Error[reason: notImplemented,
msg: "DefaultInitialValue for interface records"];
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 =>
ERROR Error[reason: notImplemented,
msg: "DefaultInitialValue for interface records"];
ENDCASE=> ERROR;
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 = 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 ERROR Error[reason: notImplemented, msg: "DefaultInitialValue in this case"];
EXITS noDefault => tv ← NIL};
ENDCASE => ERROR}; -- end basic case
ReleaseSTB[typeSTB];
[] ← RTTCache.FillRefEntry[entry, tv];
RETURN[tv]}; -- end DefaultInitialValue
IndexToDefaultInitialValue:
PUBLIC
SAFE
PROC[type: Type, index: Index]
RETURNS [tv: TypedVariable ← 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] = {
IF ISEExtended[stb, isei]
THEN {
ttype: ExtensionClass;
tree: TreeLink;
tv ← New[IndexToType[type, index]];
[ttype, tree] ← ISEFindExtension[stb, isei];
IF (
WITH ttype
SELECT
FROM
t: ExtensionClass.x => t.e = default,
t: ExtensionClass.y => t.e = default,
ENDCASE => ERROR)
AND NOT SetTVFromLink[tv, stb, tree]
THEN
ERROR Error[reason: notImplemented,
msg: "IndexToDefaultInitialValue in this case"];
} -- IF ISEExtended[stb, isei]
ELSE
IF ISEConstant[stb, isei]
THEN {
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;
}; -- ELSE clause of IF ISEExtended[stb, isei]
};
-- end GetDefaultFieldValue
START IndexToDefaultInitialValue HERE
RTTypesPrivate.RecordComponentISEI[type, index, GetDefaultFieldValue]};
SetTVFromLink:
PROC
[tv: TypedVariable, 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: TypedVariable, 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.info
SELECT
FROM
string => RETURN[FALSE]; -- Mesa can't do it
word => {
ptr: LONG POINTER ← NIL;
WITH val: stb.ltb[wordLit.index]
SELECT
FROM
short => {
ptr ← @val.value;
SELECT TypeClass[UnderType[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:
INTEGER
IN [1..stb.tb[index].nSons]
DO stv: TypedVariable ← 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: TypedVariable, 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.info
SELECT
FROM
string => RETURN[FALSE]; -- Mesa can't do it
word => {
ptr: LONG POINTER ← NIL;
WITH val: stb.ltb[wordLit.index]
SELECT
FROM
short => {
ptr ← @val.value;
SELECT TypeClass[UnderType[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: TypedVariable ← 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;
};
-- end of SetTVFromLinkY
TypeFromISE:
PROC [stb: SymbolTableBase, isei: SymbolIdIndex]
RETURNS [Type] = {
RETURN [RTSymbolOps.AcquireType[stb, RTSymbolOps.ISEType[stb, isei]]];
};
GetIdConstantValue:
PUBLIC
PROC[tv: TypedVariable, 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 {
ws ← NEW[WordSequenceRecord[1]];
ws[0] ←
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),
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"];
IF IsRemote[tv]
THEN {
ws ← NEW[WordSequenceRecord[1]];
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 => ERROR Error[reason: typeFault, type: TVType[tv]];
};
ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]];
}
ELSE {
local case
ws ← NEW[WordSequenceRecord[1]];
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 => ERROR Error[reason: typeFault, type: TVType[tv]];
};
ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]];
};
popd ←
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),
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.