DIRECTORY
Alloc USING [Notifier],
Basics USING [BITOR, BITLSHIFT, BITRSHIFT, LowHalf],
ConstArith USING [Add, Compare, Const, Div, FromCard, FromInt, Mul, Overflow, Sub, ToCard],
Host: TYPE MachineParms USING [bitsPerAU, bitsPerByte],
LiteralOps USING [FindCard, MasterString, StringValue],
MimData USING [checks, idCARDINAL, idCHAR, idINTEGER, ownSymbols, switches],
MimosaLog USING [Error, ErrorN, ErrorTree, ErrorType, WarningTree],
MimP4 USING [AdjustBias, Attr, Bias, BiasForType, BitsForType, CanonicalType, CatchNest, checked, CheckSign, ClearType, CommonProp, ConsState, Covering, emptyProp, Exp, ForceType, fullProp, implicit, ImplicitRecord, MakeStructuredCard, MakeTreeLiteralCard, MakeTreeLiteralInt, MaxCardinality, NeutralExp, nullBias, OperandType, Prop, RepForType, Repr, RValue, SetSubInfo, StructuredLiteral, Subst, TreeBounds, TreeLiteral, TreeLiteralConst, TypeExp, TypeForTree, VAttr, VBias, voidAttr, voidProp, VPop, VProp, VPush, VRep, VSetTop, WordsForType],
SymbolOps USING [ArgRecord, BitsPerElement, Cardinality, DecodeBitAddr, DecodeCard, EqTypes, FirstCtxSe, FirstVisibleSe, FnField, FromType, NextSe, NormalType, own, RCType, RecordRoot, ReferentType, ToType, TypeForm, UnderType, VariantField],
Symbols USING [ArraySEIndex, Base, BitAddress, BitCount, CSEIndex, CTXIndex, ISEIndex, ISENull, RecordSEIndex, RecordSENull, seType, Type, typeANY, TypeClass, UNSPEC],
Target: TYPE MachineParms USING [bitsPerByte, bitsPerLongWord, bitsPerWord, logBitsPerWord],
Tree USING [Base, Index, Link, Map, NodeName, NodePtr, Null, Scan, treeType],
TreeOps USING [FreeNode, FreeTree, GetNode, GetSe, GetTag, ListLength, NthSon, OpName, PopTree, PushNode, PushTree, ScanList, SetAttr, SetAttrs, SetInfo, UpdateList],
Types USING [Assignable];
Bias: TYPE = MimP4.Bias;
bitsPerByte: NAT = Target.bitsPerByte;
bitsPerWord: NAT = Target.bitsPerWord;
bitsPerHostUnit: NAT = SIZE[Symbols.UNSPEC] * Host.bitsPerAU;
bytesPerHostUnit: NAT = bitsPerHostUnit * Host.bitsPerByte;
maxBits: Symbols.BitCount = Symbols.BitCount.LAST;
logBitsPerWord: NAT = Target.logBitsPerWord;
Type: TYPE = Symbols.Type;
ISEIndex: TYPE = Symbols.ISEIndex;
CSEIndex: TYPE = Symbols.CSEIndex;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
BitAddress: TYPE = Symbols.BitAddress;
BitCount: TYPE = Symbols.BitCount;
WordOffset:
PROC [offset: BitAddress]
RETURNS [BitCount] =
INLINE {
RETURN [Basics.BITRSHIFT[offset.bd, logBitsPerWord]];
};
BitOffset:
PROC [offset: BitAddress]
RETURNS [
CARD] =
INLINE {
RETURN [Basics.LowHalf[offset.bd] MOD bitsPerWord];
};
EncodeBitAddress:
PROC [wd: BitCount, bd: BitCount]
RETURNS [BitAddress] =
INLINE {
RETURN [[bd: Basics.BITLSHIFT[wd, logBitsPerWord] + bd]];
};
OperandStruct:
PUBLIC
PROC [t: Tree.Link, clear:
BOOL]
RETURNS [CSEIndex] = {
csei: CSEIndex ¬ SymbolOps.UnderType[SymbolOps.own, OperandType[t]];
IF clear THEN csei ¬ ClearType[csei];
RETURN [csei];
};
SetType:
PUBLIC
PROC [type: Type] = {
SetInfo[SymbolOps.FromType[type]];
};
UnbiasedOffset:
PUBLIC
PROC [type: Type]
RETURNS [
INT] = {
ut: Symbols.CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH se: seb[ut]
SELECT
FROM
subrange => {
range: Symbols.CSEIndex = SymbolOps.UnderType[SymbolOps.own, se.rangeType];
IF
NOT se.biased
AND se.origin < 0
THEN
The origin is given here
RETURN [se.origin];
};
ENDCASE;
RETURN [0];
};
earlyCheck: BOOL ¬ TRUE;
Substx:
PUBLIC
PROC [node: Tree.Index]
RETURNS [val: Tree.Link] = {
type: Type = SymbolOps.ToType[tb[node].info];
IF earlyCheck
AND OpName[tb[node].son[2]] = result
THEN {
saveChecked: BOOL = checked;
subNode: Tree.Index = GetNode[tb[node].son[2]];
IF ~tb[node].attr3 THEN checked ¬ tb[node].attr1;
tb[node].son[1] ¬ NeutralExp[tb[node].son[1]];
SELECT ListLength[tb[subNode].son[1]]
FROM
0 => ERROR;
1 => val ¬ ForceType[tb[subNode].son[1], type];
ENDCASE => {
PushTree[Tree.Null]; PushTree[tb[subNode].son[1]];
PushNode[construct, 2]; SetType[type]; val ¬ PopTree[];
};
tb[subNode].son[1] ¬ Tree.Null;
FreeNode[node];
val ¬ Rhs[val, type, $init];
checked ¬ saveChecked;
}
ELSE {
val ¬ Subst[node];
IF TreeOps.OpName[val] = substx
THEN {
rLink: Tree.Link ¬ TreeOps.NthSon[val, 2];
IF TreeOps.OpName[rLink] = list
THEN {
We are looking for a list of constant declarations, followed by a result.
lNode: Tree.Index = TreeOps.GetNode[rLink];
lastIndex: NAT = tb[lNode].nSons;
IF lastIndex >= 1
THEN {
FOR i:
NAT
IN [1..lastIndex)
DO
son: Tree.Link = tb[lNode].son[i];
IF TreeOps.OpName[son] = decl
THEN {
id: Tree.Link = TreeOps.NthSon[son, 1];
WITH e: id
SELECT TreeOps.GetTag[id]
FROM
symbol => {
The only declarations we allow to be simple are those that declarae identifiers that have been processed into constants.
sei: ISEIndex = e.index;
IF seb[sei].constant THEN LOOP;
};
ENDCASE;
};
GO TO notSimple;
ENDLOOP;
rLink ¬ tb[lNode].son[lastIndex];
};
};
IF TreeOps.OpName[rLink] = block
THEN {
Any gratuitous blocks get reduced to the last node
bNode: Tree.Index = TreeOps.GetNode[rLink];
IF tb[bNode].nSons = 2
AND tb[bNode].son[1] = Tree.Null
THEN
rLink ¬ tb[bNode].son[2];
};
IF TreeOps.OpName[rLink] = result
THEN {
At this point we can use the result directly. Note that Pass4 processing has already been performed for this tree, so we should not do it again.
rNode: Tree.Index = TreeOps.GetNode[rLink];
val ¬ tb[rNode].son[1];
tb[rNode].son[1] ¬ Tree.Null;
SELECT ListLength[val]
FROM
0 => ERROR;
1 => val ¬ ForceType[val, type];
ENDCASE => {
An argument record constructor
PushTree[Tree.Null];
PushTree[val];
PushNode[construct, 2];
SetType[type];
val ¬ PopTree[];
};
};
EXITS notSimple => {};
};
VPush[BiasForType[type], [prop: emptyProp, rep: RepForType[type]]];
};
};
Call:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
son1: Tree.Link = tb[node].son[1] ¬ Exp[tb[node].son[1], none];
son2: Tree.Link ¬ tb[node].son[2];
type: CSEIndex ¬ OperandStruct[son1, TRUE];
prop: Prop ¬ VProp[];
VPop[];
WITH t: seb[type]
SELECT
FROM
transfer => {
IF tb[node].attr1
AND tb[node].name # xerror
AND t.typeIn # Symbols.RecordSENull
THEN son2 ¬ Rhs[son2, t.typeIn, $init]
ELSE son2 ¬ MakeArgRecord[SymbolOps.ArgRecord[SymbolOps.own, t.typeIn], son2];
tb[node].son[2] ¬ son2;
prop ¬ CommonProp[prop, VProp[]]; VPop[];
prop.noXfer ¬ prop.noAssign ¬ prop.noFreeVar ¬ FALSE;
IF tb[node].nSons > 2 THEN CatchNest[tb[node].son[3]];
VPush[BiasForType[t.typeOut], [prop: prop, rep: RepForType[t.typeOut]]];
};
ENDCASE => ERROR;
RETURN [[subtree[index: node]]];
};
Construct:
PUBLIC
PROC [node: Tree.Index, cs: ConsState]
RETURNS [Tree.Link] = {
type: RecordSEIndex = LOOPHOLE[SymbolOps.UnderType[SymbolOps.own, SymbolOps.ToType[tb[node].info]]];
record: RecordSEIndex = SymbolOps.RecordRoot[SymbolOps.own, type];
prop: Prop;
son2: Tree.Link ¬ tb[node].son[2];
name: Tree.NodeName = OpName[son2];
val: Tree.Link ¬ [subtree[index: node]];
SELECT
TRUE
FROM
name = list => {
subNode: Tree.Index;
son2 ¬ tb[node].son[2] ¬ MakeRecord[record, son2, cs];
prop ¬ VProp[];
subNode ¬ GetNode[son2];
tb[node].attr3 ¬ tb[subNode].attr3;
SELECT
TRUE
FROM
tb[subNode].attr1
AND MimP4.BitsForType[type] <= bitsPerWord
AND type = record
AND
NOT seb[type].hints.variant => {
This is a very simple little constant record, we hope
ENABLE NotSimple => GO TO notSimple;
val ¬ PackRecord[type, son2];
FreeNode[node];
EXITS notSimple => {};
};
ENDCASE;
VSetTop[MimP4.nullBias, [prop: prop, rep: other], 1];
};
son2 = Tree.Null =>
VPush[MimP4.nullBias, [prop: voidProp, rep: other]];
name = union => {
son2 ¬ tb[node].son[2] ¬ Union[GetNode[son2], cs];
IF OpName[son2] # union
THEN {
val ¬ ForceType[son2, type];
tb[node].son[2] ¬ Tree.Null;
FreeNode[node];
};
};
ENDCASE =>
val ¬ CastUniList[node, type, cs, record];
RETURN [val];
};
Union:
PUBLIC
PROC [node: Tree.Index, cs: ConsState]
RETURNS [Tree.Link] = {
vSei: ISEIndex = GetSe[tb[node].son[1]];
type: RecordSEIndex = LOOPHOLE[SymbolOps.UnderType[SymbolOps.own, vSei]];
tSei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, SymbolOps.ToType[tb[node].info]];
tagged: BOOL = (WITH t: seb[tSei] SELECT FROM union => t.controlled, ENDCASE => FALSE);
son2: Tree.Link ¬ tb[node].son[2];
val: Tree.Link ¬ [subtree[index: node]];
tb[node].attr2 ¬ tagged;
IF son2 = Tree.Null
THEN {
tb[node].attr1 ¬ TRUE;
VPush[MimP4.nullBias, [prop: voidProp, rep: other]];
}
ELSE {
name: Tree.NodeName = OpName[son2];
isLit: BOOL ¬ FALSE;
attr: Attr;
son2 ¬ tb[node].son[2] ¬ MakeRecord[type, son2, cs];
attr ¬ VAttr[];
SELECT name
FROM
list, union =>
WITH e: son2
SELECT GetTag[son2]
FROM
subtree => isLit ¬ tb[e.index].attr1;
ENDCASE;
ENDCASE => isLit ¬ StructuredLiteral[son2];
attr.rep ¬ other;
tb[node].attr1 ¬ isLit;
VSetTop[MimP4.nullBias, attr, 1];
};
RETURN [val];
};
TagSei:
PROC [tSei: CSEIndex]
RETURNS [ISEIndex] =
INLINE {
RETURN [WITH seb[tSei] SELECT FROM union => tagSei, ENDCASE => Symbols.ISENull];
};
ZeroOffset:
PROC [sei: ISEIndex]
RETURNS [
BOOL] =
INLINE {
RETURN [sei # Symbols.ISENull AND SymbolOps.DecodeBitAddr[seb[sei].idValue] = 0]
};
CastUniList:
PROC [node: Tree.Index, type: CSEIndex, cs: ConsState, rType: RecordSEIndex]
RETURNS [Tree.Link] = {
target: Type = seb[SymbolOps.FirstVisibleSe[seb[rType].fieldCtx]].idType;
val: Tree.Link ¬ ForceType[FieldRhs[tb[node].son[2], target, cs], type];
prop: Prop ¬ VProp[];
tb[node].son[2] ¬ Tree.Null;
FreeNode[node];
VSetTop[BiasForType[type], [prop: prop, rep: RepForType[type]], 1];
RETURN [val];
};
RowConstruct:
PUBLIC
PROC [node: Tree.Index, cs: ConsState]
RETURNS [Tree.Link] = {
EvalElement: Tree.Map = {
IF t = Tree.Null
THEN {v ¬ Tree.Null; const ¬ strings ¬ lstrings ¬ FALSE}
ELSE {
v ¬ FieldRhs[t, cType, cs];
IF TreeLiteral[v]
THEN strings ¬ lstrings ¬ FALSE
ELSE
WITH e: v
SELECT GetTag[v]
FROM
subtree =>
SELECT tb[e.index].name
FROM
mwconst => strings ¬ lstrings ¬ FALSE;
ENDCASE => const ¬ strings ¬ lstrings ¬ FALSE;
string => {
const ¬ FALSE;
IF LiteralOps.MasterString[e.index] = e.index
THEN lstrings ¬ FALSE
ELSE strings ¬ FALSE;
};
ENDCASE => const ¬ strings ¬ lstrings ¬ FALSE;
prop ¬ CommonProp[VProp[], prop];
VPop[];
IF cs = $first THEN cs ¬ $rest;
};
};
type: Type = SymbolOps.ToType[tb[node].info];
aType: Symbols.ArraySEIndex = LOOPHOLE[SymbolOps.UnderType[SymbolOps.own, type]];
cType: Type = seb[aType].componentType;
n: CARDINAL = SymbolOps.Cardinality[SymbolOps.own, seb[aType].indexType];
prop: Prop ¬ voidProp;
son2: Tree.Link ¬ tb[node].son[2];
l: CARDINAL = ListLength[son2];
const, strings, lstrings: BOOL ¬ TRUE;
val: Tree.Link ¬ [subtree[index: node]];
SELECT l
FROM
= n => NULL;
> n => MimosaLog.ErrorN[listLong, l-n];
< n => MimosaLog.ErrorN[listShort, n-l];
ENDCASE;
son2 ¬ tb[node].son[2] ¬ UpdateList[son2, EvalElement];
{
IF const
AND l = n
AND n > 0
AND n <= bitsPerWord
THEN {
All constant, no length errors
bits: BitCount = BitsForType[aType];
IF bits <= bitsPerWord
THEN {
ENABLE NotSimple, ConstArith.Overflow => GO TO notSimple;
grain: NAT = bits/n;
accum: CARD ¬ 0;
AccumElement: Tree.Scan = {
IF TreeLiteral[t]
THEN {
c: CARD = ConstArith.ToCard[MimP4.TreeLiteralConst[t]];
IF accum # 0
THEN accum ¬ Basics.
BITLSHIFT[accum, grain];
No shifting when grain = bitsPerWord!
accum ¬ accum + c;
RETURN;
};
ERROR NotSimple;
};
ScanList[tb[node].son[2], AccumElement];
val ¬ MakeStructuredCard[accum, aType];
GO TO wasSimple;
EXITS notSimple => {};
};
};
IF (tb[node].attr1 ¬ strings # lstrings) THEN prop.noFreeVar ¬ FALSE;
EXITS wasSimple => FreeNode[node];
};
VPush[MimP4.nullBias, [prop: prop, rep: other]];
RETURN [val];
};
All:
PUBLIC
PROC [node: Tree.Index, cs: ConsState]
RETURNS [Tree.Link] = {
aType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, SymbolOps.ToType[tb[node].info]];
val: Tree.Link ¬ [subtree[index: node]];
WITH se: seb[aType]
SELECT
FROM
array => {
cType: Type = se.componentType;
prop: Prop ¬ voidProp;
son1: Tree.Link ¬ tb[node].son[1];
IF son1 # Tree.Null
THEN {
aBits: INT = BitsForType[aType];
son1 ¬ tb[node].son[1] ¬ FieldRhs[son1, cType, cs];
IF TreeLiteral[son1]
AND aBits > 0
AND aBits <= bitsPerWord
THEN {
const: ConstArith.Const = MimP4.TreeLiteralConst[son1];
v: CARD = ConstArith.ToCard[const ! ConstArith.Overflow => GO TO oops];
nB: NAT = SymbolOps.BitsPerElement[SymbolOps.own, cType, se.packed];
elements: CARD = SymbolOps.Cardinality[SymbolOps.own, se.indexType];
IF elements <= bitsPerWord
THEN {
w: CARD ¬ v;
THROUGH [1 ..
NAT[elements])
DO
w ¬ Basics.BITOR[Basics.BITLSHIFT[w, nB], v];
ENDLOOP;
val ¬ MakeStructuredCard[w, aType];
FreeNode[node];
};
EXITS oops => {};
}
ELSE
IF OperandType[son1] # cType
THEN
son1 ¬ tb[node].son[1] ¬ ForceType[son1, cType];
prop ¬ VProp[];
VPop[];
};
VPush[MimP4.nullBias, [prop: prop, rep: other]];
};
ENDCASE => ERROR;
RETURN [val];
};
Dot:
PUBLIC
PROC [node: Tree.Index, target: Repr]
RETURNS [Tree.Link] = {
son1: Tree.Link ¬ tb[node].son[1] ¬ RValue[tb[node].son[1], MimP4.nullBias, unsigned];
prop: Prop ¬ VProp[];
son2: Tree.Link ¬ tb[node].son[2] ¬ Exp[tb[node].son[2], target];
attr: Attr ¬ VAttr[];
bias: Bias ¬ VBias[];
prop.noSelect ¬ prop.noFreeVar ¬ FALSE;
attr.prop ¬ CommonProp[attr.prop, prop];
tb[node].attr1 ¬ ~tb[node].attr3 AND (checked OR MimData.switches['n]);
WITH s1: son1
SELECT GetTag[son1]
FROM
string =>
IF LiteralOps.MasterString[s1.index] = s1.index
THEN
a global string literal, so we can assume constancy
WITH s2: son2
SELECT GetTag[son2]
FROM
symbol =>
IF SymbolOps.DecodeBitAddr[seb[s2.index].idValue] = 0
THEN {
This has the form of "...".length, which we can handle!
str: LONG STRING = LiteralOps.StringValue[s1.index];
attr.prop ¬ MimP4.fullProp;
RETURN [[literal[LiteralOps.FindCard[str.length]]]];
};
ENDCASE;
ENDCASE;
CheckTypePortability[SymbolOps.ReferentType[SymbolOps.own, OperandType[son1]], node]; -- fix added 9/22/92 WBT
VSetTop[bias, attr, 2];
RETURN [[subtree[index: node]]];
};
Dollar:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
attr: Attr;
immutable: BOOL;
bias: Bias;
val: Tree.Link ¬ [subtree[node]];
son1: Tree.Link ¬ tb[node].son[1];
son2: Tree.Link ¬ tb[node].son[2];
son1 ¬ tb[node].son[1] ¬ RValue[son1, BiasForType[OperandType[son1]], none];
attr.prop ¬ VProp[];
immutable ¬ attr.prop.immutable;
son2 ¬ tb[node].son[2] ¬ Exp[son2, none];
attr.rep ¬ VRep[];
bias ¬ VBias[];
CheckTypePortability[OperandType[son1], node];
{
WITH e: son1
SELECT GetTag[son1]
FROM
subtree => {
tp: Tree.NodePtr ¬ @tb[e.index];
SELECT tp.name
FROM
construct =>
IF tp.son[1] = Tree.Null
THEN {
ut: CSEIndex = ClearType[SymbolOps.ToType[tp.info]];
first: Tree.Link ¬ tp.son[2];
SELECT TreeOps.OpName[first]
FROM
list => tp ¬ @tb[TreeOps.GetNode[first]];
union =>
GO
TO done;
We can't handle this right now
ENDCASE => {val ¬ first;
GO
TO done};
In this simple case there is only one possibility.
IF seb[ut].typeTag = record
THEN {
At this point we have to find out which element the name refers to, since there may be more than one possibility.
rSei: RecordSEIndex = LOOPHOLE[ut];
ctx: Symbols.CTXIndex = seb[rSei].fieldCtx;
i: NAT ¬ 1;
n: NAT = tp.nSons;
FOR isei: Symbols.ISEIndex ¬ SymbolOps.FirstVisibleSe[ctx],
SymbolOps.NextSe[SymbolOps.own, isei]
WHILE isei # Symbols.ISENull
AND i <= n
DO
IF son2 = [symbol[isei]] THEN {val ¬ tp[i]; GO TO done};
i ¬ i + 1;
ENDLOOP;
};
};
ENDCASE;
};
ENDCASE;
IF StructuredLiteral[son1]
THEN {
val ¬ UnpackField[son1, GetSe[son2]];
IF val # son1 THEN FreeNode[node];
}
ELSE {
attr.prop ¬ CommonProp[attr.prop, VProp[]];
attr.prop.noSelect ¬ FALSE;
attr.prop.immutable ¬ immutable;
};
EXITS done => {};
};
VSetTop[bias, attr, 2];
RETURN [val];
};
Index:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
iType, cType: Type;
next: Type;
son1: Tree.Link ¬ tb[node].son[1] ¬ Exp[tb[node].son[1], none];
son2: Tree.Link ¬ tb[node].son[2];
unsafeOp: BOOL ¬ FALSE;
prop: Prop ¬ VProp[];
noSelect: BOOL ¬ FALSE;
immutable: BOOL ¬ prop.immutable;
val: Tree.Link ¬ [subtree[node]];
bias: Bias;
checked: BOOL = MimP4.checked;
aType: CSEIndex;
boundsCheck: BOOL ¬ checked OR MimData.switches['b];
FOR aType ¬ OperandStruct[son1,
TRUE], MimP4.ClearType[next]
DO
WITH se: seb[aType]
SELECT
FROM
array => {iType ¬ se.indexType; cType ¬ se.componentType; EXIT};
arraydesc => {next ¬ se.describedType; unsafeOp ¬ TRUE};
ENDCASE => ERROR;
ENDLOOP;
bias ¬ BiasForType[iType];
IF
NOT IsBoundedArray[aType]
THEN {
Caution, unbounded arrays do not get bounds checked.
unsafeOp ¬ TRUE;
boundsCheck ¬ FALSE;
IF
NOT checked
AND MimData.checks['i]
THEN
MimosaLog.WarningTree[unsafeOperation, val];
};
SELECT
TRUE
FROM
BitsForType[cType] > maxBits => MimosaLog.ErrorTree[operandSize, val];
checked AND unsafeOp => MimosaLog.ErrorTree[unsafeOperation, val];
ENDCASE;
IF tb[node].name = dindex
THEN {
son2 ¬ tb[node].son[2] ¬ RValue[son2, bias, unsigned];
tb[node].attr1 ¬ checked OR MimData.switches['n];
tb[node].attr3 ¬ checked OR MimData.switches['b];
}
ELSE {
IF boundsCheck
THEN son2 ¬ tb[node].son[2] ¬ Rhs[son2, iType, $init]
ELSE son2 ¬ tb[node].son[2] ¬ RValue[son2, bias, unsigned];
IF TreeLiteral[son2]
THEN {
SELECT OpName[son1]
FROM
all => {
subNode: Tree.Index = TreeOps.GetNode[son1];
val ¬ tb[subNode].son[1];
tb[subNode].son[1] ¬ Tree.Null;
GO TO folded;
};
rowcons => {
ENABLE ConstArith.Overflow => GO TO noFold;
c: CARD ¬ ConstArith.ToCard[MimP4.TreeLiteralConst[son2]];
row: Tree.Index = GetNode[son1];
elem: Tree.Link ¬ tb[row].son[2];
IF c >= NAT.LAST THEN GO TO noFold;
SELECT ListLength[elem]
FROM
<= NAT[c] => GO TO noFold;
ENDCASE => IF OpName[elem] = list THEN elem ¬ NthSon[elem, c+1];
IF elem = Tree.Null THEN GO TO noFold;
val ¬ elem;
tb[row].son[2] ¬ Tree.Null;
GO TO folded;
};
ENDCASE =>
IF StructuredLiteral[son1]
THEN {
ENABLE ConstArith.Overflow => GO TO noFold;
c: CARD ¬ ConstArith.ToCard[MimP4.TreeLiteralConst[son2]];
val ¬ UnpackElement[son1, c];
GO TO folded;
};
};
EXITS
noFold => {};
folded => {
noSelect ¬ prop.noSelect;
FreeNode[node];
};
};
prop ¬ CommonProp[prop, VProp[]];
prop.noSelect ¬ noSelect;
prop.immutable ¬ immutable;
VSetTop[BiasForType[cType], [prop: prop, rep: RepForType[cType]], 2];
RETURN [val];
};
SeqIndex:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
iType, cType: Type;
son1: Tree.Link ¬ tb[node].son[1] ¬ Exp[tb[node].son[1], none];
son2: Tree.Link ¬ tb[node].son[2];
prop: Prop ¬ VProp[];
sType: CSEIndex ¬ OperandStruct[son1, TRUE];
tree: Tree.Link ¬ [subtree[node]];
unsafeOp: BOOL ¬ FALSE;
checked: BOOL = MimP4.checked;
WITH t: seb[sType]
SELECT
FROM
sequence => {
iType ¬ seb[t.tagSei].idType;
cType ¬ t.componentType;
tb[node].attr3 ¬ t.controlled AND (checked OR MimData.switches['b]);
IF NOT t.controlled AND checked THEN unsafeOp ¬ TRUE;
};
array => {
iType ¬ SymbolOps.UnderType[SymbolOps.own, t.indexType];
cType ¬ SymbolOps.UnderType[SymbolOps.own, t.componentType];
tb[node].attr3 ¬ checked OR MimData.switches['b];
IF
NOT IsBoundedArray[sType]
THEN {
unsafeOp ¬ TRUE;
iType ¬ MimP4.CanonicalType[iType];
};
};
ENDCASE => ERROR;
SELECT
TRUE
FROM
BitsForType[cType] > maxBits => MimosaLog.ErrorTree[operandSize, tree];
unsafeOp AND checked => MimosaLog.ErrorTree[unsafeOperation, tree];
ENDCASE;
son2 ¬ tb[node].son[2] ¬ RValue[son2, BiasForType[iType], RepForType[iType]];
prop ¬ CommonProp[prop, VProp[]];
prop.noSelect ¬ FALSE;
WITH s1: son1
SELECT GetTag[son1]
FROM
subtree =>
IF tb[s1.index].name = dot
THEN {
sub1: Tree.Link = tb[s1.index].son[1];
WITH ss1: sub1
SELECT GetTag[sub1]
FROM
string =>
IF TreeLiteral[son2]
AND LiteralOps.MasterString[ss1.index] = ss1.index
THEN {
a global string literal, so we can assume constancy
str: LONG STRING = LiteralOps.StringValue[ss1.index];
index: ConstArith.Const = MimP4.TreeLiteralConst[son2];
limit: ConstArith.Const = ConstArith.FromCard[str.length];
IF index.sign # negative
AND ConstArith.Compare[index, limit] = less
THEN {
c: NAT = ConstArith.ToCard[index];
prop ¬ MimP4.fullProp;
tree ¬ MakeStructuredCard[str[c].ORD, MimData.idCHAR];
};
};
ENDCASE;
};
ENDCASE;
VSetTop[BiasForType[cType], [prop: prop, rep: RepForType[cType]], 2];
RETURN [tree];
};
Reloc:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
prop: Prop;
type: Type = SymbolOps.ToType[tb[node].info];
val: Tree.Link = [subtree[node]];
tb[node].son[1] ¬ RValue[tb[node].son[1], MimP4.nullBias, unsigned];
prop ¬ VProp[];
tb[node].son[2] ¬ RValue[tb[node].son[2], MimP4.nullBias, unsigned];
prop ¬ CommonProp[prop, VProp[]];
prop.noSelect ¬ FALSE;
VSetTop[BiasForType[type], [prop: prop, rep: RepForType[type]], 2];
RETURN [val];
};
Assignment:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
son1: Tree.Link = tb[node].son[1] ¬ Exp[tb[node].son[1], none];
lhsType: Type ¬ OperandType[son1];
bias: Bias ¬ VBias[];
attr: Attr ¬ VAttr[];
CheckLHS[son1];
tb[node].son[2] ¬ Rhs[tb[node].son[2], lhsType, $first];
attr.prop ¬ CommonProp[attr.prop, VProp[]];
attr.prop.noAssign ¬ FALSE;
VSetTop[bias, attr, 2];
RETURN [RewriteAssign[node, lhsType]];
};
CheckLHS:
PROC [t: Tree.Link] = {
DO
WITH e: t
SELECT GetTag[t]
FROM
subtree => {
tp: Tree.NodePtr = @tb[e.index];
SELECT tp.name
FROM
list => FOR i: NAT IN [1..tp.nSons] DO CheckLHS[tp.son[1]]; ENDLOOP;
dollar, cast, index, seqindex, loophole => {t ¬ tp.son[1]; LOOP};
base, length => IF tp.attr1 THEN {t ¬ tp.son[1]; LOOP};
ENDCASE;
};
symbol => IF seb[e.index].immutable THEN EXIT;
string => IF LiteralOps.MasterString[e.index] = e.index THEN EXIT;
ENDCASE => EXIT;
RETURN;
ENDLOOP;
MimosaLog.ErrorTree[nonLHS, t];
};
Extract:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
subNode: Tree.Index = GetNode[tb[node].son[1]];
rType: RecordSEIndex = LOOPHOLE[SymbolOps.UnderType[SymbolOps.own, SymbolOps.ToType[tb[subNode].info]]];
prop: Prop ¬ voidProp;
sei: ISEIndex ¬ SymbolOps.FirstVisibleSe[seb[rType].fieldCtx];
AssignItem: Tree.Map = {
v ¬ t;
IF t # Tree.Null
THEN {
subNode: Tree.Index = GetNode[t];
saveImplicit: MimP4.ImplicitRecord = MimP4.implicit;
type: Type ¬ seb[sei].idType;
rep: Repr ¬ RepForType[type];
MimP4.implicit.type ¬ type;
MimP4.implicit.bias ¬ BiasForType[type];
MimP4.implicit.attr.rep ¬ rep;
IF rep < real THEN [MimP4.implicit.lb, MimP4.implicit.ub] ¬ Bounds[type, rep];
MimP4.implicit.sef ¬ FALSE;
v ¬ IF tb[subNode].name = extract
THEN Extract[subNode]
ELSE Assignment[subNode];
prop ¬ CommonProp[prop, VProp[]];
VPop[];
MimP4.implicit ¬ saveImplicit;
};
sei ¬ SymbolOps.NextSe[SymbolOps.own, sei];
};
tb[subNode].son[1] ¬ UpdateList[tb[subNode].son[1], AssignItem];
tb[node].son[2] ¬ Exp[tb[node].son[2], none];
prop ¬ CommonProp[prop, VProp[]];
VSetTop[BiasForType[rType], [prop: prop, rep: RepForType[rType]], 1];
RETURN [[subtree[index: node]]];
};
New:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
son1: Tree.Link ¬ tb[node].son[1];
son2: Tree.Link ¬ tb[node].son[2];
son3: Tree.Link ¬ tb[node].son[3];
prop: Prop ¬ voidProp;
IF son1 # Tree.Null
THEN {
son1 ¬ tb[node].son[1] ¬ Exp[son1, none];
prop ¬ VProp[];
VPop[];
};
IF OpName[son2] = apply
THEN {
subNode: Tree.Index = GetNode[son2];
type: Type;
vSei: ISEIndex;
TypeExp[tb[subNode].son[1]];
type ¬ TypeForTree[tb[subNode].son[1]];
tb[subNode].son[2] ¬ Rhs[tb[subNode].son[2], MimData.idCARDINAL, $init];
prop ¬ CommonProp[prop, VProp[]]; VPop[];
vSei ¬ SymbolOps.VariantField[SymbolOps.own, SymbolOps.UnderType[SymbolOps.own, type]];
IF vSei # Symbols.ISENull
THEN {
vType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, seb[vSei].idType];
subType: Type = OperandType[tb[subNode].son[2]];
n:
CARD =
WITH t: seb[vType]
SELECT
FROM
sequence =>
MIN[
SymbolOps.Cardinality[SymbolOps.own, seb[t.tagSei].idType],
MaxCardinality[t.componentType, t.packed, maxBits-BitsForType[type]]]
ENDCASE => 0;
IF SymbolOps.EqTypes[SymbolOps.own, subType, MimData.idINTEGER]
OR ~(SymbolOps.Cardinality[SymbolOps.own, subType]
IN [1..n])
THEN
-- (0..n]
tb[subNode].son[2] ¬ CheckRange[tb[subNode].son[2], n, MimData.idCARDINAL];
};
}
ELSE {
TypeExp[son2, OpName[son3] = body];
SELECT BitsForType[SymbolOps.UnderType[SymbolOps.own, TypeForTree[son2]]]
FROM
> maxBits => MimosaLog.ErrorTree[operandSize, son2];
<= 0 => MimosaLog.WarningTree[emptyArray, son2];
ENDCASE;
};
SELECT OpName[son3]
FROM
body => {
expNode: Tree.Index = GetNode[son3];
PushNode[body, 0];
SetInfo[tb[expNode].info];
son3 ¬ tb[node].son[3] ¬ PopTree[];
};
signalinit => NULL;
ENDCASE =>
IF son3 # Tree.Null
THEN {
type: Type = TypeForTree[son2];
subProp: Prop;
son3 ¬ tb[node].son[3] ¬ Rhs[son3, type, $init]; subProp ¬ VProp[]; VPop[];
IF tb[node].attr3 THEN son3 ¬ tb[node].son[3] ¬ Safen[son3, subProp, $init, type];
prop ¬ CommonProp[prop, subProp];
};
IF tb[node].nSons > 3 THEN CatchNest[tb[node].son[4]];
prop.noXfer ¬ prop.noFreeVar ¬ FALSE;
VPush[MimP4.nullBias, [prop: prop, rep: unsigned]];
RETURN [[subtree[index: node]]];
};
ListCons:
PUBLIC
PROC [node: Tree.Index]
RETURNS [val: Tree.Link] = {
ItemType:
PROC [nType: Type]
RETURNS [Type] =
INLINE {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, nType];
WITH r: seb[sei]
SELECT
FROM
record => RETURN [seb[SymbolOps.FirstCtxSe[SymbolOps.own, r.fieldCtx]].idType];
ENDCASE => RETURN [Symbols.typeANY];
};
cType: Type = ItemType[SymbolOps.ReferentType[SymbolOps.own, SymbolOps.ToType[tb[node].info]]];
prop: Prop ¬ voidProp;
EvalElement: Tree.Map = {
v ¬ t;
IF t # Tree.Null
THEN {
subProp: Prop;
v ¬ Rhs[t, cType, $init];
subProp ¬ VProp[];
VPop[];
IF tb[node].attr3 THEN v ¬ Safen[v, subProp, $init, cType];
prop ¬ CommonProp[prop, subProp];
};
};
IF tb[node].son[1] # Tree.Null
THEN {
tb[node].son[1] ¬ Exp[tb[node].son[1], none];
prop ¬ VProp[];
VPop[];
};
IF BitsForType[cType] > maxBits
THEN
MimosaLog.ErrorTree[operandSize, [subtree[node]]];
IF ListLength[tb[node].son[2]] = 0
THEN {
PushTree[Tree.Null]; PushNode[nil, 1]; SetInfo[tb[node].info];
val ¬ Exp[PopTree[], RepForType[SymbolOps.UnderType[SymbolOps.own, SymbolOps.ToType[tb[node].info]]]];
FreeNode[node];
}
ELSE {
tb[node].son[2] ¬ UpdateList[tb[node].son[2], EvalElement];
prop.noXfer ¬ prop.noFreeVar ¬ FALSE;
VPush[MimP4.nullBias, [prop: prop, rep: unsigned]];
val ¬ [subtree[index: node]];
};
};
Narrow:
PUBLIC
PROC [node: Tree.Index]
RETURNS [Tree.Link] = {
type: Type = SymbolOps.ToType[tb[node].info];
val: Tree.Link ¬ [subtree[index: node]];
son1: Tree.Link ¬ tb[node].son[1];
son2: Tree.Link ¬ tb[node].son[2];
IF son2 # Tree.Null THEN TypeExp[son2];
IF tb[node].attr2
OR tb[node].attr3
THEN {
prop: Prop;
tb[node].son[1] ¬ RValue[son1, MimP4.nullBias, RepForType[OperandType[son1]]];
prop ¬ VProp[];
prop.noXfer ¬ FALSE;
VPop[];
IF tb[node].nSons > 2 THEN CatchNest[tb[node].son[3]];
VPush[BiasForType[type], [prop: prop, rep: RepForType[type]]];
}
ELSE {
val ¬ Rhs[son1, type, $init];
tb[node].son[1] ¬ Tree.Null;
FreeNode[node];
IF
NOT SymbolOps.EqTypes[SymbolOps.own, OperandType[val], type]
THEN
val ¬ ForceType[val, type];
};
RETURN [val];
};
Rhs:
PUBLIC
PROC [exp: Tree.Link, lhsType: Type, cs: ConsState, voidOK:
BOOL¬
FALSE]
RETURNS [val: Tree.Link] = {
lType: CSEIndex ¬ SymbolOps.UnderType[SymbolOps.own, lhsType];
rType: CSEIndex ¬ OperandStruct[exp, FALSE];
cType: CSEIndex ¬ rType;
lBias: Bias ¬ BiasForType[lType];
lRep: Repr ¬ RepForType[lType];
lBits: INT ¬ BitsForType[lType];
rRep: Repr;
rBits: INT;
tc: Symbols.TypeClass = seb[lType].typeTag;
{
WITH exp
SELECT GetTag[exp]
FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name
FROM
construct => {val ¬ Construct[node, cs]; GO TO adjusted};
union => {val ¬ Union[node, cs]; GO TO adjusted};
rowcons => {val ¬ RowConstruct[node, cs]; GO TO adjusted};
all => {val ¬ All[node, cs]; GO TO adjusted};
ENDCASE;
};
ENDCASE;
val ¬ RValue[exp, lBias, lRep];
rType ¬ OperandStruct[val, FALSE];
EXITS adjusted => {};
};
IF lType = Symbols.typeANY
THEN {
Got to be careful about this; we don't want to assign just anything to UNSPECIFIED!
IF lBits # 0
OR
NOT voidOK
THEN
IF MimP4.WordsForType[rType] # MimP4.WordsForType[lType]
THEN
MimosaLog.ErrorTree[sizeClash, val];
RETURN [val];
};
rRep ¬ VRep[];
rBits ¬ BitsForType[rType];
{
Check for assignability
RRA: first we throw out the obvious fixed-point & floating point cases because Types.Assignable can't hack it.
lClass: Symbols.TypeClass ¬
seb[SymbolOps.NormalType[SymbolOps.own, lType]].typeTag;
rClass: Symbols.TypeClass ¬
seb[SymbolOps.NormalType[SymbolOps.own, rType]].typeTag;
SELECT lClass
FROM
signed, unsigned, real =>
SELECT rClass
FROM
signed, unsigned => GO TO matched;
ENDCASE;
ENDCASE;
IF
NOT Types.Assignable[
[MimData.ownSymbols, lType], [MimData.ownSymbols, cType]]
THEN {
clearType: CSEIndex ¬ MimP4.ClearType[cType];
IF
NOT Types.Assignable[
[MimData.ownSymbols, lType], [MimData.ownSymbols, clearType]]
THEN {
MimosaLog.ErrorType[typeClash, val, [MimData.ownSymbols, lhsType]];
RETURN [val];
};
rType ¬ cType ¬ clearType;
};
EXITS matched => {};
};
{
SELECT TreeOps.OpName[val]
FROM
lengthen => cType ¬ OperandStruct[TreeOps.NthSon[val, 1], TRUE];
ENDCASE;
SELECT tc
FROM
transfer => {
WITH exp
SELECT GetTag[exp]
FROM
symbol => {
sei: Symbols.ISEIndex = index;
IF sei # Symbols.ISENull
AND seb[sei].extended
AND seb[sei].constant
THEN
This looks like a MACHINE CODE procedure that was not caught in Pass3Xb.OperandInline, due to declaration order.
MimosaLog.ErrorTree[misusedInline, exp];
};
ENDCASE;
};
subrange, enumerated, relative => {
SELECT Cover[lType, lRep, cType, rRep]
FROM
$full => {};
$partial => {
val ¬ CheckRange[val, SymbolOps.Cardinality[SymbolOps.own, lType], lType];
GO TO redoType;
};
ENDCASE => {
val ¬ BoundsFault[val, lType];
GO TO redoType;
};
};
basic =>
IF SymbolOps.EqTypes[SymbolOps.own, lType, MimData.idCHAR]
THEN {
val ¬ CheckRange[val, SymbolOps.Cardinality[SymbolOps.own, lType], lType];
GO TO redoType;
};
ENDCASE =>
IF (lRep=signed
AND rRep=unsigned)
OR (lRep=unsigned
AND rRep=signed)
THEN {
Conversion needed from signed to unsigned or unsigned to signed.
val ¬ MimP4.CheckSign[val, lType];
GO TO redoType;
};
EXITS redoType => {
rType ¬ OperandStruct[val, TRUE];
rBits ¬ BitsForType[rType];
};
};
SELECT
TRUE
FROM
lBits = rBits => {};
lBits = 0 AND voidOK => {};
(seb[lType].typeTag = record)
AND (seb[rType].typeTag = record) =>
val ¬ PadRecord[val, lType];
(seb[lType].typeTag = union) AND (seb[rType].typeTag = union) => {};
ENDCASE => {
Try to convert between numbers with different sizes
lClass: Symbols.TypeClass ¬
seb[SymbolOps.NormalType[SymbolOps.own, lType]].typeTag;
rClass: Symbols.TypeClass ¬
seb[SymbolOps.NormalType[SymbolOps.own, rType]].typeTag;
sameWords: BOOL = MimP4.WordsForType[rType] = MimP4.WordsForType[lType];
IF tc = subrange AND lBits < rBits THEN GO TO converted;
SELECT lClass
FROM
basic, signed, unsigned, real, ref, enumerated => {
isReal: BOOL ¬ lClass = real;
isSigned: BOOL ¬ lClass = signed OR isReal;
SELECT rClass
FROM
basic, signed, unsigned, real, ref, enumerated => {
PushTree[val];
SELECT
TRUE
FROM
isReal => PushNode[float, 1];
TreeLiteral[val]
AND rBits <= Target.bitsPerLongWord =>
Checking already done, just change type
PushNode[cast, 1];
lBits > rBits => PushNode[lengthen, 1];
lBits < rBits => {
SELECT
TRUE
FROM
MimP4.checked, MimData.switches['b],
NOT sameWords =>
PushNode[shorten, 1];
ENDCASE =>
Checking not needed, just change type
PushNode[cast, 1];
};
ENDCASE => ERROR;
SetType[lType];
SetAttrs[isReal, FALSE, isSigned];
val ¬ PopTree[];
MimP4.SetSubInfo[val, lType];
GO TO converted;
};
ENDCASE;
};
ENDCASE;
IF lType = Symbols.typeANY
OR rType = Symbols.typeANY
THEN
IF sameWords
THEN
GO
TO converted;
Trust that code generation will rectify the sizes properly
MimosaLog.ErrorTree[sizeClash, val];
EXITS converted => {};
};
IF lBits > maxBits THEN MimosaLog.ErrorTree[operandSize, val];
};
Cover:
PUBLIC
PROC [lType: Type, lRep: Repr, rType: Type, rRep: Repr]
RETURNS [Covering] = {
lLb, lUb, rLb, rUb: ConstArith.Const;
[lLb, lUb] ¬ Bounds[lType, lRep];
[rLb, rUb] ¬ Bounds[rType, rRep];
IF ConstArith.Compare[lLb, lUb] = greater
THEN
RETURN [none];
empty lType
IF ConstArith.Compare[rLb, rUb] = greater
THEN
RETURN [none];
empty rType
IF ConstArith.Compare[lUb, rLb] = less
THEN
RETURN [none];
all lType values less than all rType values
IF ConstArith.Compare[lLb, rUb] = greater
THEN
RETURN [none];
all lType values greater than all rType values
IF ConstArith.Compare[rUb, lUb] = greater
THEN
RETURN [partial];
at least one rType value greater than max lType value
IF ConstArith.Compare[rLb, lLb] = less
THEN
RETURN [partial];
at least one rType value less than min lType value
RETURN [full];
Bounds:
PUBLIC
PROC [type: Type, rep: Repr]
RETURNS [lb, ub: ConstArith.Const] = {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
lb ¬ MimP4.nullBias;
WITH t: seb[sei]
SELECT
FROM
subrange => {
The bounds are determined using the origin even for an "unbiased" type.
lb ¬ ConstArith.FromInt[t.origin];
IF t.empty
THEN ub ¬ ConstArith.Sub[lb, ConstArith.FromCard[1]]
ELSE ub ¬ ConstArith.Add[lb, ConstArith.FromCard[t.range]];
};
enumerated =>
ub ¬ ConstArith.FromCard[t.range];
relative =>
[lb, ub] ¬ Bounds[SymbolOps.UnderType[SymbolOps.own, t.offsetType], rep];
signed => {
len: NAT ¬ t.length;
SELECT len
FROM
NAT[
BITS[
INT32]]*2 => {
We depend on LAST[INT64] = LAST[CARD64]/2
two: ConstArith.Const = ConstArith.FromCard[2];
ub ¬ ConstArith.FromCard[LAST[INT32]];
ub ¬ ConstArith.Mul[ub, ConstArith.Add[ub, two]];
ub ¬ ConstArith.Div[ub, two];
};
NAT[BITS[INT32]] => ub ¬ ConstArith.FromInt[LAST[INT32]];
NAT[BITS[INT16]] => ub ¬ ConstArith.FromInt[LAST[INT16]];
0 => ERROR;
ENDCASE => {
ub ¬ ConstArith.FromCard[0];
WHILE len > 1
DO
ub ¬ ConstArith.Add[ConstArith.Add[ub, ub], ConstArith.FromCard[1]];
len ¬ len - 1;
ENDLOOP;
};
SELECT rep
FROM
signed => lb ¬ ConstArith.Sub[ConstArith.FromInt[-1], ub];
ENDCASE;
};
unsigned => {
len: NAT ¬ t.length;
SELECT len
FROM
NAT[
BITS[
CARD32]]*2 => {
ub ¬ ConstArith.FromCard[LAST[CARD32]];
ub ¬ ConstArith.Mul[ub, ConstArith.Add[ub, ConstArith.FromCard[2]]];
};
NAT[BITS[CARD32]] => ub ¬ ConstArith.FromCard[LAST[CARD32]];
NAT[BITS[CARD16]] => ub ¬ ConstArith.FromCard[LAST[CARD16]];
NAT[BITS[BYTE]] => ub ¬ ConstArith.FromCard[LAST[BYTE]];
0 => ERROR;
ENDCASE => {
ub ¬ ConstArith.FromCard[1];
WHILE len > 1
DO
ub ¬ ConstArith.Add[ConstArith.Add[ub, ub], ConstArith.FromCard[1]];
len ¬ len - 1;
ENDLOOP;
};
SELECT rep
FROM
signed, either => ub ¬ ConstArith.Div[ub, ConstArith.FromCard[2]];
ENDCASE;
};
basic => {
Will this survive the transition to handle 64-bit numbers?
len: [1..bitsPerWord] = t.length;
c: CARD ¬ Basics.BITLSHIFT[1, len-1];
ub ¬ ConstArith.FromCard[c+(c-1)];
};
ENDCASE =>
Will this survive the transition to handle 64-bit numbers?
SELECT rep
FROM
signed => {
lb ¬ ConstArith.FromInt[INT.FIRST];
ub ¬ ConstArith.FromInt[INT.LAST];
};
either =>
ub ¬ ConstArith.FromInt[INT.LAST];
ENDCASE =>
ub ¬ ConstArith.FromCard[CARD.LAST];
};
CheckRange:
PUBLIC
PROC [t: Tree.Link, bound:
CARD, type: Type]
RETURNS [Tree.Link] = {
ubo: INT = -UnbiasedOffset[type];
lb1, ub1: ConstArith.Const;
srcType: Type = MimP4.OperandType[t];
srcRep: MimP4.Repr = MimP4.RepForType[srcType];
val: Tree.Link ¬ t;
IF bound = 0
OR srcRep >= real
THEN
RETURN [t];
A bogus check
[lb1, ub1] ¬ MimP4.TreeBounds[t, srcRep];
IF ubo = 0
AND lb1.sign # negative
AND ConstArith.Compare[ub1, ConstArith.FromCard[bound]] = less
THEN
This check is not necessary, since we should always succeed
RETURN [t];
SELECT
TRUE
FROM
TreeLiteral[t] =>
IF
NOT CheckLiteralBound[t, bound, UnbiasedOffset[type]]
THEN
val ¬ BoundsFault[t, type];
(checked
OR MimData.switches['b]) => {
IF ubo # 0
AND (srcRep = signed
OR srcRep = either)
THEN {
The origin must be removed (to allow for unsigned checking)
rt: Type = SymbolOps.NormalType[SymbolOps.own, type];
PushTree[MakeTreeLiteralInt[ubo]];
PushTree[MakeTreeLiteralCard[bound]];
PushTree[MakeTreeLiteralInt[ubo]];
PushTree[t];
PushNode[plus, -2];
SetSubInfoOnStack[rt, TRUE];
PushNode[check, -2];
SetType[rt];
PushNode[minus, -2];
SetSubInfoOnStack[rt, TRUE];
PushNode[cast, 1]; -- don't need this, the type is already set
}
ELSE {
A simple unsigned check will be sufficient
ubc: CARD ¬ IF ubo > 0 THEN ubo ELSE 0;
PushTree[MakeTreeLiteralCard[bound-ubc]];
PushTree[t];
PushNode[check, -2];
};
SetType[type];
val ¬ PopTree[];
};
ENDCASE;
RETURN [val];
};
SetSubInfoOnStack:
PROC [type: Type, isSigned:
BOOL] = {
t: Tree.Link;
SetType[type];
PushTree[t ¬ PopTree[]];
MimP4.SetSubInfo[t, type];
IF isSigned THEN SetAttr[3, TRUE];
};
CheckLiteralBound:
PROC [t: Tree.Link, bound:
CARD, ubo:
INT ¬ 0]
RETURNS [
BOOL] = {
... checks the literal against the bound, returning TRUE if the literal is less than the bound.
cv: ConstArith.Const ¬ MimP4.TreeLiteralConst[t];
IF ubo # 0 THEN cv ¬ ConstArith.Sub[cv, ConstArith.FromInt[ubo]];
IF cv.sign = negative THEN RETURN [FALSE];
RETURN [ConstArith.Compare[cv, ConstArith.FromCard[bound]] = less];
};
BoundsFault:
PROC [t: Tree.Link, type: Type]
RETURNS [Tree.Link] = {
MimosaLog.ErrorTree[boundsFault,
AdjustBias[t, RepForType[type], BiasForType[type], TRUE]];
PushTree[t];
RETURN [PopTree[]];
};
RewriteAssign:
PUBLIC
PROC [node: Tree.Index, lType: Type]
RETURNS [Tree.Link] = {
son1: Tree.Link ¬ tb[node].son[1];
IF SymbolOps.TypeForm[SymbolOps.own, lType] = $union
THEN
WITH e: son1
SELECT GetTag[son1]
FROM
subtree => {
subNode: Tree.Index = e.index;
SELECT tb[subNode].name
FROM
dot => {
sub1: Tree.Link ¬ tb[subNode].son[1];
PushTree[sub1];
PushNode[uparrow, 1];
SetType[SymbolOps.ReferentType[SymbolOps.own, OperandType[sub1]]];
tb[subNode].son[1] ¬ PopTree[];
tb[subNode].name ¬ dollar;
};
ENDCASE;
};
ENDCASE;
IF tb[node].name = assignx
THEN
tb[node].info ¬ SymbolOps.FromType[OperandType[son1]];
RETURN [[subtree[index: node]]];
};
CheckTypePortability:
PROC [type: Type, node: Tree.Index] = {
ut: CSEIndex = ClearType[type];
WITH cse: seb[ut]
SELECT
FROM
record =>
IF cse.length
IN [1..bitsPerWord)
THEN {
RRA: this checks for funny archaic records, such as used sometimes in partially ported GlobalView code. This code added on October 22, 1991 per XSoft request.
WBT: The more stringent check in the 'then' case below was added Sept 24, 1992 to assist in Maui porting. The 'else' case is RRA's code.
IF MimData.checks['r]
THEN MimosaLog.WarningTree[notPortable, [subtree[node]]]
ELSE {
FOR isei: Symbols.ISEIndex ¬ SymbolOps.FirstCtxSe[SymbolOps.own, cse.fieldCtx],
SymbolOps.NextSe[SymbolOps.own, isei]
WHILE isei # Symbols.ISENull DO
elemUt: CSEIndex = ClearType[seb[isei].idType];
WITH ese: seb[elemUt]
SELECT
FROM
array => IF NOT IsBoundedArray[elemUt] THEN
MimosaLog.WarningTree[notPortable, [subtree[node]]];
ENDCASE;
ENDLOOP;
}
};
ENDCASE;
};
IsBoundedArray:
PROC [type: Type]
RETURNS [
BOOL] = {
limit: INT = maxBits;
ut: CSEIndex = ClearType[type];
WITH cse: seb[ut]
SELECT
FROM
array => {
indexUt: CSEIndex = ClearType[cse.indexType];
WITH xse: seb[indexUt]
SELECT
FROM
basic => RETURN [TRUE];
subrange => {
IF xse.empty OR xse.range > limit THEN RETURN [FALSE];
IF xse.biased OR xse.origin IN [0..limit) THEN RETURN [TRUE];
};
enumerated => {
IF xse.empty OR xse.range > limit THEN RETURN [FALSE];
RETURN [TRUE];
};
ENDCASE;
};
ENDCASE;
RETURN [FALSE];
};