Pass3Xb.mesa
Copyright Ó 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Satterthwaite, June 25, 1986 9:29:20 am PDT
Russ Atkinson (RRA) August 3, 1990 0:20:43 am PDT
DIRECTORY
LiteralOps USING [FindHeapString, Value],
MimData USING [base, bitsToAlignment, idATOM, idBOOL, idCARDINAL, idCHAR, idDCARD, idDREAL, idINTEGER, idNAT, idREAL, idSTRING, idTEXT, ownSymbols, switches, typeAtomRecord],
MimosaEvents USING [Callback, RegisterSet],
MimosaLog USING [Error, ErrorHti, ErrorN, ErrorNode, ErrorNodeOp, ErrorSei, ErrorTree, ErrorTreeOp, ErrorType, Warning, WarningNode, WarningTree],
MimP3 USING [AddrOp, All, And, Apply, Assignment, Attr, BoundNP, Case, CatchPhrase, ClearRefStack, Cons, Discrimination, Dot, emptyAttr, EnterType, Extract, fullAttr, Id, ListCons, MakeLongType, MakeRefType, MergeNP, MiscXfer, Narrowing, NarrowOp, New, NPUse, phraseNP, Range, RecordMention, SealRefStack, SearchCtxList, SequenceNP, TextForm, TextRep, TypeAppl, TypeExp, UnsealRefStack, voidAttr],
MimP3S USING [ImplicitInfo, implicitRecord, safety, self],
MimZones USING [permZone, tempZone],
OSMiscOps USING [Copy],
Pass3Attributes USING [BaseType, <<BodyForTree,>> Bundling, CanonicalType, IdentifiedType, IndexType, LongType, MarkedType, NewableType, OperandType, OrderedType, PermanentType, TargetType, TypeForTree, Unbundle],
SymbolOps USING [ConstantId, DecodeBti, DecodeTreeIndex, EqTypes, FromType, MakeNonCtxSe, NormalType, own, RCType, ToBti, TypeForm, TypeRoot, UnderType, XferMode],
Symbols USING [Base, bodyType, CBTIndex, CBTNull, codeANY, codeCHAR, CSEIndex, CSENull, ctxType, HTIndex, ISEIndex, ISENull, nullType, RecordSEIndex, RecordSENull, SERecord, seType, Type, typeANY],
SymLiteralOps USING [EnterAtom, EnterText],
Target: TYPE MachineParms USING [bitsPerPtr, bitsPerReal, bitsPerRef, bitsPerWord],
Tree USING [Base, Index, Link, Map, NodePtr, NodeName, Null, nullIndex, SubInfo, treeType],
TreeOps USING [FreeNode, GetHash, GetInfo, GetNode, GetTag, ListLength, OpName, PopTree, PushNode, PushTree, SetAttr, SetInfo, UpdateList],
Types USING [Assignable, Equivalent, OpaqueValue, SymbolTableBase];
Arithmetic expression manipulation
EvalNumeric:
PROC [t: Tree.Link, op: Tree.NodeName ¬ $none]
RETURNS [Tree.Link] = {
rt: Type ¬ MimData.idINTEGER;
val: Tree.Link = GenericRhs[t, rt];
nt: CSEIndex = ClearType[rStack[rI].type, TRUE];
IF nt # typeANY
THEN
SELECT seb[nt].typeTag
FROM
signed => rt ¬ MimData.idINTEGER;
unsigned => rt ¬ MimData.idCARDINAL;
real => rt ¬ MimData.idREAL;
ENDCASE =>
IF op # $none
THEN MimosaLog.ErrorTreeOp[missingOp, val, op]
ELSE MimosaLog.ErrorTree[typeClash, val];
rStack[rI].type ¬ rt;
RETURN [val];
};
ArithOp:
PROC [node: Tree.Index] = {
son1: Tree.Link ¬ tb[node].son[1] ¬ EvalNumeric[tb[node].son[1], tb[node].name];
saveNP: NPUse ¬ phraseNP;
son2: Tree.Link ¬ tb[node].son[2] ¬ EvalNumeric[tb[node].son[2]];
BalanceAttributes[node];
rStack[rI-1].attr ¬ And[rStack[rI-1].attr, rStack[rI].attr];
IF tb[node].attr1 THEN rStack[rI-1].attr.const ¬ FALSE;
RPopAssured[];
phraseNP ¬ MergeNP[saveNP][phraseNP];
};
Plus:
PROC [node: Tree.Index] = {
son1: Tree.Link ¬ tb[node].son[1] ¬ GenericRhs[tb[node].son[1], typeANY];
son2: Tree.Link ¬ tb[node].son[2];
saveNP: NPUse ¬ phraseNP;
lType: CSEIndex ¬ ClearType[rStack[rI].type, TRUE];
rType: CSEIndex;
lr: BOOL ¬ TRUE;
target: Type ¬ typeANY;
clash1: BOOL ¬ FALSE;
clash2: BOOL ¬ FALSE;
float: BOOL ¬ FALSE;
IF lType # typeANY
THEN {
WITH se: seb[lType]
SELECT
FROM
ref, relative => {
clash1 ¬ SymbolOps.RCType[SymbolOps.own, lType] # none;
WITH e: son2
SELECT GetTag[son2]
FROM
literal => MimosaLog.WarningNode[notPortable, node];
ENDCASE;
};
enumerated => clash1 ¬ NOT EqualTypes[lType, MimData.idCHAR];
basic => clash1 ¬ NOT se.ordered;
real => {target ¬ lType; float ¬ TRUE};
signed, unsigned => {target ¬ lType; lr ¬ FALSE};
ENDCASE => clash1 ¬ TRUE;
IF clash1
THEN {
MimosaLog.ErrorTreeOp[missingOp, son1, plus];
lr ¬ FALSE;
};
};
son2 ¬ tb[node].son[2] ¬ GenericRhs[son2, target];
rType ¬ ClearType[rStack[rI].type, TRUE];
IF lr THEN target ¬ lType ELSE target ¬ rType;
IF rType # typeANY
THEN {
WITH se: seb[rType]
SELECT
FROM
real => IF NOT float THEN clash2 ¬ lr;
signed, unsigned => {};
ref, relative => clash2 ¬ SymbolOps.RCType[SymbolOps.own, rType] # none;
enumerated => clash2 ¬ lr;
basic => clash2 ¬ NOT se.ordered OR lr;
ENDCASE => clash2 ¬ TRUE;
IF clash2
THEN {
MimosaLog.ErrorTree[typeClash, son2];
target ¬ rStack[rI].type ¬ MimData.idINTEGER;
};
};
BalanceAttributes[node];
rStack[rI-1].attr ¬ And[rStack[rI-1].attr, rStack[rI].attr];
IF tb[node].attr1 THEN rStack[rI-1].attr.const ¬ FALSE;
IF NOT lr THEN target ¬ UType[];
rStack[rI-1].type ¬ target;
RPopAssured[];
phraseNP ¬ MergeNP[saveNP][phraseNP];
};
Minus:
PROC [node: Tree.Index] = {
son1: Tree.Link ¬ tb[node].son[1] ¬ GenericRhs[tb[node].son[1], typeANY];
son2: Tree.Link ¬ tb[node].son[2];
saveNP: NPUse ¬ phraseNP;
lType: CSEIndex ¬ ClearType[rStack[rI].type, TRUE];
rType: CSEIndex;
lr: BOOL ¬ TRUE;
target: Type ¬ typeANY;
clash1: BOOL ¬ FALSE;
clash2: BOOL ¬ FALSE;
float: BOOL ¬ FALSE;
IF lType # typeANY
THEN {
WITH se: seb[lType]
SELECT
FROM
ref, relative => {
clash1 ¬ SymbolOps.RCType[SymbolOps.own, lType] # none;
WITH e: son2
SELECT GetTag[son2]
FROM
literal => MimosaLog.WarningNode[notPortable, node];
ENDCASE;
};
enumerated => clash1 ¬ NOT EqualTypes[lType, MimData.idCHAR];
basic => clash1 ¬ NOT se.ordered;
real => {target ¬ lType; float ¬ TRUE};
signed, unsigned => {target ¬ lType; lr ¬ FALSE};
ENDCASE => clash1 ¬ TRUE;
IF clash1
THEN {
MimosaLog.ErrorTreeOp[missingOp, son1, minus];
lr ¬ FALSE;
};
};
son2 ¬ tb[node].son[2] ¬ GenericRhs[son2, target];
rType ¬ ClearType[rStack[rI].type, TRUE];
IF lr THEN target ¬ lType ELSE target ¬ rType;
SELECT
TRUE
FROM
EqualTypes[lType, rType] => {
lr ¬ TRUE;
WITH se: seb[lType]
SELECT
FROM
real, signed, unsigned => target ¬ lType;
ENDCASE => target ¬ MimData.idINTEGER;
};
rType = typeANY => {lr ¬ TRUE};
ENDCASE => {
WITH se: seb[rType]
SELECT
FROM
real => IF NOT float THEN clash2 ¬ lr;
signed, unsigned => {};
ENDCASE => clash2 ¬ TRUE;
IF clash2
THEN {
MimosaLog.ErrorTree[typeClash, son2];
target ¬ rStack[rI].type ¬ MimData.idINTEGER;
};
};
BalanceAttributes[node];
rStack[rI-1].attr ¬ And[rStack[rI-1].attr, rStack[rI].attr];
IF tb[node].attr1 THEN rStack[rI-1].attr.const ¬ FALSE;
IF NOT lr THEN target ¬ UType[];
rStack[rI-1].type ¬ target;
RPopAssured[];
phraseNP ¬ MergeNP[saveNP][phraseNP];
};
RelOp:
PROC [node: Tree.Index, ordered:
BOOL] = {
son1: Tree.Link ¬ tb[node].son[1] ¬ GenericRhs[tb[node].son[1], typeANY];
saveNP: NPUse ¬ phraseNP;
type: Type ¬ rStack[rI].type;
target: Type ¬ BaseType[type];
attr: Attr ¬ rStack[rI].attr;
implicitOp: BOOL ¬ (son1 = Tree.Null);
son2: Tree.Link ¬ tb[node].son[2] ¬ GenericRhs[tb[node].son[2], target];
type ¬ BalanceTypes[target, BaseType[rStack[rI].type]
! UnresolvedTypes => {
MimosaLog.ErrorType[typeClash, son2, [MimData.ownSymbols, type]];
RESUME[typeANY]}];
IF (ordered
AND ~OrderedType[type])
OR (~ordered
AND ~IdentifiedType[type])
THEN
MimosaLog.ErrorTreeOp[missingOp, son1, tb[node].name];
BalanceAttributes[node];
May change son[1] or son[2].
son1 ¬ tb[node].son[1];
son2 ¬ tb[node].son[2];
attr ¬ And[attr, rStack[rI].attr];
IF implicitOp AND son1 # Tree.Null THEN MimosaLog.ErrorTree[typeClash, son2];
SELECT SymbolOps.TypeForm[SymbolOps.own, type]
FROM
$basic, $enumerated, $signed, $unsigned => NULL;
$transfer => {
IF OperandInline[son1] THEN MimosaLog.ErrorTree[misusedInline, son1];
IF OperandInline[son2] THEN MimosaLog.ErrorTree[misusedInline, son2];
attr.const ¬ FALSE;
};
$real => attr.const ¬ FALSE;
ENDCASE;
RPopAssured[];
RSet[MimData.idBOOL, attr];
phraseNP ¬ MergeNP[saveNP][phraseNP];
};
In:
PROC [node: Tree.Index] = {
son1: Tree.Link ¬ tb[node].son[1] ¬ GenericRhs[tb[node].son[1], typeANY];
saveNP: NPUse ¬ phraseNP;
type: Type ¬ rStack[rI].type;
son2: Tree.Link ¬ tb[node].son[2] ¬ Range[tb[node].son[2], CanonicalType[type]];
cType: Type ¬ rStack[rI].type;
[] ¬ BalanceTypes[BaseType[type], BaseType[cType]
! UnresolvedTypes => {
MimosaLog.ErrorType[typeClash, son1, [MimData.ownSymbols, cType]];
RESUME[typeANY]}];
BalanceAttributes[node, FALSE];
rStack[rI-1].attr ¬ And[rStack[rI-1].attr, rStack[rI].attr];
RPopAssured[];
tb[node].info ¬ SymbolOps.FromType[rStack[rI].type ¬ MimData.idBOOL];
phraseNP ¬ MergeNP[saveNP][phraseNP];
};
BoolOp:
PROC [node: Tree.Index] = {
attr: Attr;
saveNP: NPUse;
SealRefStack[];
tb[node].son[1] ¬ Rhs[tb[node].son[1], MimData.idBOOL];
attr ¬ rStack[rI].attr;
saveNP ¬ phraseNP;
ClearRefStack[];
tb[node].son[2] ¬ Rhs[tb[node].son[2], MimData.idBOOL];
UnsealRefStack[];
attr ¬ And[attr, rStack[rI].attr];
RPopAssured[];
RSet[MimData.idBOOL, attr];
phraseNP ¬ SequenceNP[saveNP][phraseNP];
};
Interval:
PUBLIC
PROC [t: Tree.Link, target: Type, constant:
BOOL] = {
node: Tree.Index = GetNode[t];
type: Type;
attr: Attr;
saveNP: NPUse;
target ¬ TargetType[target];
tb[node].son[1] ¬ BalancedRhs[tb[node].son[1], target];
saveNP ¬ phraseNP;
type ¬ rStack[rI].type ¬ CanonicalType[rStack[rI].type];
attr ¬ rStack[rI].attr;
IF constant AND ~attr.const THEN MimosaLog.ErrorTree[nonConstant, tb[node].son[1]];
tb[node].son[2] ¬ BalancedRhs[tb[node].son[2], target];
rStack[rI].type ¬ CanonicalType[rStack[rI].type];
type ¬ BalanceTypes[BaseType[type], BaseType[rStack[rI].type]
! UnresolvedTypes => {
MimosaLog.ErrorTree[typeClash, tb[node].son[2]];
RESUME[typeANY];
}];
attr ¬ And[attr, rStack[rI].attr];
IF constant
AND ~rStack[rI].attr.const
THEN
MimosaLog.ErrorTree[nonConstant, tb[node].son[2]];
SELECT tb[node].name
FROM
intOO, intOC, intCO, intCC => {
No need to balance signed/unsigned yet
ac: ArithClass ¬ AttrClass[type];
IF ac.kind = real THEN BalanceAttributes[node];
};
ENDCASE => BalanceAttributes[node];
IF tb[node].attr1 THEN attr.const ¬ FALSE;
phraseNP ¬ MergeNP[saveNP][phraseNP];
RPopAssured[];
rStack[rI].attr ¬ attr;
};
BalancedTarget:
PROC [target, type: Type]
RETURNS [Type] = {
SELECT
TRUE
FROM
target = typeANY => {};
EqualTypes[type, target] => RETURN [target];
EqualTypes[ClearType[type, TRUE], target] => RETURN [target];
ENDCASE => RETURN [target];
RETURN [TargetType[type]];
ResolveTypes:
PROC [type1, type2, target: Type, t: Tree.Link]
RETURNS [type: Type] = {
failed: BOOL ¬ target = typeANY;
IF
NOT failed
THEN {
ENABLE UnresolvedTypes => {failed ¬ TRUE; RESUME[typeANY]};
type ¬ BalanceTypes[BalanceTypes[target, type1], BalanceTypes[target, type2]];
};
IF failed
THEN {
MimosaLog.ErrorType[typeClash, t, [MimData.ownSymbols, CanonicalType[type1]]];
type ¬ typeANY;
};
};
IfExp:
PROC [node: Tree.Index, target: Type] = {
type: Type;
attr: Attr;
entryNP: NPUse;
saveNP: NPUse;
son1: Tree.Link ¬ tb[node].son[1];
son2: Tree.Link ¬ tb[node].son[2];
son3: Tree.Link ¬ tb[node].son[3];
SealRefStack[];
son1 ¬ tb[node].son[1] ¬ Rhs[son1, MimData.idBOOL];
attr ¬ rStack[rI].attr; RPopAssured[]; entryNP ¬ phraseNP;
UnsealRefStack[];
son2 ¬ tb[node].son[2] ¬ BalancedRhs[son2, target];
attr ¬ And[attr, rStack[rI].attr];
saveNP ¬ SequenceNP[entryNP][phraseNP];
type ¬ rStack[rI].type;
RPopAssured[];
target ¬ BalancedTarget[target, type];
son3 ¬ tb[node].son[3] ¬ BalancedRhs[son3, target];
attr ¬ And[attr, rStack[rI].attr];
type ¬ BalanceTypes[type, rStack[rI].type
! UnresolvedTypes => {
RESUME[ResolveTypes[type, rStack[rI].type, target, son3]];
}];
IF SymbolOps.TypeForm[SymbolOps.own, type] = $transfer
THEN {
IF OperandInline[son2] THEN MimosaLog.ErrorTree[misusedInline, son2];
IF OperandInline[son3] THEN MimosaLog.ErrorTree[misusedInline, son3];
attr.const ¬ FALSE;
};
phraseNP ¬ BoundNP[saveNP][SequenceNP[entryNP][phraseNP]];
RSet[type, attr];
};
SelectExp:
PROC
[node: Tree.Index, target: Type, driver:
PROC [Tree.Index, Tree.Map], foldable:
BOOL] = {
Selection: Tree.Map = {
subType: Type;
entryNP: NPUse = phraseNP;
v ¬ BalancedRhs[t, target];
subType ¬ BalanceTypes[type, rStack[rI].type
! UnresolvedTypes => {RESUME[ResolveTypes[type, rStack[rI].type, target, v]]}];
IF SymbolOps.TypeForm[SymbolOps.own, subType] = $transfer
AND OperandInline[v]
THEN
MimosaLog.ErrorTree[misusedInline, v];
saveNP ¬ BoundNP[saveNP][SequenceNP[entryNP][phraseNP]];
IF subType # typeANY THEN type ¬ subType;
IF ~started THEN target ¬ BalancedTarget[target, type];
attr ¬ And[attr, rStack[rI].attr]; RPopAssured[];
started ¬ TRUE;
};
type: Type ¬ typeANY;
attr: Attr ¬ fullAttr;
started: BOOL ¬ FALSE;
saveNP: NPUse ¬ none;
driver[node, Selection];
attr ¬ And[attr, rStack[rI].attr];
attr.const ¬ foldable AND attr.const AND tb[node].attr2;
RSet[type, attr];
phraseNP ¬ saveNP;
};
MinMax:
PROC [node: Tree.Index, target: Type] = {
attr: Attr ¬ fullAttr;
saveNP: NPUse ¬ none;
started: BOOL ¬ FALSE;
subType: Type ¬ typeANY;
type: Type ¬ target;
maxAc: ArithClass;
SubMinMax: Tree.Map = {
Here we do the evaluations and to gather up the maximum type. We do not convert to the maximum type until it exists. Conversions are deferred until Pass4.
vType: Type;
ac: ArithClass;
v ¬ GenericRhs[t, target];
saveNP ¬ MergeNP[saveNP][phraseNP];
vType ¬ rStack[rI].type;
ac ¬ AttrClass[vType];
IF
NOT started
OR (attr.either
AND ac.kind = unsigned)
THEN {
The first time that we have a definitive type.
type ¬ vType;
attr ¬ rStack[rI].attr;
maxAc ¬ ac;
}
ELSE {
Accumulate a "maximum" type.
attr ¬ And[attr, rStack[rI].attr];
ac ¬ MaxClass[ac, maxAc];
IF ac.kind # none THEN maxAc ¬ ac;
IF maxAc.kind # none THEN type ¬ AttrClassToType[maxAc];
};
subType ¬ BalanceTypes[type, vType
! UnresolvedTypes => {RESUME[ResolveTypes[type, vType, target, v]]}];
IF subType # typeANY
THEN {
SELECT
TRUE
FROM
~started => {
IF ~OrderedType[subType]
THEN
MimosaLog.ErrorTreeOp[missingOp, v, tb[node].name];
target ¬ BalancedTarget[target, subType];
started ¬ TRUE;
};
~SymbolOps.EqTypes[SymbolOps.own, type, subType]
AND ~OrderedType[subType] =>
MimosaLog.ErrorTree[typeClash, v];
ENDCASE;
type ¬ subType;
};
RPop[];
};
tb[node].son[1] ¬ UpdateList[tb[node].son[1], SubMinMax];
SELECT SymbolOps.TypeForm[SymbolOps.own, type]
FROM
real => {tb[node].attr1 ¬ TRUE; tb[node].attr2 ¬ FALSE; attr.const ¬ FALSE};
ENDCASE => tb[node].attr1 ¬ tb[node].attr2 ¬ FALSE;
IF type = typeANY THEN type ¬ MimData.idINTEGER;
RPush[type, attr];
phraseNP ¬ saveNP;
};
TypeTest:
PROC [node: Tree.Index, from, to: Type] = {
subType: Type = CanonicalType[from];
op: NarrowOp = Narrowing[type: subType, target: to];
son1: Tree.Link ¬ tb[node].son[1];
SELECT
TRUE
FROM
op.error => MimosaLog.ErrorTree[typeClash, son1];
op.computed => MimosaLog.ErrorTree[missingBinding, son1];
op.unImpl => MimosaLog.Warning[opaqueTest];
ENDCASE;
IF
NOT SymbolOps.EqTypes[SymbolOps.own, subType, from]
THEN
son1 ¬ tb[node].son[1] ¬ ForceType[son1, subType];
tb[node].attr1 ¬ op.indirect;
IF (tb[node].attr2 ¬ op.rtTest) THEN EnterType[MarkedType[to]];
tb[node].attr3 ¬ op.tagTest;
};
Unspec:
PROC [type: Type]
RETURNS [
BOOL] = {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei]
SELECT
FROM
basic => RETURN [t.code = codeANY];
ENDCASE => RETURN [FALSE];
SafeForUnspec:
PROC [target: Type]
RETURNS [
BOOL] = {
RETURN [MimP3S.safety # checked OR SymbolOps.RCType[SymbolOps.own, target] = none];
};
Rhs:
PUBLIC
PROC [exp: Tree.Link, lhsType: Type]
RETURNS [val: Tree.Link] = {
rhsType: Type;
lhsSei, rhsSei: CSEIndex;
val ¬ Exp[exp, lhsType];
rhsType ¬ rStack[rI].type;
lhsSei ¬ SymbolOps.UnderType[SymbolOps.own, lhsType];
rhsSei ¬ SymbolOps.UnderType[SymbolOps.own, rhsType];
SELECT
TRUE
FROM
(lhsSei = rhsSei), Unspec[lhsType] => NULL;
ENDCASE => {
immediate matching is inconclusive
UNTIL Types.Assignable[[own, lhsSei], [own, rhsSei]]
DO
WITH t: seb[rhsSei]
SELECT
FROM
subrange =>
rhsType ¬ SymbolOps.UnderType[SymbolOps.own, t.rangeType];
record => {
IF Bundling[rhsSei] = 0 THEN GO TO nomatch;
rhsType ¬ Unbundle[LOOPHOLE[rhsSei, RecordSEIndex]];
val ¬ ForceType[val, IF Unspec[rhsType] THEN typeANY ELSE rhsType];
};
basic => {
IF Unspec[rhsSei]
AND SafeForUnspec[lhsSei]
THEN GO TO coerced
ELSE GO TO nomatch;
};
signed => {
rBits: INT ¬ t.length;
WITH dst: seb[lhsSei]
SELECT
FROM
signed =>
SELECT dst.length
FROM
< rBits => val ¬ Shorten[val, lhsType];
> rBits => val ¬ Lengthen[val, lhsType];
ENDCASE => ERROR; -- how come no match ???
unsigned =>
SELECT dst.length
FROM
> rBits => val ¬ Lengthen[val, lhsType];
ENDCASE => val ¬ Shorten[val, lhsType];
real => {
val ¬ Float[val, rhsType, lhsType];
rStack[rI].attr.const ¬ FALSE;
};
ENDCASE => GO TO nomatch;
GO TO coerced;
};
unsigned => {
rBits: INT ¬ t.length;
WITH dst: seb[lhsSei]
SELECT
FROM
signed =>
SELECT dst.length
FROM
> rBits => val ¬ Lengthen[val, lhsType];
ENDCASE => val ¬ Shorten[val, lhsType];
unsigned =>
SELECT dst.length
FROM
< rBits => val ¬ Shorten[val, lhsType];
> rBits => val ¬ Lengthen[val, lhsType];
ENDCASE => ERROR; -- how come no match ???
real => {
val ¬ Float[val, rhsType, lhsType];
rStack[rI].attr.const ¬ FALSE;
};
ENDCASE => GO TO nomatch;
GO TO coerced;
};
real => {
rBits: INT ¬ t.length;
WITH tt: seb[lhsSei]
SELECT
FROM
real =>
SELECT tt.length
FROM
< rBits => val ¬ Shorten[val, lhsType];
> rBits => val ¬ Lengthen[val, lhsType];
ENDCASE => ERROR; -- should have been assignable!
ENDCASE => GO TO nomatch;
GO TO coerced;
};
ENDCASE => GO TO nomatch;
rhsSei ¬ SymbolOps.UnderType[SymbolOps.own, rhsType];
REPEAT
coerced => {
coercion is complete
rhsType ¬ lhsType;
};
nomatch => {
no coercion is possible
MimosaLog.ErrorType[typeClash,
IF exp = Tree.Null THEN implicit.tree ELSE val,
[MimData.ownSymbols, lhsType]];
rhsType ¬ lhsType;
};
ENDLOOP;
rStack[rI].type ¬ rhsType;
};
IF val # Tree.Null
AND SymbolOps.TypeForm[SymbolOps.own, rhsType] = $transfer
AND OperandInline[val]
THEN
MimosaLog.ErrorTree[misusedInline, val];
};
GenericRhs:
PROC [exp: Tree.Link, target: Type]
RETURNS [Tree.Link] = {
val: Tree.Link ¬ Exp[exp, target];
type: Type ¬ rStack[rI].type;
put value in canonical form
DO
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei]
SELECT
FROM
subrange => type ¬ t.rangeType;
record => {
IF Bundling[sei] = 0 THEN EXIT;
type ¬ Unbundle[LOOPHOLE[sei, RecordSEIndex]];
val ¬ ForceType[val, type];
};
ENDCASE => EXIT;
rStack[rI].type ¬ type;
ENDLOOP;
rStack[rI].type ¬ type;
RETURN [val];
};
BalancedRhs:
PROC [exp: Tree.Link, target: Type]
RETURNS [Tree.Link] = {
val: Tree.Link ¬ Exp[exp, target];
type: Type ¬ rStack[rI].type; -- for exp
ac: ArithClass ¬ AttrClass[type];
tac: ArithClass ¬ AttrClass[target];
rac: ArithClass ¬ MaxClass[ac, tac];
attr: Attr ¬ rStack[rI].attr;
IF attr.either
AND tac.kind = unsigned
THEN {
A cheap coercion
rac.kind ¬ ac.kind ¬ unsigned;
rStack[rI].type ¬ type ¬ target;
};
IF rac.kind # none
AND ac # rac
THEN {
Need to augment val
target ¬ AttrClassToType[rac];
IF rac.kind = real
THEN {
val ¬ Float[val, type, target];
rStack[rI].type ¬ type ¬ target;
}
ELSE {
IF MimData.switches['y]
THEN {
We are being asked to emit warnings about possibly unexpected conversions between signed & unsigned numbers. We don't bother to check conversions of constants, because that will be done in Pass 4.
SELECT
TRUE
FROM
rac.kind = signed
AND ac.kind = unsigned
AND
NOT attr.const =>
MimosaLog.WarningTree[mixedRepresentation, val];
rac.kind = unsigned
AND ac.kind = signed
AND
NOT attr.const =>
MimosaLog.WarningTree[mixedRepresentation, val];
ENDCASE;
};
val ¬ Lengthen[val, target];
rStack[rI].type ¬ type ¬ target;
};
};
SELECT
TRUE
FROM
type = typeANY => rStack[rI].type ¬ type ¬ target;
Unspec[type] AND SafeForUnspec[target] => rStack[rI].type ¬ type ¬ target;
ENDCASE;
RETURN [val];
};
SetAttributesPop:
PROC [target: Type]
RETURNS [t: Tree.Link] = {
t ¬ PopTree[];
IF t # Tree.Null
THEN
WITH e: t
SELECT GetTag[t]
FROM
subtree => {SetAttributes[e.index, target]; RETURN};
ENDCASE;
ERROR;
};
SetAttributes:
PROC [node: Tree.Index, target: Type] = {
nt: CSEIndex = ClearType[target, TRUE];
ac: ArithClass = AttrClass[nt];
tp: Tree.NodePtr = @tb[node];
tp.attr1 ¬ tp.attr2 ¬ FALSE;
tp.subInfo ¬ ac.precision;
WITH seb[nt]
SELECT
FROM
real => tp.attr1 ¬ tp.attr3 ¬ TRUE;
signed => tp.attr3 ¬ TRUE;
ref => tp.attr2 ¬ TRUE;
relative => tp.attr2 ¬ TRUE;
ENDCASE;
tp.info ¬ SymbolOps.FromType[target];
BalanceAttributes:
PROC [node: Tree.Index, alterSon2:
BOOL ¬ TRUE] = {
type1: Type ¬ rStack[rI-1].type; -- for son1
ac1: ArithClass ¬ AttrClass[type1];
type2: Type ¬ rStack[rI].type; -- for son2
ac2: ArithClass ¬ AttrClass[type2];
target: Type ¬ type1;
attr1: Attr ¬ rStack[rI-1].attr;
attr2: Attr ¬ rStack[rI].attr;
IF attr2.either
THEN
SELECT ac1.kind
FROM
unsigned => {ac2.kind ¬ unsigned; rStack[rI].type ¬ type2 ¬ target ¬ type1};
signed => {ac2.kind ¬ signed; rStack[rI].type ¬ type2 ¬ target ¬ type1};
ENDCASE;
IF attr1.either
THEN
SELECT ac2.kind
FROM
unsigned => {ac1.kind ¬ unsigned; rStack[rI-1].type ¬ type1 ¬ target ¬ type2};
signed => {ac1.kind ¬ signed; rStack[rI-1].type ¬ type1 ¬ target ¬ type2};
ENDCASE;
SELECT
TRUE
FROM
dontCareAboutSigns
AND ac1.precision = ac2.precision
AND (ac1.kind = signed
AND ac2.kind = unsigned
OR ac1.kind = unsigned
AND ac2.kind = signed) => {
We rely on Pass 4 processing to determine the correct kind of arithmetic to use
};
ac1 # ac2 => {
ac: ArithClass ¬ MaxClass[ac1, ac2];
IF MimData.switches['y]
THEN {
We are being asked to emit warnings about possibly unexpected conversions between signed & unsigned numbers. We don't bother to check conversions of constants, because that will be done in Pass 4.
SELECT
TRUE
FROM
ac1.kind = signed
AND ac2.kind = unsigned
AND
NOT attr2.const =>
MimosaLog.WarningNode[mixedRepresentation, node];
ac1.kind = unsigned
AND ac2.kind = signed
AND
NOT attr1.const =>
MimosaLog.WarningNode[mixedRepresentation, node];
ENDCASE;
};
IF ac.kind # none
THEN
SELECT ac
FROM
ac1 => {
Need to augment son[2]
son: Tree.Link ¬ tb[node].son[2];
target ¬ type1;
IF alterSon2
THEN {
IF ac.kind = real
THEN tb[node].son[2] ¬ Float[son, type2, target]
ELSE tb[node].son[2] ¬ Lengthen[son, target];
};
rStack[rI].type ¬ target;
};
ac2 => {
Need to augment son[1]
son: Tree.Link ¬ tb[node].son[1];
target ¬ type2;
IF ac.kind = real
THEN tb[node].son[1] ¬ Float[son, type1, target]
ELSE tb[node].son[1] ¬ Lengthen[son, target];
rStack[rI-1].type ¬ target;
};
ENDCASE => target ¬ AttrClassToType[ac];
};
ENDCASE;
SetAttributes[node, target];
Lengthen:
PROC [t: Tree.Link, target: Type]
RETURNS [Tree.Link] = {
PushTree[t];
PushNode[lengthen, 1];
RETURN [SetAttributesPop[target]];
};
Shorten:
PROC [t: Tree.Link, target: Type]
RETURNS [Tree.Link] = {
PushTree[t];
PushNode[shorten, 1];
RETURN [SetAttributesPop[target]];
};
Float:
PROC [t: Tree.Link, type, target: Type]
RETURNS [Tree.Link] = {
nt: CSEIndex = ClearType[type, TRUE];
bits: NAT ¬ Target.bitsPerReal;
needsFloat: BOOL ¬ FALSE;
cTarget: CSEIndex = ClearType[target, TRUE];
WITH s: seb[nt]
SELECT
FROM
signed => {bits ¬ s.length; needsFloat ¬ TRUE};
unsigned => {bits ¬ s.length; needsFloat ¬ TRUE};
real => bits ¬ s.length;
ENDCASE => IF nt # typeANY THEN {MimosaLog.ErrorTree[typeClash, t]; RETURN [t]};
IF needsFloat
THEN {
PushTree[t];
PushNode[float, 1];
t ¬ SetAttributesPop[target];
bits ¬ Target.bitsPerReal;
};
WITH r: seb[cTarget]
SELECT
FROM
real => IF bits < r.length THEN t ¬ Lengthen[t, target];
ENDCASE;
RETURN [t];
};
Binary arithmetic class determination
AttrClass:
PROC [type: Type]
RETURNS [ac: ArithClass] = {
sei: CSEIndex = ClearType[type, TRUE];
bits: NAT ¬ 0;
grain: NAT ¬ Target.bitsPerWord;
ac ¬ [none, 0];
IF binaryClassTable = NIL THEN InitClassTable[];
WITH se: seb[sei]
SELECT
FROM
signed => {bits ¬ se.length; ac.kind ¬ signed};
unsigned => {bits ¬ se.length; ac.kind ¬ unsigned};
real => {bits ¬ se.length; grain ¬ Target.bitsPerReal; ac.kind ¬ real};
ENDCASE;
IF
NOT dontResolvePrecisions
THEN
Try to resolve precisions in Pass3 (historical)
WHILE bits > grain
DO
ac.precision ¬ ac.precision.SUCC;
bits ¬ bits - grain;
ENDLOOP;
IF dontCareAboutSigns
THEN
SELECT ac.kind
FROM
signed => ac.kind ¬ either;
unsigned => ac.kind ¬ either;
ENDCASE;
};
generatedTypes: REF GenTypeSeq ¬ NIL;
GenTypeSeq:
TYPE =
RECORD [
len: NAT, elements: SEQUENCE max: NAT OF GenTypeEntry
];
GenTypeEntry:
TYPE =
RECORD [
ac: ArithClass,
type: Type
];
MakeEntry:
PROC [ac: ArithClass, type: Type] = {
len: NAT ¬ generatedTypes.len;
IF len = generatedTypes.max
THEN {
new: REF GenTypeSeq ¬ MimZones.tempZone.NEW[GenTypeSeq[len+16]];
new.len ¬ len;
OSMiscOps.Copy[
from: @generatedTypes[0],
nwords: WORDS[GenTypeSeq[len]] - WORDS[GenTypeSeq[0]],
to: @new[0]];
MimZones.tempZone.FREE[@generatedTypes];
generatedTypes ¬ new;
};
generatedTypes[len] ¬ [ac, type];
generatedTypes.len ¬ len+1;
};
AttrClassToType:
PROC [ac: ArithClass]
RETURNS [Type] = {
IF generatedTypes =
NIL
THEN {
Make the initial table and fill it with common arithmetic types
generatedTypes ¬ MimZones.tempZone.NEW[GenTypeSeq[16]];
generatedTypes.len ¬ 0;
MakeEntry[[either, 0], MimData.idNAT];
MakeEntry[AttrClass[MimData.idINTEGER], MimData.idINTEGER];
MakeEntry[AttrClass[MimData.idCARDINAL], MimData.idCARDINAL];
MakeEntry[AttrClass[MimData.idREAL], MimData.idREAL];
MakeEntry[AttrClass[MimData.idDREAL], MimData.idDREAL];
};
FOR i:
NAT
IN [0..generatedTypes.len)
DO
IF generatedTypes[i].ac = ac THEN RETURN [generatedTypes[i].type];
ENDLOOP;
SELECT ac.kind
FROM
either => ERROR;
signed => {
type: Type ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.signed.SIZE];
bits: NAT ¬ Target.bitsPerWord*(ac.precision+1);
seb[type] ¬ [mark3:
TRUE, mark4:
TRUE, body: cons[
align: MimData.bitsToAlignment[bits],
typeInfo: signed[length: bits]]];
RETURN [type];
};
unsigned => {
type: Type ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.unsigned.SIZE];
bits: NAT ¬ Target.bitsPerWord*(ac.precision+1);
seb[type] ¬ [mark3:
TRUE, mark4:
TRUE, body: cons[
align: MimData.bitsToAlignment[bits],
typeInfo: unsigned[length: bits]]];
RETURN [type];
};
real => {
type: Type ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.real.SIZE];
bits: NAT ¬ Target.bitsPerReal*(ac.precision+1);
seb[type] ¬ [mark3:
TRUE, mark4:
TRUE, body: cons[
align: MimData.bitsToAlignment[bits],
typeInfo: real[length: bits]]];
RETURN [type];
};
ENDCASE;
RETURN [nullType];
};
ArithKind: TYPE = {none, address, either, signed, unsigned, real};
ArithClassTable: TYPE = ARRAY ArithKind OF ARRAY ArithKind OF ArithKind;
binaryClassTable: REF ArithClassTable ¬ NIL;
InitClassTable:
PROC = {
binaryClassTable ¬ MimZones.permZone.NEW[ArithClassTable ¬ ALL[ALL[none]]];
FOR i: ArithKind
IN ArithKind
DO
binaryClassTable[i][i] ¬ i;
ENDLOOP;
FOR i: ArithKind
IN ArithKind[signed..real]
DO
binaryClassTable[real][i] ¬ real;
binaryClassTable[i][real] ¬ real;
binaryClassTable[i][either] ¬ i;
binaryClassTable[either][i] ¬ i;
ENDLOOP;
binaryClassTable[unsigned][signed] ¬ signed;
binaryClassTable[signed][unsigned] ¬ signed;
};
MaxClass:
PROC [dstAc: ArithClass, srcAc: ArithClass]
RETURNS [rac: ArithClass] =
INLINE {
rac ¬ [binaryClassTable[dstAc.kind][srcAc.kind], MAX[dstAc.precision, srcAc.precision]];
};
Precision: TYPE = Tree.SubInfo;
ArithClass:
TYPE =
RECORD [kind: ArithKind, precision: Precision];
The kind indicates the properties of the arithmetic and the precision gives the number of words of precision-1.