-- file Pass3Xb.mesa
-- last modified by Satterthwaite, March 9, 1983 3:13 pm
-- last modified by Donahue, 9-Dec-81 15:32:12
DIRECTORY
A3: TYPE USING [
Bundling, CanonicalType, IdentifiedType, IndexType, MarkedType, NullableType,
OperandInline, OrderedType, PermanentType, TargetType, TypeForTree, Unbundle],
Alloc: TYPE USING [Notifier],
ComData: TYPE USING [
idCARDINAL, idTEXT, interface, ownSymbols,
typeATOM, typeAtomRecord, typeBOOL, typeCHAR, typeINT, typeREAL, typeSTRING],
LiteralOps: TYPE USING [FindHeapString],
Log: TYPE USING [Error, ErrorHti, ErrorN, ErrorNode, ErrorSei, ErrorTree, Warning],
P3: TYPE USING [
Attr, emptyAttr, fullAttr, voidAttr,
NarrowOp, NPUse, BoundNP, MergeNP, SequenceNP, TextForm, phraseNP,
AddrOp, All, And, Apply, Assignment, Case, CatchPhrase, ClearRefStack,
Discrimination, Dot, EnterType, Extract, Id, MakeLongType, MakeRefType,
MiscXfer, Narrowing, 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, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CSENull,
RecordSENull, codeANY, codeCHAR, codeINT, typeANY, ctxType, seType],
SymbolOps: TYPE USING [ConstantId, NormalType, RCType, TypeForm, TypeRoot, UnderType],
Tree: TYPE USING [Base, Index, Link, Map, 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, 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;
zone: UNCOUNTED ZONE ← NIL;
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: CSEIndex, -- type of operand
attr: Attr]; -- attributes
RStack: TYPE = RECORD [SEQUENCE length: NAT OF OperandDescriptor];
rStack: LONG POINTER TO RStack ← NIL;
rI: INTEGER; -- index into rStack
RPush: PUBLIC PROC [type: CSEIndex, attr: Attr] = {
rI ← rI + 1;
WHILE rI >= rStack.length DO
newLength: NAT = rStack.length + 16;
newStack: LONG POINTER TO RStack = zone.NEW[RStack[newLength]];
FOR i: INTEGER IN [0 .. rI) DO newStack[i] ← rStack[i] ENDLOOP;
zone.FREE[@rStack];
rStack ← newStack;
ENDLOOP;
rStack[rI] ← [type:type, attr:attr]};
RPop: PUBLIC PROC = {IF rI < 0 THEN ERROR; rI ← rI-1};
RType: PUBLIC PROC RETURNS [CSEIndex] = {RETURN [rStack[rI].type]};
RAttr: PUBLIC PROC RETURNS [Attr] = {RETURN [rStack[rI].attr]};
longUnsigned: CSEIndex; -- a hint for mwconst
textType: ARRAY TextForm OF CSEIndex; -- a hint for text literals
ExpInit: PUBLIC PROC [scratchZone: UNCOUNTED ZONE] = {
zone ← scratchZone;
implicit ← [type: typeANY, tree: Tree.Null, attr: emptyAttr];
P3S.implicitRecord ← RecordSENull;
own ← dataPtr.ownSymbols; -- make a parameter?
longUnsigned ← CSENull; textType ← ALL[CSENull];
rStack ← zone.NEW[RStack[32]];
rI ← -1};
ExpReset: PUBLIC PROC = {
IF rStack # NIL THEN zone.FREE[@rStack];
zone ← NIL};
-- type manipulation
EqualTypes: PROC [type1, type2: CSEIndex] RETURNS [BOOL] = {
RETURN [Types.Equivalent[[own, type1], [own, type2]]]};
UnresolvedTypes: SIGNAL RETURNS [CSEIndex] = CODE;
BalanceTypes: PROC [type1, type2: CSEIndex] RETURNS [type: CSEIndex] = {
n1, n2: CARDINAL;
SELECT TRUE FROM
(type1 = type2), (type2 = typeANY) => type ← type1;
(type1 = typeANY) => type ← type2;
ENDCASE => {
n1 ← Bundling[type1];
n2 ← Bundling[type2];
WHILE n1 > n2 DO type1 ← Unbundle[LOOPHOLE[type1]]; n1 ← n1-1 ENDLOOP;
WHILE n2 > n1 DO type2 ← Unbundle[LOOPHOLE[type2]]; n2 ← n2-1 ENDLOOP;
-- check bundling
DO
type1 ← TargetType[type1];
type2 ← TargetType[type2];
SELECT TRUE FROM
Types.Assignable[[own, type1], [own, type2]] => {type ← type1; EXIT};
Types.Assignable[[own, type2], [own, type1]] => {type ← type2; EXIT};
ENDCASE;
IF n1 = 0 THEN GO TO Fail;
n1 ← n1-1;
type1 ← Unbundle[LOOPHOLE[type1]];
type2 ← Unbundle[LOOPHOLE[type2]];
REPEAT
Fail => type ← SIGNAL UnresolvedTypes;
ENDLOOP};
RETURN};
ForceType: PUBLIC PROC [t: Tree.Link, type: CSEIndex] 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] = {
OPEN tb[node];
type, nType: CSEIndex;
attr: Attr;
son[1] ← Exp[son[1], typeANY];
type ← RType[]; attr ← RAttr[]; RPop[]; attr.const ← FALSE;
DO
nType ← NormalType[type];
WITH t: seb[nType] SELECT FROM
ref => {
RPush[UnderType[t.refType], attr];
attr2 ← seb[type].typeTag = long;
IF P3S.safety = checked AND ~(t.counted OR PermanentType[t.refType]) THEN
Log.ErrorNode[unsafeOperation, node];
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.ErrorTree[typeClash, son[1]];
RPush[typeANY, attr]};
ENDLOOP};
-- arithmetic expression manipulation
MakeNumeric: PROC [type: CSEIndex] RETURNS [CSEIndex] = {
RETURN [SELECT seb[type].typeTag FROM
long => MakeLongType[dataPtr.typeINT, type],
ENDCASE => dataPtr.typeINT]};
EvalNumeric: PROC [t: Tree.Link] RETURNS [val: Tree.Link] = {
val ← GenericRhs[t, dataPtr.typeINT];
SELECT NormalType[rStack[rI].type] FROM
dataPtr.typeINT => NULL;
typeANY => rStack[rI].type ← MakeNumeric[rStack[rI].type];
ENDCASE => Log.ErrorTree[typeClash, val];
RETURN};
ArithOp: PROC [node: Tree.Index] = {
OPEN tb[node];
saveNP: NPUse;
son[1] ← EvalNumeric[son[1]]; 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: CSEIndex] RETURNS [CSEIndex] = {
type ← NormalType[type];
RETURN [WITH seb[type] SELECT FROM
relative => NormalType[UnderType[offsetType]],
ENDCASE => type]};
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.ErrorTree[typeClash, son[1]];
lr ← TRUE; son[2] ← EvalNumeric[son[2]]}
ELSE {
SELECT type FROM
dataPtr.typeINT, typeANY => NULL;
ENDCASE => Log.ErrorTree[typeClash, son[1]];
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.ErrorNode[unsafeOperation, node];
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.ErrorTree[typeClash, son[1]];
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.ErrorTree[typeClash, son[1]]; rStack[rI].type ← typeANY};
son[2] ← EvalNumeric[son[2]]};
IF P3S.safety = checked AND seb[lType].typeTag = ref THEN
Log.ErrorNode[unsafeOperation, node];
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]]; SetAttributes[node];
IF tb[node].attr1 THEN rStack[rI].attr.const ← FALSE}};
EnumOp: PROC [node: Tree.Index, target: CSEIndex] = {
IF UniOperand[node] THEN {
tb[node].son[1] ← GenericRhs[tb[node].son[1], target]; SetAttributes[node];
IF ~IndexType[RType[]] THEN Log.ErrorTree[typeClash, tb[node].son[1]]}};
RelOp: PROC [node: Tree.Index, ordered: BOOL] = {
OPEN tb[node];
type: CSEIndex;
attr: Attr;
saveNP: NPUse;
implicitOp: BOOL;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← NormalType[RType[]]; attr ← RAttr[];
implicitOp ← (son[1] = Tree.Null);
son[2] ← GenericRhs[son[2], type];
type ← BalanceTypes[type, NormalType[RType[]]
! UnresolvedTypes => {Log.ErrorTree[typeClash, son[2]]; RESUME [typeANY]}];
IF (ordered AND ~OrderedType[type]) OR (~ordered AND ~IdentifiedType[type]) THEN
Log.ErrorNode[relationType, node];
BalanceAttributes[node];
attr ← And[attr, RAttr[]];
IF implicitOp AND son[1] # Tree.Null THEN Log.ErrorTree[typeClash, son[2]];
SELECT seb[type].typeTag 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.typeBOOL, attr]; phraseNP ← MergeNP[saveNP][phraseNP]};
In: PROC [node: Tree.Index] = {
OPEN tb[node];
type: CSEIndex;
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← RType[];
son[2] ← Range[son[2], CanonicalType[type]];
[] ← BalanceTypes[NormalType[type], NormalType[RType[]]
! UnresolvedTypes => {Log.ErrorTree[typeClash, tb[node].son[1]]; RESUME [typeANY]}];
BalanceAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr]; RPop[];
rStack[rI].type ← dataPtr.typeBOOL;
phraseNP ← MergeNP[saveNP][phraseNP]};
BoolOp: PROC [node: Tree.Index] = {
OPEN tb[node];
attr: Attr;
saveNP: NPUse;
SealRefStack[];
son[1] ← Rhs[son[1], dataPtr.typeBOOL]; attr ← RAttr[]; saveNP ← phraseNP;
ClearRefStack[];
son[2] ← Rhs[son[2], dataPtr.typeBOOL];
UnsealRefStack[];
attr ← And[attr, RAttr[]];
RPop[]; RPop[];
RPush[dataPtr.typeBOOL, attr]; phraseNP ← SequenceNP[saveNP][phraseNP]};
Interval: PUBLIC PROC [t: Tree.Link, target: CSEIndex, constant: BOOL] = {
node: Tree.Index = GetNode[t];
type: CSEIndex;
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[NormalType[type], NormalType[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: CSEIndex] RETURNS [CSEIndex] = {
RETURN [IF target = typeANY
OR (~EqualTypes[type, target] AND NormalType[type] = target)
THEN TargetType[type]
ELSE target]};
ResolveTypes: PROC [type1, type2, target: CSEIndex, t: Tree.Link]
RETURNS [type: CSEIndex] = {
failed: BOOL;
IF target = typeANY THEN failed ← TRUE
ELSE {
ENABLE UnresolvedTypes => {failed ← TRUE; RESUME [typeANY]};
failed ← FALSE;
type1 ← BalanceTypes[target, type1];
type2 ← BalanceTypes[target, type2];
type ← BalanceTypes[type1, type2]};
IF failed THEN {Log.ErrorTree[typeClash, t]; type ← typeANY};
RETURN};
IfExp: PROC [node: Tree.Index, target: CSEIndex] = {
OPEN tb[node];
type: CSEIndex;
attr: Attr;
entryNP, saveNP: NPUse;
SealRefStack[];
son[1] ← Rhs[son[1], dataPtr.typeBOOL];
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 seb[type].typeTag = 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: CSEIndex,
driver: PROC [Tree.Index, Tree.Map], foldable: BOOL] = {
type: CSEIndex;
attr: Attr;
saveNP: NPUse;
started: BOOL;
Selection: Tree.Map = {
subType: CSEIndex;
entryNP: NPUse = phraseNP;
v ← BalancedRhs[t, target];
subType ← BalanceTypes[type, RType[]
! UnresolvedTypes => {RESUME [ResolveTypes[type, RType[], target, v]]}];
IF seb[subType].typeTag = 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: CSEIndex] = {
OPEN tb[node];
attr: Attr;
saveNP: NPUse;
started: BOOL;
type: CSEIndex;
SubMinMax: Tree.Map = {
subType: CSEIndex;
v ← BalancedRhs[t, target];
attr ← And[attr, RAttr[]]; saveNP ← MergeNP[saveNP][phraseNP];
subType ← CanonicalType[RType[]];
subType ← BalanceTypes[subType, type
! UnresolvedTypes => {RESUME[ResolveTypes[subType, type, target, v]]}];
IF type # subType AND subType # typeANY THEN {
IF ~OrderedType[subType] THEN Log.ErrorNode[relationType, node];
type ← subType;
IF ~started THEN target ← BalancedTarget[target, type]};
RPop[]; started ← TRUE; RETURN};
attr ← fullAttr; saveNP ← none; started ← FALSE; type ← typeANY;
son[1] ← UpdateList[son[1], SubMinMax];
SELECT seb[type].typeTag 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: CSEIndex] = {
subType: CSEIndex = 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[unimplemented];
ENDCASE;
IF 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 => NULL;
long =>
IF NormalType[UnderType[rangeType]] # dataPtr.typeINT THEN GO TO fail;
ENDCASE => GO TO fail;
EXITS
fail => Log.ErrorTree[typeClash, son[1]];
END;
RPush[type, fullAttr]};
Unspec: PROC [type: CSEIndex] RETURNS [BOOL] = {
RETURN [WITH t: seb[type] SELECT FROM
basic => t.code = codeANY,
ENDCASE => FALSE]};
SafeForUnspec: PROC [target: CSEIndex] RETURNS [BOOL] = {
RETURN [P3S.safety # checked OR RCType[target] = none]};
Rhs: PUBLIC PROC [exp: Tree.Link, lhsType: CSEIndex] RETURNS [val: Tree.Link] = {
rhsType: CSEIndex;
val ← Exp[exp, lhsType];
rhsType ← rStack[rI].type;
SELECT TRUE FROM
(lhsType = rhsType), Unspec[lhsType] => NULL;
ENDCASE => { -- immediate matching is inconclusive
UNTIL Types.Assignable[[own, lhsType], [own, rhsType]] DO
WITH t: seb[rhsType] SELECT FROM
subrange => rhsType ← UnderType[t.rangeType];
record => {
IF Bundling[rhsType] = 0 THEN GO TO nomatch;
rhsType ← Unbundle[LOOPHOLE[rhsType, RecordSEIndex]];
val ← ForceType[val, IF Unspec[rhsType] THEN typeANY ELSE rhsType]};
ref, arraydesc => {
SELECT seb[lhsType].typeTag FROM
long => {
IF ~Types.Assignable[[own, NormalType[lhsType]], [own, rhsType]] THEN
GO TO nomatch;
val ← Lengthen[val, lhsType]};
ENDCASE => GO TO nomatch;
rhsType ← lhsType};
basic => {
IF Unspec[rhsType] AND SafeForUnspec[lhsType] THEN
SELECT seb[lhsType].typeTag FROM
long => val ← Lengthen[val, MakeLongType[typeANY, lhsType]];
ENDCASE
ELSE SELECT seb[lhsType].typeTag FROM
long => {
IF ~Types.Assignable[[own, NormalType[lhsType]], [own, rhsType]] THEN
GO TO nomatch;
val ← Lengthen[val, lhsType]};
real =>
IF rhsType = 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[rhsType];
SELECT seb[lhsType].typeTag FROM
long =>
SELECT TRUE FROM
Unspec[NormalType[lhsType]] => lhsType ← rhsType;
Unspec[subType] AND SafeForUnspec[lhsType] =>
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, lhsType]] THEN
GO TO nomatch;
rhsType ← UnderType[t.rangeType]; val ← Shorten[val, rhsType]};
enumerated =>
IF EqualTypes[rhsType, dataPtr.typeATOM] THEN {
Log.ErrorTree[missingCoercion, val]; rhsType ← lhsType}
ELSE GOTO nomatch;
ENDCASE => GO TO nomatch};
ENDCASE => GO TO nomatch;
REPEAT
nomatch => { -- no coercion is possible
Log.ErrorTree[typeClash,
IF exp = Tree.Null THEN implicit.tree ELSE val];
rhsType ← lhsType};
ENDLOOP;
rStack[rI].type ← rhsType};
IF seb[rhsType].typeTag = transfer AND OperandInline[val] THEN
Log.ErrorTree[misusedInline, val];
RETURN};
GenericRhs: PROC [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = {
type: CSEIndex;
val ← Exp[exp, target]; type ← rStack[rI].type;
-- put value in canonical form
DO
WITH seb[type] SELECT FROM
subrange => type ← UnderType[rangeType];
record => {
IF Bundling[type] = 0 THEN EXIT;
type ← Unbundle[LOOPHOLE[type, RecordSEIndex]];
val ← ForceType[val, type]};
ENDCASE => EXIT;
rStack[rI].type ← type;
ENDLOOP;
SELECT seb[target].typeTag FROM
enumerated =>
IF EqualTypes[type, dataPtr.typeATOM] THEN {
Log.ErrorTree[missingCoercion, val]; rStack[rI].type ← target};
ENDCASE;
RETURN};
BalancedRhs: PROC [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = {
type: CSEIndex;
val ← Exp[exp, target];
SELECT seb[target].typeTag FROM
long, real => {
type ← CanonicalType[rStack[rI].type];
IF type # typeANY AND seb[target].typeTag # seb[type].typeTag
AND EqualTypes[NormalType[target], type] THEN {
SELECT seb[target].typeTag FROM
long => IF seb[type].typeTag # real THEN val ← Lengthen[val, target];
real => {val ← Float[val, type, target]; rStack[rI].attr.const ← FALSE};
ENDCASE;
rStack[rI].type ← target}};
enumerated =>
IF EqualTypes[rStack[rI].type, dataPtr.typeATOM] THEN {
Log.ErrorTree[missingCoercion, val]; rStack[rI].type ← target};
ENDCASE;
RETURN};
AttrClass: PROC [type: CSEIndex] RETURNS [{short, long, real}] = {
RETURN [WITH t: seb[type] 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: CSEIndex;
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: CSEIndex] RETURNS [Tree.Link] = {
PushTree[t]; PushNode[lengthen, 1]; SetInfo[target]; RETURN [PopTree[]]};
Shorten: PROC [t: Tree.Link, target: CSEIndex] RETURNS [Tree.Link] = {
PushTree[t]; PushNode[shorten, 1]; SetInfo[target]; RETURN [PopTree[]]};
Float: PROC [t: Tree.Link, type, target: CSEIndex] RETURNS [Tree.Link] = {
PushTree[IF seb[type].typeTag = 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: CSEIndex] RETURNS [val: Tree.Link] = {
type: CSEIndex;
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 ← UnderType[seb[sei].idType];
SELECT ctxb[seb[sei].idCtx].ctxType FROM
included =>
IF ~(attr.const←ConstantId[sei]) THEN Log.ErrorSei[unimplemented, sei];
imported => attr.const ← ConstantId[sei];
ENDCASE => attr.const ← seb[sei].constant;
RPush[type, attr]; val ← exp};
hash =>
WITH t: seb[target] 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[unimplemented, 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.typeBOOL];
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.typeREAL, fullAttr]
ELSE {
IF longUnsigned = CSENull THEN
longUnsigned ← MakeLongType[dataPtr.idCARDINAL, typeANY];
RPush[longUnsigned, fullAttr]};
void => RPush[target, voidAttr];
clit => RPush[dataPtr.typeCHAR, fullAttr];
llit => {
attr: Attr ← fullAttr;
attr.const ← FALSE; RPush[dataPtr.typeSTRING, attr]};
atom => {
hti: HTIndex = GetHash[tb[node].son[1]];
WITH t: seb[target] 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.typeATOM, fullAttr]}};
nil => {
OPEN tb[node];
SELECT TRUE FROM
(son[1] # Tree.Null) => {
son[1] ← TypeExp[son[1]]; type ← UnderType[TypeForTree[son[1]]]};
(target # typeANY) => type ← target;
ENDCASE => type ← MakeRefType[typeANY, typeANY];
IF ~NullableType[type] THEN Log.ErrorTree[typeClash, val];
RPush[type, fullAttr]};
new, signalx, errorx, fork, joinx, create, startx, cons, listcons => {
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],
WITH seb[target] SELECT FROM
long => TargetType[UnderType[rangeType]],
ENDCASE => target];
subType ← 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.ErrorTree[typeClash, son[1]]; 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 ← UnderType[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]]; type ← UnderType[TypeForTree[son[2]]];
TypeTest[node: node, from: RType[], to: type];
rStack[rI].type ← dataPtr.typeBOOL; rStack[rI].attr.const ← FALSE};
safen => tb[node].son[1] ← Exp[tb[node].son[1], target];
loophole => {
OPEN tb[node];
subType: CSEIndex;
son[1] ← Exp[son[1], typeANY]; subType ← RType[];
IF seb[subType].typeTag = 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 ← UnderType[TypeForTree[son[2]]]};
IF RCType[rStack[rI].type] # none THEN {
rStack[rI].attr.const ← FALSE;
IF P3S.safety = checked THEN Log.ErrorNode[unsafeOperation, node]}};
size => {
OPEN tb[node];
attr: Attr;
son[1] ← TypeAppl[son[1]]; attr ← RAttr[]; RPop[];
IF son[2] # Tree.Null THEN {
saveNP: NPUse = phraseNP;
son[2] ← Rhs[son[2], dataPtr.typeINT];
attr ← And[attr, RAttr[]]; RPop[];
phraseNP ← MergeNP[saveNP][phraseNP]};
RPush[dataPtr.typeINT, attr]};
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};
val,
cast => {
tb[node].son[1] ← Exp[tb[node].son[1], target];
rStack[rI].type ← target};
ord =>
IF UniOperand[node] THEN {
tb[node].son[1] ← Exp[tb[node].son[1], typeANY]; SetAttributes[node];
IF ~IndexType[RType[]] THEN Log.ErrorTree[typeClash, tb[node].son[1]];
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.typeINT];
IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, tb[node].son[2]];
RPop[]; RPush[dataPtr.typeSTRING, 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: CSEIndex] = {
IF rStack[rI].type = CSENull 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: CSEIndex] RETURNS [v: Tree.Link, type: CSEIndex] = {
IF RCType[target] = none THEN {type ← dataPtr.typeSTRING; v ← t}
ELSE {
nType: CSEIndex = NormalType[target];
rType: SEIndex = WITH t: seb[nType] SELECT FROM
ref => t.refType,
ENDCASE => dataPtr.idTEXT;
form: TextForm = TextRep[rType];
cType: SEIndex = 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};
}.