-- Constructor.mesa, modified by Sweet, January 22, 1980 4:35 PM
DIRECTORY
AltoDefs: FROM "altodefs" USING [BYTE, charlength, wordlength],
Code: FROM "code" USING [CodeNotImplemented, curctxlvl],
CodeDefs: FROM "codedefs" USING [
BoVarIndex, ConsDestination, Lexeme, MaxParmsInStack, NullLex,
VarComponent, VarIndex, VarNull],
ComData: FROM "comdata" USING [tC0],
ControlDefs: FROM "controldefs" USING [FieldDescriptor],
FOpCodes: FROM "fopcodes" USING [
qBLT, qBLTL, qDSUB, qGADRB, qLADRB, qLI, qPUSH, qSUB, qWS, qWSD, qWSF],
InlineDefs: FROM "inlinedefs" USING [BITSHIFT],
LiteralOps: FROM "literalops" USING [MasterString],
Literals: FROM "literals" USING [ltType, MSTIndex, stType],
P5: FROM "p5" USING [
ConstructOnStack, Exp, GenTempLex, MoveToCodeWord, P5Error, SysCall,
WriteCodeWord],
P5L: FROM "p5l" USING [
AdjustComponent, ComponentForLex, CopyToTemp, CopyVarItem,
EasilyLoadable, FieldOfComponent, GenAdd, GenVarItem,
LoadComponent, LoadVar, MakeBo, ModComponent, OVarItem, ReleaseVarItem,
ReusableCopies, TOSLex, VarForLex, VarVarAssign, Words],
P5U: FROM "p5u" USING [
FieldAddress, MakeTreeLiteral, NextVar, OperandType,
Out0, Out1, Out2,
PushLitVal, WordAligned, WordsForOperand],
SDDefs: FROM "sddefs" USING [sStringInit],
Stack: FROM "stack" USING [Also, Dump, Forget, Mark, Pop, TempStore, Top],
SymbolOps: FROM "symbolops" USING [
BitsForType, Cardinality, FnField, NextSe, RecordRoot, UnderType,
WordsForType],
Symbols: FROM "symbols" USING [ ArraySEIndex,
BitAddress, bodyType, BTIndex, CBTIndex, ContextLevel, CSEIndex, CTXIndex,
ctxType, HTIndex, ISEIndex, ISENull, lG, lZ, RecordSEIndex, SEIndex,
seType, TypeClass],
Table: FROM "table" USING [Base, Notifier],
Tree: FROM "tree" USING [Index, Link, Map, Null, treeType],
TreeOps: FROM "treeops" USING [FreeNode, ScanList, UpdateList];
Constructor: PROGRAM
IMPORTS MPtr: ComData, CPtr: Code, InlineDefs, LiteralOps, P5, P5L, P5U,
Stack, SymbolOps, TreeOps
EXPORTS CodeDefs, P5 =
BEGIN
OPEN CodeDefs, SymbolOps;
-- imported definitions
BYTE: TYPE = AltoDefs.BYTE;
wordlength: CARDINAL = AltoDefs.wordlength;
charlength: CARDINAL = AltoDefs.charlength;
BitAddress: TYPE = Symbols.BitAddress;
BTIndex: TYPE = Symbols.BTIndex;
CBTIndex: TYPE = Symbols.CBTIndex;
ContextLevel: TYPE = Symbols.ContextLevel;
CSEIndex: TYPE = Symbols.CSEIndex;
CTXIndex: TYPE = Symbols.CTXIndex;
HTIndex: TYPE = Symbols.HTIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
ISENull: ISEIndex = Symbols.ISENull;
lZ: ContextLevel = Symbols.lZ;
lG: ContextLevel = Symbols.lG;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
SEIndex: TYPE = Symbols.SEIndex;
TypeClass: TYPE = Symbols.TypeClass;
tb: Table.Base; -- tree base (local copy)
seb: Table.Base; -- semantic entry base (local copy)
ctxb: Table.Base; -- context entry base (local copy)
bb: Table.Base; -- body entry base (local copy)
cb: Table.Base; -- code base (local copy)
stb: Table.Base; -- string base (local copy)
ltb: Table.Base; -- literal base (local copy)
ConstructorNotify: PUBLIC Table.Notifier =
BEGIN -- called by allocator whenever table area is repacked
seb ← base[Symbols.seType];
ctxb ← base[Symbols.ctxType];
bb ← base[Symbols.bodyType];
stb ← base[Literals.stType];
tb ← base[Tree.treeType];
cb ← LOOPHOLE[tb];
ltb ← base[Literals.ltType];
RETURN
END;
-- state data and code for construction
cd: PUBLIC ConsDestination;
ConstructionError: SIGNAL = CODE;
SetConsDest: PROCEDURE [r: VarIndex, exp: BOOLEAN ← FALSE]
RETURNS [rVal: VarIndex] =
BEGIN
bor: BoVarIndex;
base: VarComponent;
rVal ← VarNull;
WITH cb[r] SELECT FROM
o => WITH vv: var SELECT FROM
frame =>
BEGIN
IF ~(vv.level = lG OR vv.level = CPtr.curctxlvl) THEN
GO TO shouldBo;
cd.bd ← vv.bd; cd.fOffset ← vv.wd; cd.fLevel ← vv.level;
cd.inFrame ← TRUE;
IF exp THEN rVal ← r ELSE P5L.ReleaseVarItem[r];
cd.wSize ← vv.wSize;
cd.bSize ← vv.bSize;
RETURN;
EXITS
shouldBo => NULL;
END;
frameup => NULL;
linkup => NULL;
ENDCASE => ERROR;
bo, bdo, ind => NULL;
ENDCASE => ERROR;
bor ← P5L.MakeBo[r];
IF bor = VarNull THEN SIGNAL ConstructionError; -- should be caught above
IF exp THEN
BEGIN
r1: VarIndex;
[r1, rVal] ← P5L.ReusableCopies[bor, store];
bor ← P5L.MakeBo[r1];
END;
BEGIN
offset: VarComponent ← cb[bor].offset;
WITH vv: offset SELECT FROM
frame =>
BEGIN
cd.bd ← vv.bd;
cd.pDelta ← -INTEGER[vv.wd];
cd.wSize ← vv.wSize;
cd.bSize ← vv.bSize;
END;
ENDCASE => ERROR;
END;
BEGIN
base ← cb[bor].base;
P5L.ReleaseVarItem[bor]; -- we're finished with it now
WITH vv: base SELECT FROM
frame =>
BEGIN
IF vv.bSize # 0 OR ~(vv.level = lG OR vv.level = CPtr.curctxlvl) THEN
GO TO loadIt;
cd.pLevel ← vv.level; cd.pOffset ← vv.wd;
cd.pLength ← vv.wSize;
END;
link => BEGIN cd.pLink ← TRUE; cd.pOffset ← vv.wd; END;
ENDCASE => GO TO loadIt;
EXITS
loadIt =>
BEGIN
wS: CARDINAL = P5L.Words[base.wSize, base.bSize];
P5L.LoadComponent[base];
cd.pSti ← Stack.Top[wS];
Stack.Also[n: wS, inLink: FALSE, tLevel: lZ, tOffset: 0]; --forget
cd.pLoaded ← TRUE;
cd.pLength ← wS;
END;
END;
END;
GetPointer: PROCEDURE [owd: CARDINAL]
RETURNS [avar: VarComponent, newOwd: CARDINAL] =
BEGIN -- invariant: cd.pLoaded => newOwd + cd.pDelta = owd
SELECT TRUE FROM
cd.pLoaded => avar ← [wSize: cd.pLength, space: stack[sti: cd.pSti]];
cd.inFrame =>
BEGIN
avar ← [wSize: 1, space: faddr[wd: cd.fOffset+owd, level: cd.fLevel]];
cd.pLength ← 1; -- to be right if loaded
cd.pDelta ← owd; -- to be right if loaded
newOwd ← 0;
RETURN
END;
cd.pLink => avar ← [wSize: 1, space: link[wd: cd.pOffset]];
cd.pLevel # lZ =>
avar ← [wSize: cd.pLength, space:
frame[wd: cd.pOffset, level: cd.pLevel, immutable: TRUE]];
ENDCASE => ERROR;
IF INTEGER[owd] >= cd.pDelta THEN
newOwd ← CARDINAL[INTEGER[owd] - cd.pDelta]
ELSE
BEGIN
P5L.LoadComponent[avar];
P5U.Out1[FOpCodes.qLI, CARDINAL[cd.pDelta] - owd];
IF cd.pLength # 1 THEN
BEGIN P5U.Out1[FOpCodes.qLI, 0]; P5U.Out0[FOpCodes.qDSUB]; END
ELSE P5U.Out0[FOpCodes.qSUB];
cd.pDelta ← owd;
cd.pSti ← Stack.Top[cd.pLength];
newOwd ← 0; cd.pLink ← FALSE; cd.pLevel ← lZ;
avar ← [wSize: cd.pLength, space: stack[sti: cd.pSti]];
cd.pLoaded ← TRUE;
RETURN
END;
IF newOwd > LAST[BYTE] THEN
BEGIN
P5L.LoadComponent[avar];
P5L.GenAdd[newOwd, cd.pLength # 1];
cd.pDelta ← owd;
cd.pSti ← Stack.Top[cd.pLength];
newOwd ← 0; cd.pLink ← FALSE; cd.pLevel ← lZ;
avar ← [wSize: cd.pLength, space: stack[sti: cd.pSti]];
cd.pLoaded ← TRUE;
END;
END;
LoadPointer: PROCEDURE [owd: CARDINAL] RETURNS [newOwd: CARDINAL] =
BEGIN
avar: VarComponent;
[avar, newOwd] ← GetPointer[owd];
P5L.LoadComponent[avar];
cd.pSti ← Stack.Top[cd.pLength];
cd.pLoaded ← TRUE;
END;
ConsAssign: PROCEDURE [
atO: POINTER TO frame VarComponent, t: Tree.Link, l: Lexeme ← NullLex] =
BEGIN
dest: VarIndex;
source: VarIndex;
offset: frame VarComponent ← atO↑;
useFrame: BOOLEAN ← cd.inFrame AND offset.wSize IN [1..2] AND
offset.bSize = 0 AND (cd.fOffset+offset.wd) IN BYTE;
useSwapped: BOOLEAN ← ~useFrame AND cd.pLength = 1 AND
(offset.wSize = 0 OR (offset.bSize = 0 AND offset.wSize IN [1..2]));
offset.bd ← offset.bd + cd.bd;
IF useFrame AND cd.pLoaded THEN
BEGIN Stack.Pop[]; cd.pLoaded ← FALSE END;
IF ~useFrame THEN
BEGIN
IF ~useSwapped AND cd.pLoaded THEN
BEGIN
IF cd.pLink OR cd.pLevel # lZ THEN Stack.Pop[]
ELSE
BEGIN
avar: VarComponent;
avar ← Stack.TempStore[cd.pLength];
WITH avar SELECT FROM
frame => BEGIN cd.pLevel ← level; cd.pOffset ← wd; END;
link => BEGIN cd.pLink ← TRUE; cd.pOffset ← wd; END;
ENDCASE => ERROR;
END;
cd.pLoaded ← FALSE;
END;
END;
IF useSwapped THEN offset.wd ← LoadPointer[offset.wd];
source ← P5L.VarForLex[IF l # NullLex THEN l ELSE P5.Exp[t]];
IF useSwapped THEN
BEGIN
base: VarComponent;
WITH cb[cd.pSti] SELECT FROM
onStack =>
BEGIN
WSOp: ARRAY [1..2] OF BYTE = [FOpCodes.qWS, FOpCodes.qWSD];
P5L.LoadVar[source];
IF offset.bSize = 0 THEN P5U.Out1[WSOp[offset.wSize], offset.wd]
ELSE P5U.Out2[FOpCodes.qWSF, offset.wd,
LOOPHOLE[ ControlDefs.FieldDescriptor[
offset: 0, posn: offset.bd, size: offset.bSize]]];
IF cd.remaining # 0 THEN
BEGIN
P5U.Out0[FOpCodes.qPUSH];
cd.pSti ← Stack.Top[];
Stack.Also[n: 1, inLink: cd.pLink,
tOffset: cd.pOffset, tLevel: cd.pLevel];
END
ELSE cd.pLoaded ← FALSE;
RETURN
END;
inTemp =>
BEGIN
cd.pLevel ← tLevel; cd.pOffset ← tOffset;
base ← [wSize: 1, space: frame[wd: tOffset, level: tLevel,
immutable: TRUE]];
END;
inLink =>
BEGIN
cd.pLink ← TRUE; cd.pOffset ← link;
base ← [wSize: 1, space: link[wd: link]];
END;
ENDCASE => ERROR;
-- would have used swap but pointer got dumped when evaluating field
Stack.Forget[cd.pSti];
cd.pLoaded ← FALSE;
dest ← P5L.GenVarItem[bo];
cb[dest] ← [body: bo[base: base, offset: offset]];
END
ELSE IF useFrame THEN
BEGIN
offset.wd ← offset.wd + cd.fOffset;
offset.level ← cd.fLevel;
dest ← P5L.OVarItem[offset];
END
ELSE
BEGIN
base: VarComponent;
[base, offset.wd] ← GetPointer[offset.wd];
IF cd.remaining # 0 THEN WITH base SELECT FROM
stack => IF ~cd.inFrame THEN
BEGIN -- this is our only copy, save it away
base ← Stack.TempStore[cd.pLength];
WITH base SELECT FROM
frame => BEGIN cd.pLevel ← level; cd.pOffset ← wd; END;
link => BEGIN cd.pLink ← TRUE; cd.pOffset ← wd; END;
ENDCASE => ERROR;
cd.pLoaded ← FALSE;
END;
ENDCASE;
dest ← P5L.GenVarItem[bo];
cb[dest] ← [body: bo[base: base, offset: offset]];
END;
[] ← P5L.VarVarAssign[to: dest, from: source, isexp: FALSE];
cd.pLoaded ← FALSE;
END;
CountDups: Tree.Map =
BEGIN
node: Tree.Index;
IF t = Tree.Null THEN GO TO normalRet;
WITH t SELECT FROM
subtree =>
BEGIN
node ← index;
SELECT tb[node].name FROM
rowcons, construct =>
IF ~(tb[node].name = rowcons AND tb[node].attr1) THEN
BEGIN
tb[node].son[2] ←
TreeOps.UpdateList[tb[node].son[2], CountDups];
GO TO normalRet
END;
all =>
BEGIN
asei: Symbols.ArraySEIndex = tb[node].info;
IF seb[asei].oldPacked AND
SymbolOps.BitsForType[seb[asei].componentType] <= 8 THEN
GO TO packed;
tb[node].son[1] ← TreeOps.UpdateList[tb[node].son[1], CountDups];
GO TO normalRet
EXITS
packed => NULL;
END;
union =>
BEGIN
IF tb[node].attr2 THEN cd.remaining ← cd.remaining+1;
tb[node].son[2] ← TreeOps.UpdateList[tb[node].son[2], CountDups];
GO TO normalRet
END;
cast, pad =>
BEGIN
tb[node].son[1] ← TreeOps.UpdateList[tb[node].son[1], CountDups];
GO TO normalRet
END;
safen =>
BEGIN
IF cd.ignoreSafen THEN
BEGIN
v ← TreeOps.UpdateList[tb[node].son[1], CountDups];
tb[node].son[1] ← Tree.Null;
TreeOps.FreeNode[node];
RETURN --[v]
END
ELSE
BEGIN
r: VarIndex = P5L.VarForLex[P5.Exp[tb[node].son[1]]];
sei: ISEIndex = P5L.CopyToTemp[r].sei;
seb[sei].idType ← tb[node].info;
TreeOps.FreeNode[node];
cd.remaining ← cd.remaining+1;
RETURN [[symbol[sei]]];
END;
END;
ENDCASE;
END;
ENDCASE;
cd.remaining ← cd.remaining+1;
GO TO normalRet;
EXITS
normalRet => RETURN[t];
END;
ConstructCountDown: PROCEDURE =
BEGIN
IF LOOPHOLE[(cd.remaining ← cd.remaining-1),INTEGER] < 0 THEN
SIGNAL ConstructionError;
RETURN
END;
--
RowCons: PUBLIC PROCEDURE [t: Tree.Link, node: Tree.Index] =
BEGIN -- array initialization
r: VarIndex;
asei: CSEIndex = LOOPHOLE[tb[node].info];
saveCd: ConsDestination = cd; -- necessary in an inline
offset: frame VarComponent;
cd ← [ignoreSafen: t.tag = symbol]; -- + many defaults
IF tb[node].attr1 THEN cd.remaining ← 1
ELSE tb[node].son[2] ← TreeOps.UpdateList[tb[node].son[2], CountDups];
r ← P5L.VarForLex[P5.Exp[t]];
[] ← SetConsDest[r, FALSE];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
Row[node, asei, @offset];
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
cd ← saveCd;
RETURN
END;
RowConsExp: PUBLIC PROCEDURE [t: Tree.Link, node: Tree.Index]
RETURNS [Lexeme] =
BEGIN -- array (expression)initialization
r, rr: VarIndex;
asei: CSEIndex ← tb[node].info;
awords: CARDINAL = WordsForType[asei];
saveCd: ConsDestination = cd;
offset: frame VarComponent;
cd ← [ignoreSafen: t = Tree.Null OR t.tag = symbol]; -- + many defaults
tb[node].son[2] ← TreeOps.UpdateList[tb[node].son[2], CountDups];
r ← P5L.VarForLex[IF t = Tree.Null THEN P5.GenTempLex[awords]
ELSE P5.Exp[t]];
rr ← SetConsDest[r, TRUE];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
Row[node, asei, @offset];
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
cd ← saveCd;
RETURN[[bdo[rr]]]
END;
Row: PROCEDURE [node: Tree.Index, asei: CSEIndex, atO: POINTER TO READONLY frame VarComponent] =
BEGIN
-- handles ARRAY initialization
n: CARDINAL;
csei: CSEIndex;
c: CARDINAL;
filled: BOOLEAN ← FALSE;
localstrconst, globalstrconst: BOOLEAN;
tOffset: frame VarComponent = atO↑;
offset: frame VarComponent ← atO↑;
constrow: PROCEDURE [t: Tree.Link] =
BEGIN -- outputs a row of constants
scr: PROCEDURE [t: Tree.Link] =
BEGIN
msti: Literals.MSTIndex;
WITH e:t SELECT FROM
literal =>
WITH e.info SELECT FROM
string =>
BEGIN
msti ← LiteralOps.MasterString[index];
IF stb[msti].local THEN localstrconst ← TRUE
ELSE globalstrconst ← TRUE;
P5.WriteCodeWord[stb[msti].info];
END;
ENDCASE => P5.P5Error[577];
ENDCASE => P5.P5Error[578];
n ← n+1;
RETURN
END;
n ← 0;
TreeOps.ScanList[t, scr];
RETURN
END; -- of constrow
scrow: PROCEDURE [t: Tree.Link] =
BEGIN
node: Tree.Index;
offset.wSize ← eWSize; offset.bSize ← eBSize;
IF t # Tree.Null THEN
BEGIN
DO -- until we get to something interesting
WITH t SELECT FROM
subtree =>
SELECT tb[index].name FROM
pad =>
BEGIN
eWords: CARDINAL;
t ← tb[index].son[1]; -- note the variant may change here
eWords ← P5U.WordsForOperand[t];
offset.wSize ← eWords; offset.bSize ← 0;
END;
cast => t ← tb[index].son[1];
ENDCASE => EXIT;
ENDCASE => EXIT;
ENDLOOP;
WITH t SELECT FROM
subtree =>
BEGIN
node ← index;
SELECT tb[node].name FROM
rowcons =>
BEGIN
Row[node, csei, @offset];
P5L.ModComponent[var: @offset, wd: eWSize, bd: eBSize];
RETURN
END;
construct =>
BEGIN
MainConstruct[
tb[node].son[2], P5U.OperandType[t], P5U.FieldAddress,
@offset];
P5L.ModComponent[var: @offset, wd: eWSize, bd: eBSize];
RETURN
END;
all =>
BEGIN -- convert this later
AllConstruct[node, @offset];
P5L.ModComponent[var: @offset, wd: eWSize, bd: eBSize];
RETURN
END;
ENDCASE;
END;
ENDCASE;
ConstructCountDown[];
ConsAssign[@offset, t];
END; -- of t # Tree.Null
P5L.ModComponent[var: @offset, wd: eWSize, bd: eBSize];
RETURN
END; -- of scrow
totalBits: CARDINAL = tOffset.wSize * wordlength + tOffset.bSize;
-- totalBits could overflow, but that would be a very large constructor
fillBits: CARDINAL ← 0;
eWSize: CARDINAL;
eBSize: [0..wordlength);
packed: BOOLEAN ← FALSE;
IF tb[node].attr1 THEN
BEGIN
c ← P5.MoveToCodeWord[];
localstrconst ← globalstrconst ← FALSE;
constrow[tb[node].son[2]];
ConstructCountDown[];
Stack.Dump[]; Stack.Mark[];
P5U.PushLitVal[c];
P5U.PushLitVal[n];
IF localstrconst AND globalstrconst THEN SIGNAL CPtr.CodeNotImplemented;
P5U.Out1[IF localstrconst THEN FOpCodes.qLADRB ELSE FOpCodes.qGADRB,0];
[] ← LoadPointer[0];
IF cd.pLength # 1 THEN -- does a long pointer to array of short strings
SIGNAL CPtr.CodeNotImplemented; -- make any sense?
P5.SysCall[SDDefs.sStringInit];
RETURN
END;
WITH a: seb[asei] SELECT FROM
array =>
BEGIN
grain: [0..16);
csei ← UnderType[a.componentType];
IF a.oldPacked THEN
BEGIN
SELECT SymbolOps.BitsForType[a.componentType] FROM
1 => grain ← 1;
2 => grain ← 2;
3,4 => grain ← 4;
5,6,7,8 => grain ← 8;
ENDCASE => GO TO not;
grain ← 8; -- *************** until after 6.0c bootstrap
packed ← TRUE;
-- change test when partial word packed arrays happen
fillBits ← totalBits - Cardinality[UnderType[a.indexType]]*grain;
IF fillBits # 0 THEN cd.remaining ← cd.remaining+1;
eWSize ← 0; eBSize ← grain;
EXITS
not => packed ← FALSE;
END
ELSE packed ← FALSE;
IF ~packed THEN
BEGIN
eBSize ← 0; eWSize ← SymbolOps.WordsForType[a.componentType];
END;
END;
ENDCASE => P5.P5Error[580];
TreeOps.ScanList[tb[node].son[2], scrow];
IF fillBits # 0 THEN
BEGIN
IF fillBits >= wordlength THEN SIGNAL ConstructionError;
offset.wSize ← 0;
offset.bSize ← fillBits;
ConstructCountDown[];
ConsAssign[@offset, MPtr.tC0];
END;
RETURN
END;
MainConstruct: PROCEDURE [
maint: Tree.Link,
rsei: CSEIndex,
fa: PROCEDURE[ISEIndex] RETURNS [BitAddress, CARDINAL],
atO: POINTER TO READONLY frame VarComponent,
fieldsei: ISEIndex ← ISENull] =
BEGIN -- workhorse subroutine for construction in memory
tOffset: frame VarComponent = atO↑;
totalBits: CARDINAL = tOffset.wSize * wordlength + tOffset.bSize;
more: BOOLEAN ← TRUE;
rcsei: RecordSEIndex;
ssmc: PROCEDURE [root: Tree.Link] =
BEGIN
offset: frame VarComponent;
rep: BitAddress;
res: CARDINAL;
node: Tree.Index;
iscontrolled: BOOLEAN ← FALSE;
BEGIN -- to set up label "done"
IF root # Tree.Null THEN
BEGIN
[rep, res] ← fa[fieldsei];
offset ← tOffset;
P5L.FieldOfComponent[var: @offset, wd: rep.wd, bd: rep.bd,
wSize: res / wordlength, bSize: res MOD wordlength];
IF fa # FnField AND totalBits <= wordlength THEN
P5L.AdjustComponent[
var: @offset, rSei: rcsei, fSei: fieldsei, tBits: totalBits];
DO -- until we get to something interesting
WITH root SELECT FROM
subtree =>
SELECT tb[index].name FROM
pad =>
BEGIN
eWords: CARDINAL;
root ← tb[index].son[1]; -- note the variant may change here
eWords ← P5U.WordsForOperand[root];
offset.wSize ← eWords; offset.bSize ← 0;
END;
cast => root ← tb[index].son[1];
ENDCASE => EXIT;
ENDCASE => EXIT;
ENDLOOP;
WITH root SELECT FROM
subtree =>
BEGIN
node ← index;
SELECT tb[node].name FROM
construct =>
BEGIN
MainConstruct[tb[node].son[2], P5U.OperandType[root],
P5U.FieldAddress, @offset];
GOTO done
END;
union =>
BEGIN
UnionConstruct[node, rcsei, atO];
GO TO done
END;
rowcons =>
BEGIN
Row[node, UnderType[seb[fieldsei].idType], @offset];
GO TO done
END;
all =>
BEGIN
AllConstruct[node, @offset];
GO TO done;
END;
ENDCASE;
END;
ENDCASE;
ConstructCountDown[];
ConsAssign[@offset, root];
END; -- IF root # Tree.Null
EXITS
done => NULL;
END;
fieldsei ← P5U.NextVar[NextSe[fieldsei]];
RETURN
END; -- of ssmc
IF fieldsei = ISENull THEN
WITH seb[rsei] SELECT FROM
record =>
BEGIN
rcsei ← RecordRoot[LOOPHOLE[rsei]];
fieldsei ← P5U.NextVar[ctxb[seb[rcsei].fieldCtx].seList];
END;
ENDCASE => P5.P5Error[589]
ELSE rcsei ← LOOPHOLE[rsei];
TreeOps.ScanList[maint, ssmc];
RETURN
END; -- of MainConstruct
UnionConstruct: PROCEDURE [
node: Tree.Index,
rootSei: RecordSEIndex,
atO: POINTER TO READONLY frame VarComponent] =
BEGIN -- construct a union part, atO↑ is offset of beginning of record
tOffset: frame VarComponent = atO↑;
offset: frame VarComponent ← tOffset;
fieldsei: ISEIndex;
constctx: CTXIndex;
usei: CSEIndex = tb[node].info;
rcsei: RecordSEIndex;
tsei: ISEIndex;
iscontrolled: BOOLEAN;
tagvalue: CARDINAL;
tBits: CARDINAL = tOffset.wSize * wordlength + tOffset.bSize;
WITH seb[usei] SELECT FROM
union =>
BEGIN
iscontrolled ← controlled;
IF iscontrolled THEN
BEGIN
tagAddr: BitAddress ← seb[tagSei].idValue;
tagSize: [0..wordlength] ← seb[tagSei].idInfo;
P5L.FieldOfComponent[
var: @offset, wd: tagAddr.wd, bd: tagAddr.bd,
wSize: tagSize / wordlength,
bSize: tagSize MOD wordlength];
IF tBits <= wordlength THEN
P5L.AdjustComponent[
var: @offset, rSei: rootSei, fSei: tagSei,
tBits: tBits];
END;
END;
ENDCASE => ERROR;
WITH tb[node].son[1] SELECT FROM
symbol => tsei ← index;
ENDCASE => P5.P5Error[583];
tagvalue ← seb[tsei].idValue;
rcsei ← LOOPHOLE[UnderType[tsei], RecordSEIndex];
constctx ← seb[rcsei].fieldCtx;
fieldsei ← P5U.NextVar[ctxb[constctx].seList];
IF iscontrolled THEN
BEGIN
IF fieldsei # ISENull AND seb[fieldsei].idCtx # constctx THEN
BEGIN -- a dummy fill field
fillSize: [0..wordlength) ← seb[fieldsei].idInfo;
b: CARDINAL ← offset.bSize+fillSize;
tagvalue ← InlineDefs.BITSHIFT[tagvalue, fillSize];
offset.bSize ← b MOD wordlength;
offset.wSize ← b / wordlength;
fieldsei ← P5U.NextVar[NextSe[fieldsei]];
END;
ConstructCountDown[];
ConsAssign[@offset, P5U.MakeTreeLiteral[tagvalue]];
END
ELSE IF fieldsei # ISENull AND seb[fieldsei].idCtx # constctx THEN
BEGIN -- no tag, but a fill field anyway
fillSize: [0..wordlength) ← seb[fieldsei].idInfo;
fillAddr: BitAddress ← seb[fieldsei].idValue; -- can't be full word
P5L.FieldOfComponent[
var: @offset, wd: fillAddr.wd,
bd: fillAddr.bd, bSize: fillSize];
IF tBits <= wordlength THEN
P5L.AdjustComponent[
var: @offset, rSei: rootSei, fSei: fieldsei,
tBits: tBits];
ConsAssign[@offset, MPtr.tC0];
fieldsei ← P5U.NextVar[NextSe[fieldsei]];
END;
IF fieldsei # ISENull THEN
MainConstruct[
tb[node].son[2], rootSei, P5U.FieldAddress, atO, fieldsei];
RETURN
END;
AllConstruct: PROCEDURE [
node: Tree.Index,
atO: POINTER TO READONLY frame VarComponent] =
BEGIN
asei: CSEIndex = tb[node].info;
csei: CSEIndex; -- element type
t1: Tree.Link ← tb[node].son[1];
tOffset: frame VarComponent = atO↑;
offset: frame VarComponent ← tOffset;
totalBits: CARDINAL = tOffset.wSize * wordlength + tOffset.bSize;
-- totalBits could overflow, should probably use LONG CARD
fillBits: CARDINAL ← 0;
eCount, owd: CARDINAL;
eWSize: CARDINAL;
eBSize: [0..wordlength);
packed: BOOLEAN ← FALSE;
grain: [0..16);
bWords, e2Offset: CARDINAL;
WITH a: seb[asei] SELECT FROM
array =>
BEGIN
csei ← UnderType[a.componentType];
IF a.oldPacked THEN
BEGIN
SELECT SymbolOps.BitsForType[a.componentType] FROM
1 => grain ← 1;
2 => grain ← 2;
3,4 => grain ← 4;
5,6,7,8 => grain ← 8;
ENDCASE => GO TO not;
packed ← TRUE;
grain ← 8; -- *************** until after 6.0c bootstrap
-- rethink fillBits when partial word packed arrays happen
eCount ← Cardinality[UnderType[a.indexType]];
fillBits ← totalBits - eCount*grain;
IF fillBits # 0 THEN cd.remaining ← cd.remaining+1;
eWSize ← 0; eBSize ← grain;
EXITS
not => packed ← FALSE;
END
ELSE packed ← FALSE;
IF ~packed THEN
BEGIN
eBSize ← 0; eWSize ← SymbolOps.WordsForType[a.componentType];
END;
END;
ENDCASE => ERROR;
P5L.FieldOfComponent[var: @offset, wSize: eWSize, bSize: eBSize];
DO -- until we get to something interesting
WITH t1 SELECT FROM
subtree =>
BEGIN
node1: Tree.Index = index;
SELECT tb[node1].name FROM
pad =>
BEGIN
eWords: CARDINAL;
t1 ← tb[node1].son[1]; -- note the variant may change here
eWords ← P5U.WordsForOperand[t1];
offset.wSize ← eWords; offset.bSize ← 0;
END;
cast => t1 ← tb[node1].son[1];
ENDCASE => EXIT;
END;
ENDCASE => EXIT;
ENDLOOP;
IF ~packed THEN
BEGIN
IF tOffset.wSize > eWSize THEN
cd.remaining ← cd.remaining + 1; -- so only pointer isn't lost
BEGIN -- to set up label "done"
WITH t1 SELECT FROM
subtree =>
BEGIN
node1: Tree.Index = index;
SELECT tb[node1].name FROM
construct =>
BEGIN
MainConstruct[tb[node1].son[2], P5U.OperandType[t1],
P5U.FieldAddress, @offset];
GO TO done
END;
rowcons =>
BEGIN
Row[node, csei, @offset];
GO TO done
END;
all =>
BEGIN
AllConstruct[node, @offset];
GO TO done
END;
ENDCASE;
END;
ENDCASE;
ConstructCountDown[];
ConsAssign[@offset, tb[node].son[1]]; -- set first element
EXITS
done => NULL;
END;
e2Offset ← eWSize;
END
ELSE -- packed case
BEGIN
-- for bootstraping purposes, deal only with word aligned
ePerWord: CARDINAL = wordlength/grain;
val: VarComponent ← P5L.ComponentForLex[P5.Exp[t1]];
val ← P5L.EasilyLoadable[val, load]; -- could only clober with self
THROUGH [0..MIN[ePerWord, eCount]) DO
ConsAssign[@offset, Tree.Null, [bdo[P5L.OVarItem[val]]]];
P5L.ModComponent[var: @offset, bd: eBSize];
ENDLOOP;
e2Offset ← 1;
END;
bWords ← tOffset.wSize - e2Offset; -- assumes tOffset.wSize >= 1
IF bWords = 0 THEN RETURN;
owd ← LoadPointer[tOffset.wd]; -- load address of first element
IF ~(cd.inFrame OR cd.pLink OR cd.pLevel # lZ) THEN
BEGIN -- we need to load at least twice, save in temp
tvar: VarComponent ← Stack.TempStore[cd.pLength];
P5L.LoadComponent[tvar]; -- load it back
WITH vv: tvar SELECT FROM
frame => BEGIN cd.pLevel ← vv.level; cd.pOffset ← vv.wd; END;
ENDCASE => ERROR;
END;
cd.pLoaded ← FALSE; -- cd.pSti was maybe invalid anyway
IF owd # 0 THEN P5L.GenAdd[owd, cd.pLength # 1];
ConstructCountDown[];
IF cd.pLength = 1 THEN -- otherwise stack gets too full
P5U.Out1[FOpCodes.qLI, bWords];
owd ← LoadPointer[tOffset.wd + e2Offset]; -- load address of second
IF (cd.remaining # 0 AND
~(cd.inFrame OR cd.pLink OR cd.pLevel # lZ)) THEN
BEGIN -- still needed, save in temp
tvar: VarComponent ← Stack.TempStore[cd.pLength];
P5L.LoadComponent[tvar]; -- load it back
WITH vv: tvar SELECT FROM
frame => BEGIN cd.pLevel ← vv.level; cd.pOffset ← vv.wd; END;
ENDCASE => ERROR;
END;
cd.pLoaded ← FALSE; -- cd.pSti was maybe invalid anyway
IF owd # 0 THEN P5L.GenAdd[owd, cd.pLength # 1];
IF cd.pLength # 1 THEN
BEGIN -- we almost certainly had to add something
-- so this is not as awful as it seems
tvar: VarComponent ← Stack.TempStore[2];
P5U.Out1[FOpCodes.qLI, bWords];
P5L.LoadComponent[tvar];
END;
BEGIN -- to define BltOp
BltOp: ARRAY [1..2] OF BYTE = [FOpCodes.qBLT, FOpCodes.qBLTL];
P5U.Out0[BltOp[cd.pLength]];
END;
IF fillBits # 0 THEN
BEGIN
usedBits: CARDINAL = eCount * grain;
offset ← tOffset;
P5L.FieldOfComponent[var: @offset, wd: usedBits / wordlength,
bd: usedBits MOD wordlength, bSize: fillBits];
ConstructCountDown[];
ConsAssign[@offset, MPtr.tC0];
END;
END;
ConstructExp: PUBLIC PROCEDURE [t: Tree.Link, node: Tree.Index]
RETURNS [Lexeme] =
BEGIN
-- generate code for constructor expression
r, rr: VarIndex;
tsei: RecordSEIndex;
wa: BOOLEAN ← FALSE;
fa: PROCEDURE [ISEIndex] RETURNS [BitAddress, CARDINAL];
saveCd: ConsDestination = cd;
offset: frame VarComponent;
nwords: CARDINAL;
packedDest: VarIndex ← VarNull;
tsei ← LOOPHOLE[tb[node].info, RecordSEIndex];
nwords ← WordsForType[tsei];
wa ← P5U.WordAligned[tsei];
IF t = Tree.Null AND wa AND nwords <= MaxParmsInStack THEN
BEGIN -- can build in stack
P5.ConstructOnStack[tb[node].son[2], tsei];
RETURN[P5L.TOSLex[nwords]];
END;
cd ← [ignoreSafen: t = Tree.Null OR t.tag = symbol]; -- + many defaults
tb[node].son[2] ← TreeOps.UpdateList[tb[node].son[2], CountDups];
r ← P5L.VarForLex[IF t = Tree.Null THEN P5.GenTempLex[nwords]
ELSE P5.Exp[t]];
WITH cc: cb[r] SELECT FROM
ind => WITH cc SELECT FROM
packed =>
BEGIN
var: VarComponent;
packedDest ← r;
var ← P5L.ComponentForLex[P5.GenTempLex[1]];
r ← P5L.OVarItem[var];
END;
ENDCASE;
ENDCASE;
rr ← SetConsDest[r, TRUE];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
fa ← IF seb[tsei].argument THEN SymbolOps.FnField ELSE P5U.FieldAddress;
MainConstruct[tb[node].son[2], tsei, fa, @offset];
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
IF packedDest # VarNull THEN
[] ← P5L.VarVarAssign[packedDest, P5L.CopyVarItem[rr], FALSE];
cd ← saveCd;
RETURN [[bdo[rr]]];
END;
TransferConstruct: PUBLIC PROCEDURE [lex: Lexeme, t: Tree.Link, tsei: CSEIndex] =
BEGIN -- generate code for construct statement
-- lex is TOSAddrLex for allocated large parameter record
saveCd: ConsDestination = cd;
offset: frame VarComponent;
cd ← [ignoreSafen: t.tag = symbol]; -- + many defaults
t ← TreeOps.UpdateList[t, CountDups];
IF cd.remaining = 0 THEN RETURN;
[] ← SetConsDest[P5L.VarForLex[lex], FALSE];
cd.remaining ← cd.remaining + 1;
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
MainConstruct[t, tsei, SymbolOps.FnField, @offset];
[] ← LoadPointer[0];
cd ← saveCd;
RETURN
END;
Construct: PUBLIC PROCEDURE [t: Tree.Link, node: Tree.Index] =
BEGIN -- generate code for construct statement
tsei: RecordSEIndex;
r, rr: VarIndex;
saveCd: ConsDestination = cd;
offset: frame VarComponent;
fa: PROCEDURE [ISEIndex] RETURNS [BitAddress, CARDINAL];
packedDest: VarIndex ← VarNull;
cd ← [ignoreSafen: t.tag = symbol]; -- + many defaults
tb[node].son[2] ← TreeOps.UpdateList[tb[node].son[2], CountDups];
IF cd.remaining = 0 THEN RETURN;
tsei ← LOOPHOLE[tb[node].info];
fa ← IF seb[tsei].argument THEN SymbolOps.FnField ELSE P5U.FieldAddress;
r ← P5L.VarForLex[P5.Exp[t]];
WITH cc: cb[r] SELECT FROM
ind => WITH cc SELECT FROM
packed =>
BEGIN
var: VarComponent;
packedDest ← r;
var ← P5L.ComponentForLex[P5.GenTempLex[1]];
r ← P5L.OVarItem[var];
END;
ENDCASE;
ENDCASE;
rr ← SetConsDest[r, packedDest # VarNull];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
MainConstruct[tb[node].son[2], tsei, fa, @offset];
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
IF packedDest # VarNull THEN
[] ← P5L.VarVarAssign[packedDest, rr, FALSE];
cd ← saveCd;
RETURN
END;
VariantConstruct: PUBLIC PROCEDURE [node: Tree.Index] =
BEGIN -- generate code for construct statement
r: VarIndex;
saveCd: ConsDestination = cd;
offset: frame VarComponent;
t1: Tree.Link ← tb[node].son[1];
rootSei: RecordSEIndex;
WITH t1 SELECT FROM
subtree => t1 ← tb[index].son[1]; -- always a dollar node
ENDCASE => P5.P5Error[592];
cd ← [ignoreSafen: t1.tag = symbol]; -- + many defaults
tb[node].son[2] ← TreeOps.UpdateList[tb[node].son[2], CountDups];
IF cd.remaining = 0 THEN RETURN;
rootSei ← SymbolOps.RecordRoot[LOOPHOLE[P5U.OperandType[t1]]];
r ← P5L.VarForLex[P5.Exp[t1]];
WITH cc: cb[r] SELECT FROM
ind => WITH cc SELECT FROM
packed => SIGNAL CPtr.CodeNotImplemented;
ENDCASE;
ENDCASE;
[] ← SetConsDest[r, FALSE];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
WITH tb[node].son[2] SELECT FROM
subtree => UnionConstruct[index, rootSei, @offset];
ENDCASE;
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
cd ← saveCd;
RETURN
END;
All: PUBLIC PROCEDURE [t: Tree.Link, node: Tree.Index] =
BEGIN -- array initialization
r: VarIndex;
saveCd: ConsDestination = cd; -- necessary in an inline
offset: frame VarComponent;
asei: Symbols.ArraySEIndex = tb[node].info;
cd ← [ignoreSafen: t.tag = symbol]; -- + many defaults
IF seb[asei].oldPacked AND
SymbolOps.BitsForType[seb[asei].componentType] <= 8 THEN
cd.remaining ← 1
ELSE tb[node].son[1] ← TreeOps.UpdateList[tb[node].son[1], CountDups];
r ← P5L.VarForLex[P5.Exp[t]];
[] ← SetConsDest[r, FALSE];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
AllConstruct[node, @offset];
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
cd ← saveCd;
RETURN
END;
AllExp: PUBLIC PROCEDURE [t: Tree.Link, node: Tree.Index]
RETURNS [Lexeme] =
BEGIN -- array (expression)initialization
r, rr: VarIndex;
saveCd: ConsDestination = cd;
offset: frame VarComponent;
awords: CARDINAL = WordsForType[tb[node].info];
asei: Symbols.ArraySEIndex = tb[node].info;
cd ← [ignoreSafen: t = Tree.Null OR t.tag = symbol]; -- + many defaults
IF seb[asei].oldPacked AND
SymbolOps.BitsForType[seb[asei].componentType] <= 8 THEN
cd.remaining ← 1
ELSE tb[node].son[1] ← TreeOps.UpdateList[tb[node].son[1], CountDups];
r ← P5L.VarForLex[IF t = Tree.Null THEN P5.GenTempLex[awords]
ELSE P5.Exp[t]];
rr ← SetConsDest[r, TRUE];
offset ← [wSize: cd.wSize, bSize: cd.bSize, space: frame[]];
AllConstruct[node, @offset];
IF cd.remaining # 0 THEN SIGNAL ConstructionError;
cd ← saveCd;
RETURN[[bdo[rr]]]
END;
END.