Pass3Xb.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
Satterthwaite, June 24, 1986 12:32:28 pm PDT
Donahue, 9-Dec-81 15:32:12
Paul Rovner, September 6, 1983 10:59 pm
Russ Atkinson (RRA) December 1, 1986 6:35:51 pm PST
DIRECTORY
A3: TYPE USING [BaseType, Bundling, CanonicalType, IdentifiedType, IndexType, MarkedType, NewableType, NullableType, OperandInline, OrderedType, PermanentType, TargetType, TypeForTree, Unbundle],
Alloc: TYPE USING [Notifier],
ComData: TYPE USING [idATOM, idBOOL, idCARDINAL, idCHAR, idINT, idREAL, idSTRING, idTEXT, interface, ownSymbols, typeAtomRecord, typeCHAR, typeINT],
ComDataExtras: TYPE USING [idCARD32],
LiteralOps: TYPE USING [FindHeapString],
Log: TYPE USING [Error, ErrorHti, ErrorN, ErrorNode, ErrorNodeOp, ErrorSei, ErrorTree, ErrorTreeOp, ErrorType, Warning],
P3: TYPE USING [Attr, emptyAttr, fullAttr, voidAttr, NarrowOp, NPUse, BoundNP, MergeNP, SequenceNP, TextForm, phraseNP, AddrOp, All, And, Apply, Assignment, Case, CatchPhrase, ClearRefStack, Cons, Discrimination, Dot, EnterType, Extract, Id, ListCons, MakeLongType, MakeRefType, MiscXfer, Narrowing, New, Range, RecordMention, SealRefStack, SearchCtxList, TextRep, TypeAppl, TypeExp, UnsealRefStack],
P3S: TYPE USING [ImplicitInfo, implicitRecord, safety, self],
SymLiteralOps: TYPE USING [EnterAtom, EnterText],
Symbols: TYPE USING [Base, HTIndex, Type, ISEIndex, CSEIndex, RecordSEIndex, nullType, CSENull, RecordSENull, codeANY, codeCHAR, codeINT, typeANY, ctxType, seType],
SymbolOps: TYPE USING [ConstantId, EqTypes, NormalType, RCType, TypeForm, TypeRoot, UnderType],
Tree: TYPE USING [Base, Index, Link, Map, NodeName, Null, NullIndex, treeType],
TreeOps: TYPE USING [FreeNode, GetHash, GetNode, ListLength, PopTree, PushTree, PushNode, SetAttr, SetInfo, UpdateList],
Types: TYPE USING [SymbolTableBase, Assignable, Equivalent];
Pass3Xb: PROGRAM
IMPORTS
A3, ComDataExtras, LiteralOps, Log, P3, P3S, SymLiteralOps, SymbolOps, TreeOps, Types, dataPtr: ComData
EXPORTS P3, P3S = {
OPEN SymbolOps, Symbols, TreeOps, A3, P3;
tb: Tree.Base; -- tree base address (local copy)
seb: Base; -- se table base address (local copy)
ctxb: Base; -- context table base address (local copy)
own: Types.SymbolTableBase;
ExpBNotify: PUBLIC Alloc.Notifier = {
called by allocator whenever table area is repacked
seb ← base[seType]; ctxb ← base[ctxType];
tb ← base[Tree.treeType]};
intermediate result bookkeeping
OperandDescriptor: TYPE = RECORD[
type: Type,  -- type of operand
attr: Attr];  -- attributes
RStack: TYPE = RECORD [SEQUENCE length: NAT OF OperandDescriptor];
rStack: REF RStack ← NIL;
rI: INTEGER;   -- index into rStack
RPush: PUBLIC PROC[type: Type, attr: Attr] = {
rI ← rI + 1;
WHILE rI >= rStack.length DO
newLength: NAT = rStack.length + 16;
newStack: REF RStack = NEW[RStack[newLength]];
FOR i: INTEGER IN [0 .. rI) DO newStack[i] ← rStack[i] ENDLOOP;
rStack ← newStack;
ENDLOOP;
rStack[rI] ← [type:type, attr:attr]};
RPop: PUBLIC PROC = {IF rI < 0 THEN ERROR; rI ← rI-1};
RType: PUBLIC PROC RETURNS[Type] = {RETURN[rStack[rI].type]};
RAttr: PUBLIC PROC RETURNS[Attr] = {RETURN[rStack[rI].attr]};
UType: PUBLIC PROC RETURNS[CSEIndex] = {RETURN[UnderType[rStack[rI].type]]};
longUnsigned: Type; -- a hint for mwconst
textType: ARRAY TextForm OF Type;  -- a hint for text literals
ExpInit: PUBLIC PROC = {
implicit ← [type: typeANY, tree: Tree.Null, attr: emptyAttr];
P3S.implicitRecord ← RecordSENull;
own ← dataPtr.ownSymbols; -- make a parameter?
longUnsigned ← nullType; textType ← ALL[nullType];
rStack ← NEW[RStack[32]];
rI ← -1};
ExpReset: PUBLIC PROC = {
IF rStack # NIL THEN rStack ← NIL};
type manipulation
EqualTypes: PROC[type1, type2: Type] RETURNS[BOOL] = {
RETURN[Types.Equivalent[[own, UnderType[type1]], [own, UnderType[type2]]]]};
UnresolvedTypes: SIGNAL RETURNS[Type] = CODE;
BalanceTypes: PROC[type1, type2: Type] RETURNS[type: Type] = {
sei1: CSEIndex ← UnderType[type1];
sei2: CSEIndex ← UnderType[type2];
SELECT TRUE FROM
(sei1 = sei2), (sei2 = typeANY) => type ← type1;
(sei1 = typeANY) => type ← type2;
ENDCASE => {
n1: CARDINAL ← Bundling[sei1];
n2: CARDINAL ← Bundling[sei2];
WHILE n1 > n2 DO
type1 ← Unbundle[LOOPHOLE[sei1]]; sei1 ← UnderType[type1]; n1 ← n1-1
ENDLOOP;
WHILE n2 > n1 DO
type2 ← Unbundle[LOOPHOLE[sei2]]; sei2 ← UnderType[type1]; n2 ← n2-1
ENDLOOP;
check bundling
DO
type1 ← TargetType[type1]; sei1 ← UnderType[type1];
type2 ← TargetType[type2]; sei2 ← UnderType[type2];
SELECT TRUE FROM
Types.Assignable[[own, sei1], [own, sei2]] => {type ← type1; EXIT};
Types.Assignable[[own, sei2], [own, sei1]] => {type ← type2; EXIT};
ENDCASE;
IF n1 = 0 THEN GO TO Fail;
n1 ← n1-1;
type1 ← Unbundle[LOOPHOLE[sei1]];
type2 ← Unbundle[LOOPHOLE[sei2]];
REPEAT
Fail => type ← SIGNAL UnresolvedTypes;
ENDLOOP};
RETURN};
ForceType: PUBLIC PROC[t: Tree.Link, type: Type] RETURNS[Tree.Link] = {
PushTree[t];
IF t = Tree.Null THEN PushNode[cast, 1]
ELSE WITH t SELECT FROM
subtree =>
SELECT tb[index].name FROM
construct, union, rowcons => PushNode[cast, 1];
openx => PushNode[cast, 1];
ENDCASE;
ENDCASE => PushNode[cast, 1];
SetInfo[type]; RETURN[PopTree[]]};
operators
UpArrow: PUBLIC PROC[node: Tree.Index] = {
type: Type;
attr: Attr;
tb[node].son[1] ← Exp[tb[node].son[1], typeANY];
type ← RType[]; attr ← RAttr[]; RPop[]; attr.const ← FALSE;
DO
nType: CSEIndex = NormalType[type];
WITH t: seb[nType] SELECT FROM
ref => {
RPush[t.refType, attr];
tb[node].attr2 ← (TypeForm[type] = $long);
IF P3S.safety = checked AND ~(t.counted OR PermanentType[t.refType]) THEN
Log.ErrorNodeOp[unsafeOp, node, uparrow];
EXIT};
record => {
IF Bundling[nType] = 0 THEN GO TO fail;
type ← Unbundle[LOOPHOLE[nType, RecordSEIndex]]};
ENDCASE => GO TO fail;
REPEAT
fail => {
IF type # typeANY THEN Log.ErrorTreeOp[missingOp, tb[node].son[1], uparrow];
RPush[typeANY, attr]};
ENDLOOP
};
arithmetic expression manipulation
MakeNumeric: PROC[type: Type] RETURNS[Type] = {
RETURN[SELECT TypeForm[type] FROM
long => MakeLongType[dataPtr.idINT, type],
ENDCASE => dataPtr.idINT]
};
EvalNumeric: PROC[t: Tree.Link, op: Tree.NodeName←$none] RETURNS[val: Tree.Link] = {
val ← GenericRhs[t, dataPtr.idINT];
SELECT NormalType[rStack[rI].type] FROM
dataPtr.typeINT => NULL;
typeANY => rStack[rI].type ← MakeNumeric[rStack[rI].type];
ENDCASE =>
IF op # $none THEN Log.ErrorTreeOp[missingOp, val, op]
ELSE Log.ErrorTree[typeClash, val];
RETURN};
ArithOp: PROC[node: Tree.Index] = {
OPEN tb[node];
saveNP: NPUse;
son[1] ← EvalNumeric[son[1], tb[node].name]; saveNP ← phraseNP;
son[2] ← EvalNumeric[son[2]];
BalanceAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];
IF attr1 THEN rStack[rI-1].attr.const ← FALSE;
RPop[]; phraseNP ← MergeNP[saveNP][phraseNP]};
ArithType: PROC[type: Type] RETURNS[CSEIndex] = {
sei: CSEIndex = NormalType[type];
RETURN[WITH t: seb[sei] SELECT FROM
relative => NormalType[t.offsetType],
ENDCASE => sei]
};
Plus: PROC[node: Tree.Index] = {
OPEN tb[node];
type: CSEIndex;
lr: BOOL;
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← ArithType[rStack[rI].type];
IF seb[type].typeTag = ref OR type = dataPtr.typeCHAR THEN {
IF RCType[type] # none THEN Log.ErrorTreeOp[missingOp, son[1], plus];
lr ← TRUE; son[2] ← EvalNumeric[son[2]]}
ELSE {
SELECT type FROM
dataPtr.typeINT, typeANY => NULL;
ENDCASE => Log.ErrorTreeOp[missingOp, son[1], plus];
son[2] ← GenericRhs[son[2], typeANY];
lr ← FALSE; type ← ArithType[rStack[rI].type];
SELECT TRUE FROM
type = dataPtr.typeINT, type = dataPtr.typeCHAR => NULL;
seb[type].typeTag = ref =>
IF RCType[type] # none THEN Log.ErrorTree[typeClash, son[2]];
ENDCASE => {
IF type # typeANY THEN Log.ErrorTree[typeClash, son[2]];
rStack[rI].type ← MakeNumeric[rStack[rI].type]}};
IF P3S.safety = checked AND seb[type].typeTag = ref THEN
Log.ErrorNodeOp[unsafeOp, node, plus];
BalanceAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];
IF attr1 THEN rStack[rI-1].attr.const ← FALSE;
IF ~lr THEN rStack[rI-1].type ← rStack[rI].type;
RPop[]; phraseNP ← MergeNP[saveNP][phraseNP]};
Minus: PROC[node: Tree.Index] = {
OPEN tb[node];
type, lType, rType: CSEIndex;
lr: BOOL;
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← NormalType[rStack[rI].type]; lType ← ArithType[type]; lr ← TRUE;
IF seb[lType].typeTag = ref OR lType = dataPtr.typeCHAR THEN {
IF RCType[lType] # none THEN Log.ErrorTreeOp[missingOp, son[1], minus];
son[2] ← GenericRhs[son[2], typeANY]; rType ← ArithType[rStack[rI].type];
SELECT TRUE FROM
rType = typeANY => NULL;
Types.Equivalent[[own, lType], [own, rType]] => lr ← FALSE;
rType = dataPtr.typeINT => NULL;
ENDCASE => Log.ErrorTree[typeClash, son[2]]}
ELSE {
SELECT type FROM
dataPtr.typeINT, typeANY => NULL;
ENDCASE => {
Log.ErrorTreeOp[missingOp, son[1], minus]; rStack[rI].type ← typeANY};
son[2] ← EvalNumeric[son[2]]};
IF P3S.safety = checked AND seb[lType].typeTag = ref THEN
Log.ErrorNodeOp[unsafeOp, node, minus];
BalanceAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];
IF attr1 THEN rStack[rI-1].attr.const ← FALSE;
IF ~lr THEN rStack[rI-1].type ←
IF attr2 THEN MakeLongType[dataPtr.typeINT, rStack[rI].type] ELSE dataPtr.typeINT;
RPop[]; phraseNP ← MergeNP[saveNP][phraseNP]};
UnaryOp: PROC[node: Tree.Index] = {
IF UniOperand[node] THEN {
tb[node].son[1] ← EvalNumeric[tb[node].son[1], tb[node].name]; SetAttributes[node];
IF tb[node].attr1 THEN rStack[rI].attr.const ← FALSE}
};
EnumOp: PROC[node: Tree.Index, target: Type] = {
IF UniOperand[node] THEN {
tb[node].son[1] ← GenericRhs[tb[node].son[1], target]; SetAttributes[node];
IF ~IndexType[RType[]] THEN
Log.ErrorTreeOp[missingOp, tb[node].son[1], tb[node].name]}
};
RelOp: PROC[node: Tree.Index, ordered: BOOL] = {
OPEN tb[node];
type, target: Type;
attr: Attr;
saveNP: NPUse;
implicitOp: BOOL;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← RType[]; target ← BaseType[type]; attr ← RAttr[];
implicitOp ← (son[1] = Tree.Null);
son[2] ← GenericRhs[son[2], target];
type ← BalanceTypes[target, BaseType[RType[]]
! UnresolvedTypes => {
Log.ErrorType[typeClash, son[2], [dataPtr.ownSymbols, type]];
RESUME[typeANY]}];
IF (ordered AND ~OrderedType[type]) OR (~ordered AND ~IdentifiedType[type]) THEN
Log.ErrorTreeOp[missingOp, son[1], name];
BalanceAttributes[node];
attr ← And[attr, RAttr[]];
IF implicitOp AND son[1] # Tree.Null THEN Log.ErrorTree[typeClash, son[2]];
SELECT TypeForm[type] FROM
$basic, $enumerated => NULL;
$transfer => {
IF OperandInline[son[1]] THEN Log.ErrorTree[misusedInline, son[1]];
IF OperandInline[son[2]] THEN Log.ErrorTree[misusedInline, son[2]];
attr.const ← FALSE};
$real => attr.const ← FALSE;
ENDCASE;
RPop[]; RPop[];
RPush[dataPtr.idBOOL, attr]; phraseNP ← MergeNP[saveNP][phraseNP]};
In: PROC[node: Tree.Index] = {
OPEN tb[node];
type: Type;
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← RType[];
son[2] ← Range[son[2], CanonicalType[type]];
[] ← BalanceTypes[BaseType[type], BaseType[RType[]]
! UnresolvedTypes => {
Log.ErrorType[typeClash, tb[node].son[1], [dataPtr.ownSymbols, RType[]]];
RESUME[typeANY]}];
BalanceAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr]; RPop[];
rStack[rI].type ← dataPtr.idBOOL;
phraseNP ← MergeNP[saveNP][phraseNP]};
BoolOp: PROC[node: Tree.Index] = {
OPEN tb[node];
attr: Attr;
saveNP: NPUse;
SealRefStack[];
son[1] ← Rhs[son[1], dataPtr.idBOOL]; attr ← RAttr[]; saveNP ← phraseNP;
ClearRefStack[];
son[2] ← Rhs[son[2], dataPtr.idBOOL];
UnsealRefStack[];
attr ← And[attr, RAttr[]];
RPop[]; RPop[];
RPush[dataPtr.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 ← RAttr[];
IF constant AND ~attr.const THEN Log.ErrorTree[nonConstant, tb[node].son[1]];
tb[node].son[2] ← BalancedRhs[tb[node].son[2], target];
rStack[rI].type ← CanonicalType[rStack[rI].type];
[] ← BalanceTypes[BaseType[type], BaseType[RType[]]
! UnresolvedTypes => {Log.ErrorTree[typeClash, tb[node].son[2]]; RESUME[typeANY]}];
attr ← And[attr, RAttr[]];
IF constant AND ~RAttr[].const THEN Log.ErrorTree[nonConstant, tb[node].son[2]];
BalanceAttributes[node];
IF tb[node].attr1 THEN attr.const ← FALSE;
phraseNP ← MergeNP[saveNP][phraseNP];
RPop[]; rStack[rI].attr ← attr};
BalancedTarget: PROC[target, type: Type] RETURNS[Type] = {
RETURN[IF target = typeANY
OR (~EqualTypes[type, target] AND EqTypes[NormalType[type], target])
THEN TargetType[type]
ELSE target]
};
ResolveTypes: PROC[type1, type2, target: Type, t: Tree.Link] RETURNS[type: Type] = {
failed: BOOL;
IF target = typeANY THEN failed ← TRUE
ELSE {
ENABLE UnresolvedTypes => {failed ← TRUE; RESUME[typeANY]};
failed ← FALSE;
type ← BalanceTypes[BalanceTypes[target, type1], BalanceTypes[target, type2]]};
IF failed THEN {
Log.ErrorType[
typeClash, t, [dataPtr.ownSymbols, CanonicalType[type1]]];
type ← typeANY};
RETURN};
IfExp: PROC[node: Tree.Index, target: Type] = {
OPEN tb[node];
type: Type;
attr: Attr;
entryNP, saveNP: NPUse;
SealRefStack[];
son[1] ← Rhs[son[1], dataPtr.idBOOL];
attr ← RAttr[]; RPop[]; entryNP ← phraseNP;
UnsealRefStack[];
son[2] ← BalancedRhs[son[2], target];
attr ← And[attr, RAttr[]]; saveNP ← SequenceNP[entryNP][phraseNP];
type ← RType[]; RPop[];
target ← BalancedTarget[target, type];
son[3] ← BalancedRhs[son[3], target]; attr ← And[attr, RAttr[]];
type ← BalanceTypes[type, RType[]
! UnresolvedTypes => {RESUME[ResolveTypes[type, RType[], target, son[3]]]}];
IF TypeForm[type] = $transfer THEN {
IF OperandInline[son[2]] THEN Log.ErrorTree[misusedInline, son[2]];
IF OperandInline[son[3]] THEN Log.ErrorTree[misusedInline, son[3]];
attr.const ← FALSE};
phraseNP ← BoundNP[saveNP][SequenceNP[entryNP][phraseNP]];
RPop[]; RPush[type, attr]};
SelectExp: PROC[
node: Tree.Index, target: Type, driver: PROC[Tree.Index, Tree.Map], foldable: BOOL] = {
type: Type;
attr: Attr;
saveNP: NPUse;
started: BOOL;
Selection: Tree.Map = {
subType: Type;
entryNP: NPUse = phraseNP;
v ← BalancedRhs[t, target];
subType ← BalanceTypes[type, RType[]
! UnresolvedTypes => {RESUME[ResolveTypes[type, RType[], target, v]]}];
IF TypeForm[subType] = $transfer AND OperandInline[v] THEN
Log.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, RAttr[]]; RPop[]; started ← TRUE; RETURN};
type ← typeANY; attr ← fullAttr; started ← FALSE; saveNP ← none;
driver[node, Selection]; attr ← And[attr, RAttr[]]; RPop[];
attr.const ← foldable AND attr.const AND tb[node].attr2;
RPush[type, attr]; phraseNP ← saveNP};
MinMax: PROC[node: Tree.Index, target: Type] = {
OPEN tb[node];
attr: Attr;
saveNP: NPUse;
started: BOOL;
type: Type;
SubMinMax: Tree.Map = {
subType, cType: Type;
v ← BalancedRhs[t, target];
attr ← And[attr, RAttr[]]; saveNP ← MergeNP[saveNP][phraseNP];
cType ← CanonicalType[RType[]];
subType ← BalanceTypes[type, cType
! UnresolvedTypes => {RESUME[ResolveTypes[type, cType, target, v]]}];
IF subType # typeANY THEN {
IF ~started THEN {
IF ~OrderedType[subType] THEN Log.ErrorTreeOp[missingOp, v, name];
target ← BalancedTarget[target, subType]; started ← TRUE}
ELSE IF ~EqTypes[type, subType] THEN
IF ~OrderedType[subType] THEN Log.ErrorTree[typeClash, v];
type ← subType};
RPop[]; RETURN};
attr ← fullAttr; saveNP ← none; started ← FALSE; type ← typeANY;
son[1] ← UpdateList[son[1], SubMinMax];
SELECT TypeForm[type] FROM
long => {attr1 ← FALSE; attr2 ← TRUE};
real => {attr1 ← TRUE; attr2 ← FALSE; attr.const ← FALSE};
ENDCASE => attr1 ← attr2 ← FALSE;
RPush[type, attr]; phraseNP ← saveNP};
TypeTest: PROC[node: Tree.Index, from, to: Type] = {
subType: Type = CanonicalType[from];
op: NarrowOp = Narrowing[type: subType, target: to];
SELECT TRUE FROM
op.error => Log.ErrorTree[typeClash, tb[node].son[1]];
op.computed => Log.ErrorTree[missingBinding, tb[node].son[1]];
op.unImpl => Log.Warning[opaqueTest];
ENDCASE;
IF ~EqTypes[subType, from] THEN tb[node].son[1] ← ForceType[tb[node].son[1], subType];
tb[node].attr1 ← op.indirect;
IF (tb[node].attr2 ← op.rtTest) THEN EnterType[MarkedType[to]];
tb[node].attr3 ← op.tagTest};
EndPoint: PROC[node: Tree.Index] = {
OPEN tb[node];
type: CSEIndex;
son[1] ← TypeExp[son[1]];
type ← UnderType[TypeForTree[son[1]]];
BEGIN
WITH seb[type] SELECT FROM
basic =>
SELECT code FROM
codeINT, codeCHAR => NULL;
ENDCASE => GO TO fail;
enumerated => NULL;
relative => IF TypeForm[offsetType] # $subrange THEN GO TO fail;
subrange, relative => NULL;
long => IF NormalType[rangeType] # dataPtr.typeINT THEN GO TO fail;
ENDCASE => GO TO fail;
EXITS
fail => Log.ErrorTreeOp[missingAttr, son[1], name];
END;
RPush[type, fullAttr]};
Unspec: PROC[type: Type] RETURNS[BOOL] = {
sei: CSEIndex = UnderType[type];
RETURN[WITH t: seb[sei] SELECT FROM
basic => t.code = codeANY,
ENDCASE => FALSE]
};
SafeForUnspec: PROC[target: Type] RETURNS[BOOL] = {
RETURN[P3S.safety # checked OR RCType[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 ← UnderType[lhsType]; rhsSei ← UnderType[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 ← UnderType[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]};
ref, arraydesc => {
SELECT TypeForm[lhsSei] FROM
$long => {
IF ~Types.Assignable[[own, NormalType[lhsSei]], [own, rhsSei]] THEN
GO TO nomatch;
val ← Lengthen[val, MakeLongType[rhsType, lhsType]]};
ENDCASE => GO TO nomatch;
rhsType ← lhsType};
basic => {
IF Unspec[rhsSei] AND SafeForUnspec[lhsSei] THEN
SELECT TypeForm[lhsSei] FROM
$long => val ← Lengthen[val, MakeLongType[typeANY, lhsType]];
ENDCASE
ELSE SELECT TypeForm[lhsSei] FROM
$long => {
IF ~Types.Assignable[[own, NormalType[lhsSei]], [own, rhsSei]] THEN
GO TO nomatch;
val ← Lengthen[val, lhsType]};
$real =>
IF rhsSei = dataPtr.typeINT THEN {
val ← Float[val, rhsType, lhsType]; rStack[rI].attr.const ← FALSE}
ELSE GO TO nomatch;
ENDCASE => GO TO nomatch;
rhsType ← lhsType};
long => {
subType: CSEIndex = NormalType[rhsSei];
SELECT TypeForm[lhsSei] FROM
$long =>
SELECT TRUE FROM
Unspec[NormalType[lhsSei]] => {
lhsType ← rhsType; lhsSei ← UnderType[lhsType]};
Unspec[subType] AND SafeForUnspec[lhsSei] =>
rhsType ← lhsType;
ENDCASE => GO TO nomatch;
$real =>
IF subType = dataPtr.typeINT THEN {
val ← Float[val, rhsType, lhsType]; rStack[rI].attr.const ← FALSE;
rhsType ← lhsType}
ELSE GO TO nomatch;
$basic, $subrange => {
IF ~Types.Assignable[[own, subType], [own, lhsSei]] THEN
GO TO nomatch;
rhsType ← UnderType[t.rangeType]; val ← Shorten[val, rhsType]};
ENDCASE => GO TO nomatch};
ENDCASE => GO TO nomatch;
rhsSei ← UnderType[rhsType];
REPEAT
nomatch => { -- no coercion is possible
Log.ErrorType[typeClash,
IF exp = Tree.Null THEN implicit.tree ELSE val,
[dataPtr.ownSymbols, lhsType]];
rhsType ← lhsType};
ENDLOOP;
rStack[rI].type ← rhsType};
IF TypeForm[rhsType] = $transfer AND OperandInline[val] THEN
Log.ErrorTree[misusedInline, val];
RETURN};
GenericRhs: PROC[exp: Tree.Link, target: Type] RETURNS[val: Tree.Link] = {
type: Type;
val ← Exp[exp, target]; type ← rStack[rI].type;
put value in canonical form
DO
sei: CSEIndex = UnderType[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;
RETURN};
BalancedRhs: PROC[exp: Tree.Link, target: Type] RETURNS[val: Tree.Link] = {
val ← Exp[exp, target];
SELECT TypeForm[target] FROM
$long, $real => {
type: Type = CanonicalType[rStack[rI].type];
IF type # typeANY AND TypeForm[target] # TypeForm[type]
AND EqualTypes[NormalType[target], type] THEN {
SELECT TypeForm[target] FROM
$long =>
IF TypeForm[type] # $real THEN
val ← Lengthen[val, MakeLongType[type, target]];
$real => {val ← Float[val, type, target]; rStack[rI].attr.const ← FALSE};
ENDCASE;
rStack[rI].type ← target}};
ENDCASE;
RETURN};
AttrClass: PROC[type: Type] RETURNS[{short, long, real}] = {
sei: CSEIndex = UnderType[type];
RETURN[WITH t: seb[sei] SELECT FROM
long => $long,
real => $real,
relative => AttrClass[UnderType[t.offsetType]],
ENDCASE => $short]
};
SetAttributes: PROC[node: Tree.Index] = {
SELECT AttrClass[rStack[rI].type] FROM
$long => {tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE};
$real => {tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE};
ENDCASE => tb[node].attr1 ← tb[node].attr2 ← FALSE
};
BalanceAttributes: PROC[node: Tree.Index] = {
lType, rType: Type;
lType ← rStack[rI-1].type; rType ← rStack[rI].type;
SELECT AttrClass[lType] FROM
$long => {
SELECT AttrClass[rType] FROM
$long => {tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE};
$real => {
rStack[rI-1].type ← rType;
tb[node].son[1] ← Float[tb[node].son[1], lType, rType];
rStack[rI-1].attr.const ← FALSE;
tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE};
ENDCASE => {
rStack[rI].type ← rType ← MakeLongType[rType, lType];
tb[node].son[2] ← Lengthen[tb[node].son[2], rType];
tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE}};
$real => {
tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE;
SELECT AttrClass[rType] FROM
$real => NULL;
ENDCASE => {
rStack[rI].type ← lType;
tb[node].son[2] ← Float[tb[node].son[2], rType, lType];
rStack[rI].attr.const ← FALSE}};
ENDCASE =>
SELECT AttrClass[rType] FROM
$long => {
rStack[rI-1].type ← lType ← MakeLongType[lType, rType];
tb[node].son[1] ← Lengthen[tb[node].son[1], lType];
tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE};
$real => {
rStack[rI-1].type ← rType;
tb[node].son[1] ← Float[tb[node].son[1], lType, rType];
rStack[rI-1].attr.const ← FALSE;
tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE};
ENDCASE => tb[node].attr1 ← tb[node].attr2 ← FALSE
};
Lengthen: PROC[t: Tree.Link, target: Type] RETURNS[Tree.Link] = {
PushTree[t]; PushNode[lengthen, 1]; SetInfo[target]; RETURN[PopTree[]]};
Shorten: PROC[t: Tree.Link, target: Type] RETURNS[Tree.Link] = {
PushTree[t]; PushNode[shorten, 1]; SetInfo[target]; RETURN[PopTree[]]};
Float: PROC[t: Tree.Link, type, target: Type] RETURNS[Tree.Link] = {
PushTree[IF TypeForm[type] = $long
THEN t
ELSE Lengthen[t, MakeLongType[type, typeANY]]];
SELECT NormalType[type] FROM
dataPtr.typeINT => {PushNode[float, 1]; SetInfo[target]};
typeANY => NULL;
ENDCASE => Log.ErrorTree[typeClash, t];
RETURN[PopTree[]]};
expressions
implicit: PUBLIC P3S.ImplicitInfo; -- implied attributes of Tree.Null
Exp: PUBLIC PROC[exp: Tree.Link, target: Type] RETURNS[val: Tree.Link] = {
type: Type;
phraseNP ← none;
IF exp = Tree.Null THEN {RPush[implicit.type, implicit.attr]; RETURN[Tree.Null]};
WITH e: exp SELECT FROM
symbol => {
sei: ISEIndex = e.index;
attr: Attr;
attr.noXfer ← attr.noAssign ← TRUE; RecordMention[sei];
type ← seb[sei].idType;
SELECT ctxb[seb[sei].idCtx].ctxType FROM
included =>
IF ~(attr.const𡤌onstantId[sei]) THEN Log.ErrorSei[unimplemented, sei];
imported => attr.const ← ConstantId[sei];
ENDCASE => attr.const ← seb[sei].constant;
RPush[type, attr]; val ← exp};
hash => {
sei: CSEIndex = UnderType[target];
WITH t: seb[sei] SELECT FROM
enumerated => {
sei: ISEIndex;
IF ([sei: sei] ← SearchCtxList[e.index, t.valueCtx]).found THEN {
RPush[target, fullAttr]; val ← [symbol[sei]]}
ELSE val ← Id[e.index]};
ENDCASE => val ← Id[e.index];
};
literal => {
attr: Attr;
attr.noXfer ← attr.noAssign ← TRUE;
WITH e.index SELECT FROM
string => {
[val, type] ← StringRef[exp, target];
attr.const ← FALSE;
IF dataPtr.interface THEN Log.ErrorTree[interfaceString, exp]};
ENDCASE => {type ← dataPtr.typeINT; attr.const ← TRUE; val ← exp};
RPush[type, attr]};
subtree => {
node: Tree.Index ← e.index;
val ← exp; -- the default
SELECT tb[node].name FROM
dot => {node ← Dot[node, target]; val ← [subtree[node]]};
uparrow => UpArrow[node];
apply => {
node ← Apply[node, target, FALSE]; val ← [subtree[node]];
CheckNonVoid[node, target]};
uminus, abs => UnaryOp[node];
plus => Plus[node];
minus => Minus[node];
times, div, mod => ArithOp[node];
relE, relN => RelOp[node, FALSE];
relL, relGE, relG, relLE => RelOp[node, TRUE];
in, notin => In[node];
not => tb[node].son[1] ← Rhs[tb[node].son[1], dataPtr.idBOOL];
or, and => BoolOp[node];
ifx => IfExp[node, target];
casex => SelectExp[node, target, Case, TRUE];
bindx => SelectExp[node, target, Discrimination, FALSE];
assignx => Assignment[node];
extractx => {Extract[node]; CheckNonVoid[node, target]};
min, max => MinMax[node, target];
pred, succ => EnumOp[node, target];
addr, base, length, arraydesc => AddrOp[node, target];
all => All[node, target];
mwconst =>
IF tb[node].attr1 THEN RPush[dataPtr.idREAL, fullAttr]
ELSE {
IF longUnsigned = nullType THEN
longUnsigned ← MakeLongType[dataPtr.idCARDINAL, typeANY];
RPush[longUnsigned, fullAttr]};
void => RPush[target, voidAttr];
clit => RPush[dataPtr.idCHAR, fullAttr];
llit => {
attr: Attr ← fullAttr;
attr.const ← FALSE; RPush[dataPtr.idSTRING, attr]};
atom => {
hti: HTIndex = GetHash[tb[node].son[1]];
subTarget: CSEIndex = UnderType[target];
WITH t: seb[subTarget] SELECT FROM
enumerated => {
sei: ISEIndex;
IF ~([sei: sei]←SearchCtxList[hti, t.valueCtx]).found THEN
Log.ErrorHti[unknownId, hti];
tb[node].son[1] ← Tree.Null; FreeNode[node]; node ← Tree.NullIndex;
val ← [symbol[index: sei]]; RPush[target, fullAttr]};
ENDCASE => {
SymLiteralOps.EnterAtom[hti]; EnterType[dataPtr.typeAtomRecord, FALSE];
RPush[dataPtr.idATOM, [noAssign:TRUE, noXfer:TRUE, const:FALSE]]}
};
nil => {
OPEN tb[node];
SELECT TRUE FROM
(son[1] # Tree.Null) => {
son[1] ← TypeExp[son[1]]; type ← TypeForTree[son[1]];
IF ~NullableType[type] THEN Log.ErrorTreeOp[missingAttr, son[1], nil]};
~EqTypes[target, typeANY] => {
type ← target;
IF ~NullableType[type] THEN Log.ErrorTree[typeClash, val]};
ENDCASE => type ← MakeRefType[typeANY, typeANY];
RPush[type, fullAttr]};
new => New[node, target];
cons => {val ← Cons[node, target]; node ← GetNode[val]};
listcons => ListCons[node, target];
signalx, errorx, fork, joinx, create, startx => {
val ← MiscXfer[node, target];
node ← GetNode[val]; CheckNonVoid[node, target]};
syserrorx => {
RPush[CSENull, emptyAttr]; CheckNonVoid[node, target]};
lengthen => {
OPEN tb[node];
subType: CSEIndex;
son[1] ← GenericRhs[
son[1],
IF TypeForm[target] = $long THEN BaseType[target] ELSE target];
subType ← UnderType[TargetType[rStack[rI].type]];
IF subType = dataPtr.typeINT
OR seb[subType].typeTag = ref
OR seb[subType].typeTag = arraydesc
OR subType = typeANY THEN rStack[rI].type ← MakeLongType[subType, target]
ELSE {
Log.ErrorTreeOp[missingOp, son[1], lengthen]; rStack[rI].type ← typeANY}
};
narrow => {
OPEN tb[node];
IF son[2] = Tree.Null THEN {
IF target = typeANY THEN Log.ErrorNode[noTarget, node];
type ← target}
ELSE {son[2] ← TypeExp[son[2]]; type ← TypeForTree[son[2]]};
son[1] ← Exp[son[1], TargetType[type]];
TypeTest[node: node, from: rStack[rI].type, to: type];
IF attr3 AND ~attr1 AND son[2] = Tree.Null THEN Log.ErrorNode[noTarget, node];
IF RCType[type] = simple THEN {
nType: CSEIndex = NormalType[type];
WITH t: seb[nType] SELECT FROM
ref => EnterType[t.refType, FALSE];
ENDCASE => NULL};
IF tb[node].nSons > 2 THEN [] ← CatchPhrase[tb[node].son[3]];
rStack[rI].type ← type;
rStack[rI].attr.const ← rStack[rI].attr.noXfer ← FALSE};
istype => {
OPEN tb[node];
son[1] ← Exp[son[1], typeANY];
son[2] ← TypeExp[son[2]];
TypeTest[node: node, from: RType[], to: TypeForTree[son[2]]];
rStack[rI].type ← dataPtr.idBOOL; rStack[rI].attr.const ← FALSE};
safen => tb[node].son[1] ← Exp[tb[node].son[1], target];
loophole => {
OPEN tb[node];
son[1] ← Exp[son[1], typeANY];
IF TypeForm[RType[]] = $transfer AND OperandInline[son[1]] THEN
Log.ErrorTree[misusedInline, son[1]];
IF son[2] = Tree.Null THEN {
IF target = typeANY THEN Log.ErrorNode[noTarget, node];
rStack[rI].type ← target}
ELSE {
son[2] ← TypeExp[son[2]];
rStack[rI].type ← TypeForTree[son[2]]};
IF RCType[rStack[rI].type] # none THEN {
rStack[rI].attr.const ← FALSE;
IF P3S.safety = checked THEN Log.ErrorNodeOp[unsafeOp, node, loophole]}
};
size => {
OPEN tb[node];
attr: Attr;
son[1] ← TypeAppl[son[1]]; attr ← RAttr[]; RPop[];
IF ~NewableType[TypeForTree[son[1]]] THEN
Log.ErrorTreeOp[missingAttr, son[1], size];
IF son[2] # Tree.Null THEN {
saveNP: NPUse = phraseNP;
son[2] ← Rhs[son[2], dataPtr.idINT];
attr ← And[attr, RAttr[]]; RPop[];
phraseNP ← MergeNP[saveNP][phraseNP];
};
IF tb[node].attr1
THEN RPush[ComDataExtras.idCARD32, attr]
Long result for BITS
ELSE RPush[dataPtr.idINT, attr];
Small result for SIZE
};
first, last => EndPoint[node];
typecode => {
tb[node].son[1] ← TypeExp[tb[node].son[1]];
EnterType[TypeForTree[tb[node].son[1]], FALSE];
RPush[typeANY, fullAttr]};
self => {
val ← P3S.self.tree; P3S.self.tree ← Tree.Null;
phraseNP ← P3S.self.np; RPush[P3S.self.type, P3S.self.attr];
FreeNode[node]; node ← Tree.NullIndex};
cast => {
tb[node].son[1] ← Exp[tb[node].son[1], target];
rStack[rI].type ← target};
ord =>
IF UniOperand[node] THEN {
tb[node].son[1] ← GenericRhs[tb[node].son[1], typeANY]; SetAttributes[node];
IF ~IndexType[RType[]] THEN
Log.ErrorTreeOp[missingOp, tb[node].son[1], ord];
rStack[rI].type ← MakeNumeric[RType[]]};
val =>
IF UniOperand[node] THEN {
IF ~IndexType[target] THEN Log.ErrorNode[noTarget, node];
tb[node].son[1] ← EvalNumeric[tb[node].son[1]];
rStack[rI].type ← target};
stringinit => {
tb[node].son[2] ← Rhs[tb[node].son[2], dataPtr.idCARDINAL];
IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, tb[node].son[2]];
RPop[]; RPush[dataPtr.idSTRING, voidAttr]};
ENDCASE =>
IF tb[node].name = item THEN tb[node].son[2] ← Exp[tb[node].son[2], target]
ELSE {Log.Error[unimplemented]; RPush[typeANY, emptyAttr]};
IF node # Tree.NullIndex THEN tb[node].info ← rStack[rI].type};
ENDCASE;
RETURN};
CheckNonVoid: PROC[node: Tree.Index, target: Type] = {
IF rStack[rI].type = nullType THEN
SELECT tb[node].name FROM
error => {tb[node].name ← errorx; rStack[rI].type ← target};
errorx, syserrorx => rStack[rI].type ← target;
ENDCASE => {Log.ErrorNode[typeClash, node]; rStack[rI].type ← typeANY}
};
VoidExp: PUBLIC PROC[exp: Tree.Link] RETURNS[val: Tree.Link] = {
val ← Exp[exp, typeANY]; RPop[]; RETURN};
UniOperand: PROC[node: Tree.Index] RETURNS[valid: BOOL] = {
l: CARDINAL = ListLength[tb[node].son[1]];
IF ~(valid ← l=1) THEN {
IF l > 1 THEN Log.ErrorN[listLong, l-1] ELSE Log.ErrorN[listShort, l+1];
tb[node].son[1] ← UpdateList[tb[node].son[1], VoidExp];
RPush[typeANY, emptyAttr]};
RETURN};
overloaded string literals
StringRef: PROC[t: Tree.Link, target: Type] RETURNS[v: Tree.Link, type: Type] = {
IF RCType[target] = none THEN {type ← dataPtr.idSTRING; v ← t}
ELSE {
nType: CSEIndex = NormalType[target];
rType: Type = WITH t: seb[nType] SELECT FROM
ref => t.refType,
ENDCASE => dataPtr.idTEXT;
form: TextForm = TextRep[rType];
cType: Type = (IF form = text THEN dataPtr.idTEXT ELSE rType);
type ← textType[form];
IF type = CSENull THEN {
type ← MakeLongType[MakeRefType[cType: cType, hint: nType, counted: TRUE], target];
textType[form] ← type};
EnterType[TypeRoot[cType], FALSE];
WITH e: t SELECT FROM
literal =>
WITH e.index SELECT FROM
string => {
sti ← LiteralOps.FindHeapString[sti, TypeRoot[cType]];
SymLiteralOps.EnterText[sti]};
ENDCASE;
ENDCASE;
PushTree[t]; PushNode[textlit, 1];
SetAttr[2, TRUE]; SetInfo[type]; v ← PopTree[]};
RETURN};
}.