-- file Pass3Xb.Mesa
-- last modified by Satterthwaite, December 17, 1979 1:45 PM
DIRECTORY
ComData: FROM "comdata"
USING [
definitionsOnly, idCARDINAL, nTypeCodes, ownSymbols,
typeMap, typeMapId,
typeBOOLEAN, typeCHARACTER, typeINTEGER, typeSTRING],
InlineDefs: FROM "inlinedefs" USING [BITAND],
Log: FROM "log" USING [Error, ErrorN, ErrorNode, ErrorSei, ErrorTree],
P3: FROM "p3"
USING [
Attr, EmptyAttr, FullAttr, VoidAttr,
NPUse, BoundNP, MergeNP, SequenceNP,
phraseNP,
Addr, All, --And,-- Apply, Assignment, Bundling, CanonicalType, Case,
ClearRefStack, DescOp, Discrimination, Dot, Id, IdentifiedType,
MakeLongType, MiscXfer, OperandInline, OrderedType, PopCtx, PushCtx,
RecordMention, SealRefStack, TargetType, TypeExp, TypeForTree, Unbundle,
UnsealRefStack, UpArrow],
Pass3: FROM "pass3"
USING [implicitAttr, implicitRecord, implicitTree, implicitType],
Symbols: FROM "symbols"
USING [ctxType, seType,
SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CSENull,
RecordSENull, codeCHARACTER, codeINTEGER, typeANY],
SymbolOps: FROM "symbolops"
USING [ConstantId, NormalType, TypeForm, UnderType],
Table: FROM "table" USING [Base, Notifier],
Tree: FROM "tree" USING [Index, Link, Map, Null, treeType],
TreeOps: FROM "treeops"
USING [
GetNode, ListLength, PopTree, PushTree, PushNode, SetInfo, TestTree,
UpdateList],
Types: FROM "types" USING [SymbolTableBase, Assignable, Equivalent];
Pass3Xb: PROGRAM
IMPORTS
InlineDefs, Log, P3, SymbolOps, TreeOps, Types,
dataPtr: ComData, passPtr: Pass3
EXPORTS P3 =
BEGIN
OPEN SymbolOps, TreeOps, P3;
And: PROCEDURE [Attr, Attr] RETURNS [Attr] = LOOPHOLE[InlineDefs.BITAND];
-- pervasive definitions from SymDefs
SEIndex: TYPE = Symbols.SEIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
CSEIndex: TYPE = Symbols.CSEIndex;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
typeANY: Symbols.CSEIndex = Symbols.typeANY;
tb: Table.Base; -- tree base address (local copy)
seb: Table.Base; -- se table base address (local copy)
ctxb: Table.Base; -- context table base address (local copy)
own: Types.SymbolTableBase;
ExpBNotify: PUBLIC Table.Notifier =
BEGIN -- called by allocator whenever table area is repacked
seb ← base[Symbols.seType]; ctxb ← base[Symbols.ctxType];
tb ← base[Tree.treeType]; RETURN
END;
-- intermediate result bookkeeping
OperandDescriptor: TYPE = RECORD[
type: CSEIndex, -- type of operand
attr: Attr]; -- attributes
RStackLimit: INTEGER = 32;
rStack: ARRAY [0 .. RStackLimit] OF OperandDescriptor;
rI: INTEGER; -- index into rStack
OperandStackOverflow: SIGNAL = CODE;
RPush: PUBLIC PROCEDURE [type: CSEIndex, attr: Attr] =
BEGIN
IF rI >= RStackLimit THEN ERROR OperandStackOverflow;
rI ← rI + 1;
rStack[rI] ← OperandDescriptor[type:type, attr:attr];
END;
RPop: PUBLIC PROCEDURE =
BEGIN
IF rI < 0 THEN ERROR;
rI ← rI-1;
END;
RType: PUBLIC PROCEDURE RETURNS [CSEIndex] =
BEGIN
RETURN [rStack[rI].type]
END;
RAttr: PUBLIC PROCEDURE RETURNS [Attr] =
BEGIN
RETURN [rStack[rI].attr]
END;
longUnsigned: CSEIndex; -- a hint for mwconst
ExpInit: PUBLIC PROCEDURE =
BEGIN
passPtr.implicitType ← typeANY; passPtr.implicitTree ← Tree.Null;
passPtr.implicitRecord ← Symbols.RecordSENull;
own ← dataPtr.ownSymbols; -- make a parameter?
longUnsigned ← Symbols.CSENull;
rI ← -1;
END;
-- tree manipulation utilities
OperandType: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [CSEIndex] =
BEGIN
RETURN [WITH e:t SELECT FROM
symbol => UnderType[seb[e.index].idType],
literal =>
WITH e.info SELECT FROM
string => dataPtr.typeSTRING,
ENDCASE => dataPtr.typeINTEGER,
subtree => tb[e.index].info,
ENDCASE => Symbols.CSENull]
END;
-- type manipulation
UnresolvedTypes: SIGNAL RETURNS [CSEIndex] = CODE;
BalanceTypes: PROCEDURE [type1, type2: CSEIndex] RETURNS [type: CSEIndex] =
BEGIN
n1, n2: CARDINAL;
SELECT TRUE FROM
(type1 = type2), (type2 = typeANY) => type ← type1;
(type1 = typeANY) => type ← type2;
ENDCASE =>
BEGIN
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]] =>
BEGIN type ← type1; EXIT END;
Types.Assignable[[own, type2], [own, type1]] =>
BEGIN type ← type2; EXIT END;
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;
END;
RETURN
END;
ForceType: PUBLIC PROCEDURE [t: Tree.Link, type: CSEIndex] RETURNS [Tree.Link] =
BEGIN
PushTree[t];
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[]]
END;
-- expressions
Exp: PUBLIC PROCEDURE [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] =
BEGIN
type: CSEIndex;
attr: Attr;
phraseNP ← none;
IF exp = Tree.Null
THEN
BEGIN
RPush[passPtr.implicitType, passPtr.implicitAttr]; RETURN [Tree.Null]
END;
WITH e:exp SELECT FROM
symbol =>
BEGIN
sei: ISEIndex = e.index;
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;
END;
hash =>
WITH seb[target] SELECT FROM
enumerated =>
BEGIN PushCtx[valueCtx]; val ← Id[e.index]; PopCtx[] END;
ENDCASE => val ← Id[e.index];
literal =>
BEGIN
attr.noXfer ← attr.noAssign ← TRUE;
WITH e.info SELECT FROM
string =>
BEGIN
type ← dataPtr.typeSTRING; attr.const ← FALSE;
IF dataPtr.definitionsOnly THEN Log.ErrorTree[unimplemented, exp];
END;
ENDCASE => BEGIN type ← dataPtr.typeINTEGER; attr.const ←TRUE END;
RPush[type, attr]; val ← exp;
END;
subtree =>
BEGIN
node: Tree.Index ← e.index;
val ← exp; -- the default
SELECT tb[node].name FROM
dot => Dot[node];
uparrow => UpArrow[node];
apply =>
BEGIN Apply[node, target, FALSE]; CheckNonVoid[node, target] END;
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.typeBOOLEAN];
or, and => BoolOp[node];
ifx => IfExp[node, target];
casex => SelectExp[node, target, Case];
bindx => SelectExp[node, target, Discrimination];
assignx => Assignment[node];
min, max => MinMax[node, target];
addr => Addr[node, target];
base, length, arraydesc => DescOp[node, target];
all => All[node, target];
mwconst =>
BEGIN
IF longUnsigned = Symbols.CSENull
THEN longUnsigned ← MakeLongType[dataPtr.idCARDINAL, typeANY];
RPush[longUnsigned, FullAttr];
END;
void => RPush[target, VoidAttr];
clit => RPush[dataPtr.typeCHARACTER, FullAttr];
llit =>
BEGIN
attr ← FullAttr; attr.const ← FALSE;
RPush[dataPtr.typeSTRING, attr];
END;
signalx, errorx, fork, joinx, new, startx =>
BEGIN
val ← MiscXfer[node, target];
node ← GetNode[val]; CheckNonVoid[node, target];
END;
syserrorx =>
BEGIN
RPush[Symbols.CSENull, EmptyAttr]; CheckNonVoid[node, target];
END;
lengthen =>
BEGIN OPEN tb[node];
type: CSEIndex;
son[1] ← GenericRhs[son[1], target]; type ← rStack[rI].type;
IF type = dataPtr.typeINTEGER
OR seb[type].typeTag = pointer
OR seb[type].typeTag = arraydesc
THEN rStack[rI].type ← MakeLongType[type, target]
ELSE
BEGIN
Log.ErrorTree[typeClash, son[1]]; rStack[rI].type ← typeANY;
END;
END;
safen => tb[node].son[1] ← Exp[tb[node].son[1], target];
loophole =>
BEGIN OPEN tb[node];
son[1] ← Exp[son[1], typeANY];
IF son[2] = Tree.Null
THEN
BEGIN
IF target = typeANY THEN Log.ErrorNode[noTarget, node];
rStack[rI].type ← target;
END
ELSE
BEGIN son[2] ← TypeExp[son[2]];
rStack[rI].type ← UnderType[TypeForTree[son[2]]];
END;
END;
size =>
BEGIN OPEN tb[node];
son[1] ← TypeExp[son[1]]; RPush[dataPtr.typeINTEGER, FullAttr];
END;
first, last => EndPoint[node];
typecode =>
BEGIN OPEN tb[node];
IF dataPtr.definitionsOnly THEN Log.Error[unimplemented];
son[1] ← TypeExp[son[1]];
EnterTypeCode[TypeForTree[son[1]]]; RPush[typeANY, FullAttr];
END;
item => tb[node].son[2] ← Exp[tb[node].son[2], target];
ENDCASE =>
BEGIN Log.Error[unimplemented]; RPush[typeANY, EmptyAttr] END;
tb[node].info ← rStack[rI].type;
END;
ENDCASE;
RETURN
END;
CheckNonVoid: PROCEDURE [node: Tree.Index, target: CSEIndex] =
BEGIN
IF rStack[rI].type = Symbols.CSENull THEN
SELECT tb[node].name FROM
error => BEGIN tb[node].name ← errorx; rStack[rI].type ← target END;
errorx, syserrorx => rStack[rI].type ← target;
ENDCASE =>
BEGIN
Log.ErrorNode[typeClash, node]; rStack[rI].type ← typeANY;
END;
END;
VoidExp: PUBLIC PROCEDURE [exp: Tree.Link] RETURNS [val: Tree.Link] =
BEGIN
val ← Exp[exp, typeANY]; RPop[]; RETURN
END;
UniOperand: PROCEDURE [node: Tree.Index] RETURNS [valid: BOOLEAN] =
BEGIN
l: CARDINAL = ListLength[tb[node].son[1]];
IF ~(valid ← l=1) THEN
BEGIN
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];
END;
RETURN
END;
-- arithmetic expression manipulation
NumericAny: PROCEDURE [type: CSEIndex] RETURNS [CSEIndex] =
BEGIN
RETURN [SELECT seb[type].typeTag FROM
long => MakeLongType[dataPtr.typeINTEGER, type],
ENDCASE => dataPtr.typeINTEGER]
END;
EvalNumeric: PROCEDURE [t: Tree.Link] RETURNS [val: Tree.Link] =
BEGIN
val ← GenericRhs[t, dataPtr.typeINTEGER];
SELECT NormalType[rStack[rI].type] FROM
dataPtr.typeINTEGER => NULL;
typeANY => rStack[rI].type ← NumericAny[rStack[rI].type];
ENDCASE => Log.ErrorTree[typeClash, val];
RETURN
END;
ArithOp: PROCEDURE [node: Tree.Index] =
BEGIN 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];
END;
ArithType: PROCEDURE [type: CSEIndex] RETURNS [CSEIndex] =
BEGIN
type ← NormalType[type];
RETURN [WITH seb[type] SELECT FROM
relative => NormalType[UnderType[offsetType]],
ENDCASE => type]
END;
Plus: PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
type: CSEIndex;
lr: BOOLEAN;
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← ArithType[rStack[rI].type];
IF seb[type].typeTag = pointer OR type = dataPtr.typeCHARACTER
THEN BEGIN lr ← TRUE; son[2] ← EvalNumeric[son[2]] END
ELSE
BEGIN
SELECT type FROM
dataPtr.typeINTEGER, 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.typeINTEGER, type = dataPtr.typeCHARACTER => NULL;
seb[type].typeTag = pointer => NULL;
ENDCASE =>
BEGIN
IF type # typeANY THEN Log.ErrorTree[typeClash, son[2]];
rStack[rI].type ← NumericAny[rStack[rI].type];
END;
END;
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];
END;
Minus: PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
type, subType: CSEIndex;
lr: BOOLEAN;
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← NormalType[rStack[rI].type]; subType ← ArithType[type]; lr ← TRUE;
IF seb[subType].typeTag = pointer OR subType = dataPtr.typeCHARACTER
THEN
BEGIN
son[2] ← GenericRhs[son[2], typeANY];
subType ← NormalType[rStack[rI].type];
SELECT TRUE FROM
subType = typeANY => NULL;
Types.Equivalent[[own, type], [own, subType]] => lr ← FALSE;
subType = dataPtr.typeINTEGER => NULL;
ENDCASE => Log.ErrorTree[typeClash, son[2]];
END
ELSE
BEGIN
SELECT type FROM
dataPtr.typeINTEGER, typeANY => NULL;
ENDCASE =>
BEGIN
Log.ErrorTree[typeClash, son[1]]; rStack[rI].type ← typeANY;
END;
son[2] ← EvalNumeric[son[2]];
END;
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.typeINTEGER, rStack[rI].type]
ELSE dataPtr.typeINTEGER;
RPop[]; phraseNP ← MergeNP[saveNP][phraseNP];
END;
UnaryOp: PROCEDURE [node: Tree.Index] =
BEGIN
IF UniOperand[node] THEN
BEGIN OPEN tb[node];
son[1] ← EvalNumeric[son[1]]; SetAttributes[node];
IF attr1 THEN rStack[rI].attr.const ← FALSE;
END;
END;
RelOp: PROCEDURE [node: Tree.Index, ordered: BOOLEAN] =
BEGIN OPEN tb[node];
type: CSEIndex;
attr: Attr;
saveNP: NPUse;
implicitOp: BOOLEAN;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
type ← NormalType[rStack[rI].type]; implicitOp ← (son[1] = Tree.Null);
son[2] ← GenericRhs[son[2], type];
type ← BalanceTypes[type, NormalType[rStack[rI].type]
!UnresolvedTypes =>
BEGIN Log.ErrorTree[typeClash, son[2]]; RESUME [typeANY] END];
IF (ordered AND ~OrderedType[type]) OR
(~ordered AND ~IdentifiedType[type])
THEN Log.ErrorNode[relationType, node];
BalanceAttributes[node];
attr ← And[rStack[rI-1].attr, rStack[rI].attr];
IF implicitOp AND son[1] # Tree.Null
THEN Log.ErrorTree[typeClash, son[2]];
SELECT seb[type].typeTag FROM
basic, enumerated => NULL;
transfer =>
BEGIN
IF OperandInline[son[1]] THEN Log.ErrorTree[misusedInline, son[1]];
IF OperandInline[son[2]] THEN Log.ErrorTree[misusedInline, son[2]];
attr.const ← FALSE;
END;
real => attr.const ← FALSE;
ENDCASE;
RPop[]; RPop[];
RPush[dataPtr.typeBOOLEAN, attr]; phraseNP ← MergeNP[saveNP][phraseNP];
END;
In: PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
saveNP: NPUse;
son[1] ← GenericRhs[son[1], typeANY]; saveNP ← phraseNP;
son[2] ← Range[son[2], rStack[rI].type];
SetAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr]; RPop[];
rStack[rI].type ← dataPtr.typeBOOLEAN;
phraseNP ← MergeNP[saveNP][phraseNP];
END;
BoolOp: PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
attr: Attr;
saveNP: NPUse;
SealRefStack[];
son[1] ← Rhs[son[1], dataPtr.typeBOOLEAN]; saveNP ← phraseNP;
ClearRefStack[];
son[2] ← Rhs[son[2], dataPtr.typeBOOLEAN];
UnsealRefStack[];
attr ← And[rStack[rI-1].attr, rStack[rI].attr];
RPop[]; RPop[];
RPush[dataPtr.typeBOOLEAN, attr]; phraseNP ← SequenceNP[saveNP][phraseNP];
END;
Interval: PUBLIC PROCEDURE [t: Tree.Link, type: CSEIndex, constant: BOOLEAN] =
BEGIN
node: Tree.Index = GetNode[t];
saveNP: NPUse;
type ← TargetType[type];
tb[node].son[1] ← Rhs[tb[node].son[1], type]; saveNP ← phraseNP;
IF constant AND ~rStack[rI].attr.const
THEN Log.ErrorTree[nonConstant, tb[node].son[1]];
tb[node].son[2] ← Rhs[tb[node].son[2], type];
IF constant AND ~rStack[rI].attr.const
THEN Log.ErrorTree[nonConstant, tb[node].son[2]];
SetAttributes[node];
rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr]; RPop[];
IF seb[type].typeTag = real THEN rStack[rI].attr.const ← FALSE;
phraseNP ← MergeNP[saveNP][phraseNP];
END;
Range: PUBLIC PROCEDURE [t: Tree.Link, type: CSEIndex] RETURNS [val: Tree.Link] =
BEGIN
subType: CSEIndex;
node: Tree.Index;
WITH t SELECT FROM
subtree =>
BEGIN node ← index;
SELECT tb[node].name FROM
subrangeTC =>
BEGIN val ← t;
tb[node].son[1] ← TypeExp[tb[node].son[1]];
subType ← TargetType[UnderType[TypeForTree[tb[node].son[1]]]];
Interval[tb[node].son[2], subType, FALSE];
END;
IN [intOO .. intCC] =>
BEGIN val ← t;
subType ← IF type # typeANY THEN type ELSE dataPtr.typeINTEGER;
Interval[t, subType, FALSE];
END;
ENDCASE =>
BEGIN
val ← TypeExp[t];
subType ← TargetType[UnderType[TypeForTree[val]]];
RPush[subType, FullAttr]; phraseNP ← none;
END;
END;
ENDCASE =>
BEGIN
val ← TypeExp[t]; subType ← TargetType[UnderType[TypeForTree[val]]];
RPush[subType, FullAttr]; phraseNP ← none;
END;
IF ~OrderedType[subType] AND subType # typeANY
THEN Log.Error[nonOrderedType];
IF ~Types.Assignable[
[dataPtr.ownSymbols, type],
[dataPtr.ownSymbols, subType]]
THEN Log.ErrorTree[typeClash, val];
RETURN
END;
BalancedTarget: PROCEDURE [target, type: CSEIndex] RETURNS [CSEIndex] =
BEGIN
RETURN [IF target = typeANY
OR (~Types.Equivalent[[own, type], [own, target]]
AND NormalType[type] = target)
THEN TargetType[type]
ELSE target]
END;
ResolveTypes: PROCEDURE [type1, type2, target: CSEIndex, t: Tree.Link]
RETURNS [type: CSEIndex] =
BEGIN
failed: BOOLEAN;
IF target = typeANY
THEN failed ← TRUE
ELSE
BEGIN
ENABLE UnresolvedTypes => BEGIN failed ← TRUE; RESUME [typeANY] END;
failed ← FALSE;
type1 ← BalanceTypes[target, type1];
type2 ← BalanceTypes[target, type2];
type ← BalanceTypes[type1, type2];
END;
IF failed THEN BEGIN Log.ErrorTree[typeClash, t]; type ← typeANY END;
RETURN
END;
IfExp: PROCEDURE [node: Tree.Index, target: CSEIndex] =
BEGIN OPEN tb[node];
type: CSEIndex;
attr: Attr;
entryNP, saveNP: NPUse;
SealRefStack[];
son[1] ← Rhs[son[1], dataPtr.typeBOOLEAN];
attr ← rStack[rI].attr; RPop[]; entryNP ← phraseNP;
UnsealRefStack[];
son[2] ← BalancedRhs[son[2], target];
attr ← And[attr, rStack[rI].attr]; saveNP ← SequenceNP[entryNP][phraseNP];
type ← rStack[rI].type; RPop[];
target ← BalancedTarget[target, type];
son[3] ← BalancedRhs[son[3], target]; attr ← And[attr, rStack[rI].attr];
type ← BalanceTypes[type, rStack[rI].type
!UnresolvedTypes =>
RESUME [ResolveTypes[type, rStack[rI].type, target, son[3]]]];
phraseNP ← BoundNP[saveNP][SequenceNP[entryNP][phraseNP]];
RPop[]; RPush[type, attr];
END;
SelectExp: PROCEDURE [node: Tree.Index, target: CSEIndex, driver: PROCEDURE [Tree.Index, Tree.Map]] =
BEGIN
type: CSEIndex;
attr: Attr;
saveNP: NPUse;
started: BOOLEAN;
Selection: Tree.Map =
BEGIN
subType: CSEIndex;
entryNP: NPUse = phraseNP;
v ← BalancedRhs[t, target];
subType ← BalanceTypes[type, rStack[rI].type
!UnresolvedTypes =>
RESUME [ResolveTypes[type, rStack[rI].type, target, 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]; RPop[]; started ← TRUE; RETURN
END;
type ← typeANY; attr ← FullAttr; started ← FALSE; saveNP ← none;
driver[node, Selection]; attr ← And[attr, rStack[rI].attr]; RPop[];
attr.const ← FALSE; RPush[type, attr]; phraseNP ← saveNP;
END;
MinMax: PROCEDURE [node: Tree.Index, target: CSEIndex] =
BEGIN OPEN tb[node];
attr: Attr;
saveNP: NPUse;
started: BOOLEAN;
type: CSEIndex;
SubMinMax: Tree.Map =
BEGIN
subType: CSEIndex;
v ← BalancedRhs[t, target];
attr ← And[attr, rStack[rI].attr]; saveNP ← MergeNP[saveNP][phraseNP];
subType ← CanonicalType[rStack[rI].type];
subType ← BalanceTypes[subType, type
!UnresolvedTypes =>
RESUME[ResolveTypes[subType, type, target, v]]];
IF type # subType AND subType # typeANY
THEN
BEGIN
IF ~OrderedType[subType] THEN Log.ErrorNode[relationType, node];
type ← subType;
IF ~started THEN target ← BalancedTarget[target, type];
END;
RPop[]; started ← TRUE; RETURN
END;
attr ← FullAttr; saveNP ← none; started ← FALSE; type ← typeANY;
son[1] ← UpdateList[son[1], SubMinMax];
SELECT seb[type].typeTag FROM
long => BEGIN attr1 ← FALSE; attr2 ← TRUE END;
real => BEGIN attr1 ← TRUE; attr2 ← FALSE; attr.const ← FALSE END;
ENDCASE => attr1 ← attr2 ← FALSE;
RPush[type, attr]; phraseNP ← saveNP;
END;
EndPoint: PROCEDURE [node: Tree.Index] =
BEGIN 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
Symbols.codeINTEGER, Symbols.codeCHARACTER => NULL;
ENDCASE => GO TO fail;
enumerated => NULL;
relative => IF TypeForm[offsetType] # subrange THEN GO TO fail;
subrange => NULL;
long =>
IF NormalType[UnderType[rangeType]] # dataPtr.typeINTEGER
THEN GO TO fail;
ENDCASE => GO TO fail;
EXITS
fail => Log.ErrorTree[typeClash, son[1]];
END;
RPush[type, FullAttr];
END;
EnterTypeCode: PROCEDURE [code: SEIndex] =
BEGIN
i: CARDINAL;
FOR i IN [0 .. dataPtr.nTypeCodes)
DO
IF code = dataPtr.typeMap[i] THEN EXIT;
REPEAT
FINISHED =>
BEGIN
dataPtr.typeMap[dataPtr.nTypeCodes] ← code;
dataPtr.nTypeCodes ← dataPtr.nTypeCodes + 1;
END;
ENDLOOP;
RecordMention[dataPtr.typeMapId];
END;
Rhs: PUBLIC PROCEDURE [exp: Tree.Link, lhsType: CSEIndex] RETURNS [val: Tree.Link] =
BEGIN
rhsType: CSEIndex;
val ← Exp[exp, lhsType];
rhsType ← rStack[rI].type;
SELECT TRUE FROM
(lhsType = rhsType), (lhsType = typeANY) => NULL;
(rhsType = typeANY) =>
BEGIN
SELECT seb[lhsType].typeTag FROM
long, real => val ← Lengthen[val, MakeLongType[typeANY, lhsType]];
ENDCASE;
rStack[rI].type ← lhsType;
END;
ENDCASE =>
BEGIN -- immediate matching is inconclusive
UNTIL Types.Assignable[[own, lhsType], [own, rhsType]]
DO
WITH seb[rhsType] SELECT FROM
subrange => rhsType ← UnderType[rangeType];
record =>
BEGIN
IF Bundling[rhsType] = 0 THEN GO TO nomatch;
rhsType ← Unbundle[LOOPHOLE[rhsType, RecordSEIndex]];
val ← ForceType[val, rhsType];
END;
ENDCASE =>
BEGIN
SELECT seb[lhsType].typeTag FROM
long =>
BEGIN
IF ~Types.Assignable[
[own, NormalType[lhsType]], [own, rhsType]]
THEN GO TO nomatch;
IF seb[rhsType].typeTag # real
THEN val ← Lengthen[val, lhsType];
END;
real =>
SELECT NormalType[rhsType] FROM
dataPtr.typeINTEGER, typeANY =>
BEGIN
val ← Float[val, rhsType, lhsType];
rStack[rI].attr.const ← FALSE;
END;
ENDCASE => GO TO nomatch;
ENDCASE => GO TO nomatch;
rhsType ← lhsType;
END
REPEAT
nomatch =>
BEGIN -- no coercion is possible
Log.ErrorTree[typeClash,
IF exp = Tree.Null THEN passPtr.implicitTree ELSE val];
rhsType ← lhsType;
END;
ENDLOOP;
rStack[rI].type ← IF rhsType = typeANY THEN lhsType ELSE rhsType;
END;
IF seb[rhsType].typeTag = transfer AND OperandInline[val]
THEN Log.ErrorTree[misusedInline, val];
RETURN
END;
GenericRhs: PROCEDURE [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] =
BEGIN
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 =>
BEGIN
IF Bundling[type] = 0 THEN EXIT;
type ← Unbundle[LOOPHOLE[type, RecordSEIndex]];
val ← ForceType[val, type];
END;
ENDCASE => EXIT;
rStack[rI].type ← type;
ENDLOOP;
RETURN
END;
BalancedRhs: PROCEDURE [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] =
BEGIN
type: CSEIndex;
val ← Exp[exp, target];
SELECT seb[target].typeTag FROM
long, real =>
BEGIN
type ← CanonicalType[rStack[rI].type];
IF type # typeANY AND seb[target].typeTag # seb[type].typeTag
AND Types.Equivalent[
[own, NormalType[target]], [own, type]]
THEN
BEGIN
SELECT seb[target].typeTag FROM
long =>
IF seb[type].typeTag # real THEN val ← Lengthen[val, target];
real =>
BEGIN
val ← Float[val, type, target]; rStack[rI].attr.const ← FALSE;
END;
ENDCASE;
rStack[rI].type ← target;
END;
END;
ENDCASE;
RETURN
END;
SetAttributes: PROCEDURE [node: Tree.Index] =
BEGIN
SELECT seb[rStack[rI].type].typeTag FROM
long => BEGIN tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE END;
real => BEGIN tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE END;
ENDCASE => tb[node].attr1 ← tb[node].attr2 ← FALSE;
END;
BalanceAttributes: PROCEDURE [node: Tree.Index] =
BEGIN
lType, rType: CSEIndex;
lType ← rStack[rI-1].type; rType ← rStack[rI].type;
SELECT seb[lType].typeTag FROM
long =>
BEGIN
SELECT seb[rType].typeTag FROM
long => BEGIN tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE END;
real =>
BEGIN
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;
END;
ENDCASE =>
BEGIN
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;
END;
END;
real =>
BEGIN
tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE;
SELECT seb[rType].typeTag FROM
real => NULL;
ENDCASE =>
BEGIN
rStack[rI].type ← lType;
tb[node].son[2] ← Float[tb[node].son[2], rType, lType];
rStack[rI].attr.const ← FALSE;
END;
END;
ENDCASE =>
SELECT seb[rType].typeTag FROM
long =>
BEGIN
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;
END;
real =>
BEGIN
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;
END;
ENDCASE => tb[node].attr1 ← tb[node].attr2 ← FALSE;
END;
Lengthen: PROCEDURE [t: Tree.Link, target: CSEIndex] RETURNS [v: Tree.Link] =
BEGIN
IF TestTree[t, arraydesc]
THEN v ← LengthenDesc[t, target]
ELSE
BEGIN
PushTree[t]; PushNode[lengthen, 1]; SetInfo[target]; v ← PopTree[];
END;
RETURN
END;
LengthenDesc: PROCEDURE [t: Tree.Link, target: CSEIndex] RETURNS [Tree.Link] =
BEGIN
node: Tree.Index = GetNode[t];
subNode: Tree.Index = GetNode[tb[node].son[1]];
tb[subNode].son[1] ← Lengthen[tb[subNode].son[1],
MakeLongType[OperandType[tb[subNode].son[1]], typeANY]];
tb[node].info ← MakeLongType[tb[node].info, target];
tb[node].attr2 ← TRUE;
RETURN [t]
END;
Float: PROCEDURE [t: Tree.Link, type, target: CSEIndex] RETURNS [Tree.Link] =
BEGIN
PushTree[IF seb[type].typeTag = long
THEN t
ELSE Lengthen[t, MakeLongType[type, typeANY]]];
SELECT NormalType[type] FROM
dataPtr.typeINTEGER => BEGIN PushNode[float, 1]; SetInfo[target] END;
typeANY => NULL;
ENDCASE => Log.ErrorTree[typeClash, t];
RETURN [PopTree[]]
END;
END.