[Cyan]<CedarLang>Nucleus>Compiler>Pass3Xb.mesa!1

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

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;

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

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𡤌onstantId[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;

PushTree[t]; PushNode[textlit, 1];

SetAttr[2, TRUE]; SetInfo[type]; v ← PopTree[]};

RETURN};