[_CDCSL_93-16_]<1>Cedar>release>MimosaOnly>Pass4Xc.mesa

Pass4Xc.mesa

Satterthwaite, June 18, 1986 5:10:56 pm PDT

Russ Atkinson (RRA) January 18, 1991 12:36 pm PST

Willie-s, March 12, 1993 2:17 pm PST

DIRECTORY

Alloc USING [Notifier],

Basics USING [BITAND, LowHalf],

ConstArith USING [Add, Compare, Const, FromInt, Sub, ToCard, ToInt],

Host: TYPE MachineParms USING [bitsPerLongWord],

LiteralOps USING [Find],

MimData USING [checks, idCARD, idNAT, interface, switches, typeStringBody],

MimosaLog USING [Error, ErrorTree, WarningTree],

MimP4 USING [Attr, Bias, BiasForType, BitsForType, Bounds, CatchNest, checked, ClearType, CommonAttr, CommonProp, Exp, ForceType, LiteralAttr, MakeArgRecord, MakeTreeLiteralCard, MakeTreeLiteralInt, nullBias, OperandStruct, OperandType, Prop, RelTest, RepForType, Repr, Rhs, RValue, SetType, TreeLiteral, TreeLiteralConst, TypeExp, TypeForTree, VAttr, voidAttr, VPop, VProp, VPush, VRep, VSetTop],

Symbols USING [Base, BitAddress, BitCount, codeCHAR, CSEIndex, ctxType, ISEIndex, ISENull, lZ, seType, Type, UNSPEC],

SymbolOps USING [ArgRecord, BitsPerElement, Cardinality, CtxLevel, DecodeBitAddr, DecodeCard, EncodeCard, FirstCtxSe, FromType, NextSe, NormalType, own, PackedSize, ToType, UnderType, VariantField],

SymLiteralOps USING [TypeRef],

Target: TYPE MachineParms USING [bitsPerAU, bitsPerChar, bitsPerLongWord, bitsPerWord, maxWord],

Tree USING [Base, Index, Link, NodeName, NodePtr, Null, treeType],

TreeOps USING [FreeNode, FreeTree, GetNode, GetTag, IdentityMap, OpName, PopTree, PushLit, PushNode, PushSe, PushTree, SetAttr, SetAttrs, SetSubInfo];

Pass4Xc: PROGRAM

IMPORTS Basics, ConstArith, LiteralOps, MimData, MimosaLog, MimP4, SymbolOps, SymLiteralOps, TreeOps

EXPORTS MimP4 = {

OPEN MimP4, TreeOps;

Options

warnNewProg: BOOL ¬ TRUE;

if true, then warn when "NEW program" is attempted

Defs

Bias: TYPE = MimP4.Bias;

Type: TYPE = Symbols.Type;

BitCount: TYPE = Symbols.BitCount;

CSEIndex: TYPE = Symbols.CSEIndex;

bitsPerAU: CARDINAL = Target.bitsPerAU;

bitsPerWord: CARDINAL = Target.bitsPerWord;

sizeType: Symbols.ISEIndex = IF Target.bitsPerWord < Target.bitsPerLongWord
THEN MimData.idCARD
ELSE MimData.idNAT;

RRA: how do we make this really OK for 16-bit machines? Do we really care? We do want arithmetic where we can get adequate checking...

Table notification

tb: Tree.Base; -- tree base address (local copy)

seb: Symbols.Base; -- se table base address (local copy)

ctxb: Symbols.Base; -- context table base address (local copy)

ExpCNotify: PUBLIC Alloc.Notifier = {

called by allocator whenever table area is repacked

tb ¬ base[Tree.treeType];

seb ¬ base[Symbols.seType];

ctxb ¬ base[Symbols.ctxType];

};

interval utilities

NormalizeRange: PUBLIC PROC [t: Tree.Link] RETURNS [Tree.Link] = {

val: Tree.Link ¬ t;

WITH v: val SELECT GetTag[val] FROM

symbol => {

type: Type = v.index;

ut: CSEIndex = ClearType[type];

rep: Repr ¬ RepForType[ut];

lb, ub: ConstArith.Const;

empty: BOOL ¬ FALSE;

intervalKind: Tree.NodeName ¬ intCC;

[lb, ub] ¬ MimP4.Bounds[ut, rep];

IF ConstArith.Compare[lb, ub] = greater THEN {

intervalKind ¬ intCO;

ub ¬ lb;

};

SELECT rep FROM

unsigned => {

PushTree[ForceType[MakeTreeLiteralCard[ConstArith.ToCard[lb]], type]];

PushTree[ForceType[MakeTreeLiteralCard[ConstArith.ToCard[ub]], type]];

}

ENDCASE => {

PushTree[ForceType[MakeTreeLiteralInt[ConstArith.ToInt[lb]], type]];

PushTree[ForceType[MakeTreeLiteralInt[ConstArith.ToInt[ub]], type]];

};

PushNode[intervalKind, 2];

SetType[type];

val ¬ PopTree[];

EXIT;

};

subtree => {

node: Tree.Index = v.index;

SELECT tb[node].name FROM

subrangeTC, cdot => {

val ¬ tb[node].son[2];

tb[node].son[2] ¬ Tree.Null;

FreeNode[node];

};

IN [intOO .. intCC] => EXIT;

ENDCASE => ERROR;

};

ENDCASE => ERROR;

ENDLOOP;

RETURN [val];

};

Interval: PUBLIC PROC [t: Tree.Link, bias: Bias, target: Repr]
RETURNS [BOOL] = {

attr: Attr;

const: BOOL ¬ TRUE;

WITH e: t SELECT GetTag[t] FROM

symbol => {

A symbolic type definition

attr ¬ LiteralAttr[RepForType[TypeTree[t]]];

VSetTop[nullBias, attr, 1];

};

subtree => {

node: Tree.Index = e.index;

son1: Tree.Link ¬ tb[node].son[1] ¬ RValue[tb[node].son[1], bias, target];

attr1: Attr ¬ VAttr[];

son2: Tree.Link ¬ tb[node].son[2] ¬ RValue[tb[node].son[2], bias, target];

attr2: Attr ¬ VAttr[];

const ¬ ~tb[node].attr1 AND TreeLiteral[son1] AND TreeLiteral[son2];

IF attr1.rep = signed AND attr2.rep = unsigned AND const THEN {

con: Bias ¬ TreeLiteralConst[son2];

IF ConstArith.Compare[con, ConstArith.FromInt[LAST[INT]]] # greater THEN

attr2.rep ¬ either;

};

IF attr2.rep = signed AND attr1.rep = unsigned AND const THEN {

con: Bias ¬ TreeLiteralConst[son1];

IF ConstArith.Compare[con, ConstArith.FromInt[LAST[INT]]] # greater THEN

attr1.rep ¬ either;

};

attr ¬ CommonAttr[attr1, attr2];

VSetTop[bias, attr, 2];

};

ENDCASE => ERROR;

IF const THEN

SELECT attr.rep FROM

signed, unsigned => {

origin, range: Bias;

[origin, range] ¬ ConstantInterval[t ! EmptyInterval => RESUME];

IF origin.sign # negative THEN {

ub: Bias ¬ ConstArith.Add[range, origin];

IF ConstArith.Compare[ub, ConstArith.FromInt[INT.LAST]] # greater THEN {

This interval is really neither signed nor unsigned.

attr.rep ¬ either;

VSetTop[bias, attr, 1];

};

either => {};

ENDCASE => const ¬ FALSE;

RETURN [const];

};

EmptyInterval: PUBLIC SIGNAL = CODE;

ConstantInterval: PUBLIC PROC [t: Tree.Link] RETURNS [origin, range: Bias] = {

WITH e: t SELECT GetTag[t] FROM

symbol => {

A symbolic type definition

ut: Type = ClearType[e.index];

rep: Repr ¬ RepForType[ut];

uBound: Bias;

[origin, uBound] ¬ MimP4.Bounds[ut, rep];

range ¬ ConstArith.Sub[uBound, origin];

IF range.sign = negative THEN SIGNAL EmptyInterval;

RETURN [origin, range];

};

subtree => {

node: Tree.Index = e.index;

name: Tree.NodeName ¬ tb[node].name;

rep: Repr ¬ VRep[];

empty: BOOL ¬ FALSE;

son1: Tree.Link ¬ tb[node].son[1];

son2: Tree.Link ¬ tb[node].son[2];

uBound: Bias ¬ TreeLiteralConst[son2];

origin ¬ TreeLiteralConst[son1];

SELECT name FROM

intOO, intOC => {

IF RelTest[son1, son2, relGE, rep] THEN empty ¬ TRUE;

origin ¬ ConstArith.Add[origin, ConstArith.FromInt[1]];

name ¬ IF name = intOO THEN intCO ELSE intCC;

};

ENDCASE;

SELECT name FROM

intCC =>

IF RelTest[son1, son2, relG, rep] THEN empty ¬ TRUE;

intCO => {

IF RelTest[son1, son2, relGE, rep] THEN empty ¬ TRUE;

uBound ¬ ConstArith.Sub[uBound, ConstArith.FromInt[1]];

};

ENDCASE => ERROR;

IF ~empty

THEN range ¬ ConstArith.Sub[uBound, origin]

ELSE {SIGNAL EmptyInterval; range ¬ ConstArith.FromInt[-1]};

};

ENDCASE => ERROR;

};

operators on types

IsSize: PUBLIC PROC [t: Tree.Link] RETURNS [BOOL] = {

Must be invoked before Exp processing is done

WITH e: t SELECT TreeOps.GetTag[t] FROM

symbol =>

IF seb[e.index].flags.sized THEN RETURN [TRUE];

Eventually do better than this?

subtree => {

tp: Tree.NodePtr = @tb[e.index];

SELECT tp.name FROM

plus => RETURN [IsSize[tp.son[1]] AND IsSize[tp.son[1]]];

times => {

c: NAT ¬ 0;

FOR i: NAT IN [1..tp.nSons] DO IF IsSize[tp.son[i]] THEN c ¬ c + 1; ENDLOOP;

IF c = 1 THEN RETURN [TRUE];

};

size =>

See Pass4Xc.TypeOp for details

SELECT tp.subInfo FROM

3, 5 => RETURN [TRUE];

ENDCASE;

};

ENDCASE;

RETURN [FALSE];

};

TypeOp: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {

SELECT tb[node].name FROM

size => {

Note: like all varieties of TypeOp, this is performed before constant folding.

ApplyLit: PROC [op: Tree.NodeName, val: INT] = {

SELECT op FROM

plus, minus => IF val = 0 THEN RETURN;

times, div => IF val = 1 THEN RETURN;

ENDCASE;

PushTree[MakeTreeLiteralCard[val]];

ApplyNode[op];

};

ApplyNode: PROC [op: Tree.NodeName] = {

PushNode[op, 2];

SetType[ComputeSizeType[]];

SetAttrs[FALSE, FALSE, FALSE];

IF op = check THEN SetSubInfo[1];

To inhibit treating the check node as a type check!

};

RoundUpUnits: PROC [bits: BitCount] RETURNS [BitCount] = INLINE {

mod: CARD16 = Basics.BITAND[Basics.LowHalf[bits], bitsPerRounding-1];

IF mod # 0 THEN bits ¬ bits + (bitsPerRounding - mod);

RETURN [bits];

};

RoundUpWords: PROC [bits: BitCount] RETURNS [BitCount] = INLINE {

mod: CARD16 = Basics.BITAND[Basics.LowHalf[bits], bitsPerWord-1];

IF mod # 0 THEN bits ¬ bits + (bitsPerWord - mod);

RETURN [bits];

};

BitsPerItem: PROC [type: Type] RETURNS [Symbols.BitCount] = {

ut: CSEIndex = LocalUnderType[type];

IF ut # MimData.typeStringBody THEN {

sei: Symbols.ISEIndex ¬ SymbolOps.VariantField[SymbolOps.own, ut];

IF sei # Symbols.ISENull THEN {

subType: CSEIndex = LocalUnderType[seb[sei].idType];

WITH t: seb[subType] SELECT FROM

sequence => RETURN [
SymbolOps.BitsPerElement[SymbolOps.own, t.componentType, t.packed]];

ENDCASE;

};

RETURN [Target.bitsPerChar];

};

bitsPerUnit: NAT ¬ 0;

bitsPerRounding: NAT ¬ 0;

son1: Tree.Link ¬ tb[node].son[1];

the type

son2: Tree.Link ¬ tb[node].son[2];

# of repetitions

SELECT tb[node].subInfo FROM

1 => bitsPerRounding ¬ bitsPerUnit ¬ 1;

for BITS[T]

2 => bitsPerRounding ¬ bitsPerUnit ¬ Target.bitsPerChar;

for BYTES[T]

3 => {bitsPerRounding ¬ bitsPerWord; bitsPerUnit ¬ bitsPerAU};

for SIZE[T] (rounding to words), maybe UNITS[T]

4 => bitsPerRounding ¬ bitsPerUnit ¬ bitsPerWord;

for WORDS[T]

5 => bitsPerRounding ¬ bitsPerUnit ¬ bitsPerAU;

for UNITS[T] (if no rounding desired)

ENDCASE => ERROR;

Should NEVER happen!

IF OpName[son1] # apply

THEN {

Not a sequence, just a static # of bits.

type: Type ¬ TypeTree[son1];

nBits: Symbols.BitCount ¬ MimP4.BitsForType[type];

IF son2 # Tree.Null THEN

Round up to the packed size when a repetition is present.

SELECT nBits FROM

< bitsPerWord => nBits ¬ SymbolOps.PackedSize[nBits];

ENDCASE => nBits ¬ RoundUpWords[nBits];

IF bitsPerUnit = 1 AND bitsPerRounding = bitsPerUnit

THEN

PushTree[MimP4.MakeTreeLiteralCard[nBits]]

push the number of bits (exactly)

ELSE {

nBits ¬ RoundUpUnits[nBits];

PushTree[MimP4.MakeTreeLiteralCard[nBits / bitsPerUnit]];

Push the literal # of units (rounded up, of course)

};

}

ELSE {

Using a sequence type, so will have to calculate dynamically.

subNode: Tree.Index = GetNode[son1];

items: Tree.Link ¬ tb[subNode].son[2];

type: Type ¬ TypeTree[tb[subNode].son[1]];

perType: Symbols.BitCount ¬ MimP4.BitsForType[type];

perItem: Symbols.BitCount ¬ BitsPerItem[type];

mayNeedRounding: BOOL ¬ perItem IN [1..bitsPerWord)
OR bitsPerRounding # bitsPerUnit
OR (Basics.LowHalf[perType] MOD bitsPerUnit # 0);

maxItems: Symbols.BitCount ¬ (Symbols.BitCount.LAST-perType)/perItem;

A conservative bound on the maximum # of elements.

tb[subNode].son[2] ¬ Tree.Null;

PushTree[items];

ApplyLit[check, maxItems];

IF NOT mayNeedRounding THEN {

No need to do the expensive rounding code.

IF bitsPerUnit # 1 THEN {

perItem ¬ (perItem + bitsPerUnit-1) / bitsPerUnit;

perType ¬ (perType + bitsPerUnit-1) / bitsPerUnit;

};

ApplyLit[times, perItem];

ApplyLit[plus, perType];

GO TO rounded;

};

At this point we calculate in bits first.

ApplyLit[times, perItem];

IF son2 # Tree.Null THEN {

With a repetition factor we round up to some number of units.

ApplyLit[plus, perType+bitsPerWord-1];

ApplyLit[div, bitsPerWord];

ApplyLit[times, bitsPerWord/bitsPerUnit];

GO TO rounded;

};

IF bitsPerRounding # 1 THEN {

Units other than bits.

IF bitsPerRounding > bitsPerUnit

THEN {

The rounding differs from the units

ApplyLit[plus, perType+bitsPerRounding-1];

ApplyLit[div, bitsPerRounding];

ApplyLit[times, bitsPerRounding/bitsPerUnit];

}

ELSE {

ApplyLit[plus, perType+bitsPerUnit-1];

ApplyLit[div, bitsPerUnit];

};

GO TO rounded;

};

ApplyLit[plus, perType];

EXITS rounded => {};

};

IF son2 # Tree.Null THEN {

For now, possibly forever, implemented by simple multiplication

tb[node].son[2] ¬ Tree.Null;

PushPositive[son2];

ApplyNode[times];

};

val ¬ Rhs[PopTree[], ComputeSizeType[]];

FreeNode[node];

};

first, last => {

son1: Tree.Link = tb[node].son[1];

TypeExp[son1];

{

resType: Type ¬ MimP4.TypeForTree[son1];

type: Type ¬ resType;

first: BOOL = (tb[node].name=$first);

vc: CARD ¬ 0;

vi: INT ¬ 0;

const: ConstArith.Const ¬ ConstArith.FromInt[0];

useCard: BOOL ¬ TRUE;

useConst: BOOL ¬ FALSE;

forceType: BOOL ¬ FALSE;

ut: CSEIndex = LocalUnderType[type];

WITH se: seb[ut] SELECT FROM

basic => {

forceType ¬ TRUE;

SELECT TRUE FROM

first => EXIT;

se.code = Symbols.codeCHAR => {

vc ¬ SymbolOps.Cardinality[SymbolOps.own, ut]-1;

forceType ¬ TRUE;

};

ENDCASE => vc ¬ Target.maxWord;

};

signed => {

last: INT ¬ 0;

bits: NAT ¬ se.length;

vi ¬ 0;

SELECT bits FROM

Host.bitsPerLongWord => vi ¬ INT.LAST;

Host.bitsPerLongWord*2 => {

DINT

signBitAsCard: CARD = LOOPHOLE[INT.FIRST];

useConst ¬ TRUE;

IF first THEN const ¬ [sign: negative, high: signBitAsCard, low: 0];

};

> Host.bitsPerLongWord => MimosaLog.Error[unimplemented];

ENDCASE =>

WHILE bits > 1 DO

vi ¬ vi + vi + 1;

bits ¬ bits - 1;

ENDLOOP;

IF first THEN vi ¬ -1-vi;

useCard ¬ FALSE;

};

unsigned => {

bits: NAT ¬ se.length;

vc ¬ 0;

SELECT bits FROM

Host.bitsPerLongWord => IF NOT first THEN vc ¬ CARD.LAST;

Host.bitsPerLongWord*2 => {

DCARD

useConst ¬ TRUE;

const ¬ [sign: positive, low: CARD.LAST, high: CARD.LAST];

};

> Host.bitsPerLongWord => MimosaLog.Error[unimplemented];

ENDCASE =>

WHILE bits > 0 DO

vc ¬ vc + vc + 1;

bits ¬ bits - 1;

ENDLOOP;

};

ref => {

Note: we can get here from a relative pointer

bits: NAT ¬ se.length;

vc ¬ 0;

forceType ¬ TRUE;

IF first THEN EXIT;

SELECT bits FROM

Host.bitsPerLongWord => vc ¬ CARD.LAST;

> Host.bitsPerLongWord => ERROR;

ENDCASE =>

WHILE bits > 0 DO

vc ¬ vc + vc + 1;

bits ¬ bits - 1;

ENDLOOP;

};

enumerated => {

forceType ¬ TRUE;

IF first OR se.empty THEN EXIT;

vc ¬ SymbolOps.Cardinality[SymbolOps.own, ut]-1;

};

relative => {

forceType ¬ TRUE;

type ¬ se.offsetType;

LOOP;

};

subrange => {

nt: CSEIndex = SymbolOps.NormalType[SymbolOps.own, se.rangeType];

range: CARD ¬ se.range;

vi ¬ se.origin;

forceType ← TRUE; <<RRA: this can confuse things later>>

IF NOT se.filled THEN

MimosaLog.ErrorTree[nonConstant, son1];

IF NOT first THEN {

We want the last value, but be careful about potential overflow!

vi ¬ LOOPHOLE[LOOPHOLE[vi, CARD]+se.range, INT];

IF se.empty THEN vi ¬ vi - 1;

};

WITH nse: seb[nt] SELECT FROM

signed => useCard ¬ FALSE;

ENDCASE => vc ¬ LOOPHOLE[vi];

};

ENDCASE => ERROR;

EXIT;

ENDLOOP;

SELECT TRUE FROM

useConst => {

val ¬ MakeConst[const, resType];

forceType ¬ FALSE;

};

useCard => val ¬ MakeTreeLiteralCard[vc];

ENDCASE => val ¬ MakeTreeLiteralInt[vi];

IF forceType THEN val ¬ MimP4.ForceType[val, resType];

FreeNode[node];

VPush[MimP4.nullBias, LiteralAttr[RepForType[type]]];

};

typecode => {

TypeExp[tb[node].son[1]];

IF MimData.interface

THEN val ¬ [subtree[index: node]]

ELSE {

val ¬ SymLiteralOps.TypeRef[TypeForTree[tb[node].son[1]], FALSE];

FreeNode[node];

};

VPush[MimP4.nullBias, LiteralAttr[either]];

};

ENDCASE => {

MimosaLog.Error[unimplemented];

VPush[MimP4.nullBias, voidAttr];

val ¬ [subtree[node]];

};

this can't be done in the start start - it might change, and MimData might not be initiailized

ComputeSizeType: PROC RETURNS[Symbols.ISEIndex] ~ INLINE {

RETURN[IF Target.bitsPerWord < Target.bitsPerLongWord
THEN MimData.idCARD
ELSE MimData.idNAT];

};

PushPositive: PROC [link: Tree.Link] = {

PushTree[link];

IF MimP4.checked OR MimData.switches['b] THEN {

PushTree[Tree.Null];

PushNode[check, 2];

SetType[ComputeSizeType[]];

};

MakeConst: PROC [const: ConstArith.Const, type: Type] RETURNS [Tree.Link] = {

hiVal: Tree.Link = MakeTreeLiteralCard[const.high];

loVal: Tree.Link = MakeTreeLiteralCard[const.low];

PushTree[hiVal];

PushTree[loVal];

PushNode[mwconst, 2];

SetType[type];

RETURN [PopTree[]];

};

misc transfer operators

MiscXfer: PUBLIC PROC [node: Tree.Index] RETURNS [Tree.Link] = {

attr: Attr;

val: Tree.Link ¬ [subtree[index: node]];

SELECT tb[node].name FROM

create => {

IF warnNewProg THEN MimosaLog.ErrorTree[unimplemented, val];

tb[node].son[1] ¬ RValue[tb[node].son[1], MimP4.nullBias, none];

attr ¬ [prop: VProp[], rep: unsigned];

VPop[];

};

fork => {

son1: Tree.Link = Exp[tb[node].son[1], none];

type: CSEIndex = OperandStruct[son1, TRUE];

tb[node].son[1] ¬ son1;

attr.prop ¬ VProp[];

VPop[];

WITH t: seb[type] SELECT FROM

transfer => {

tb[node].son[2] ¬ MakeArgRecord[
SymbolOps.ArgRecord[SymbolOps.own, t.typeIn], tb[node].son[2]];

attr.prop ¬ CommonProp[attr.prop, VProp[]];

attr.rep ¬ other;

VPop[];

};

ENDCASE => ERROR;

};

ENDCASE => {MimosaLog.Error[unimplemented]; attr ¬ voidAttr};

attr.prop.noXfer ¬ attr.prop.noFreeVar ¬ FALSE;

VPush[MimP4.nullBias, attr];

IF tb[node].nSons > 2 THEN CatchNest[tb[node].son[3]];

RETURN [val];

};

NIL

Nil: PUBLIC PROC [node: Tree.Index] RETURNS [Tree.Link] = {

type: Type = SymbolOps.ToType[tb[node].info];

n: BitCount;

IF tb[node].son[1] # Tree.Null THEN TypeExp[tb[node].son[1]];

n ¬ MimP4.BitsForType[type];

VPush[BiasForType[type], LiteralAttr[RepForType[type]]];

SELECT n FROM

<= Host.bitsPerLongWord => {

PushLit[LiteralOps.Find[either, SymbolOps.EncodeCard[0]]];

FreeNode[node];

RETURN [ForceType[PopTree[], type]];

};

ENDCASE => RETURN [ [subtree[node]] ];

Don't convert this to a literal right now

};

Misc addressing operators

AddrOp: PUBLIC PROC [node: Tree.Index] RETURNS [Tree.Link] = {

attr: Attr ¬ voidAttr;

val: Tree.Link ¬ [subtree[node]];

SELECT tb[node].name FROM

addr => {

extraCheck: BOOL ¬ MimData.checks['w];

subNode: Tree.Index;

type, next: CSEIndex;

son1: Tree.Link ¬ tb[node].son[1] ¬ Exp[tb[node].son[1], none];

v: Tree.Link ¬ son1;

prop: Prop ¬ VProp[];

prop.noFreeVar ¬ FALSE;

FOR t: Tree.Link ¬ v, v DO

WITH t SELECT GetTag[t] FROM

symbol => {

sei: Symbols.ISEIndex = index;

IF seb[sei].constant THEN GO TO fail;

IF SymbolOps.CtxLevel[SymbolOps.own, seb[sei].idCtx] = Symbols.lZ AND

(SymbolOps.DecodeBitAddr[seb[sei].idValue].bd MOD bitsPerWord # 0 OR

SymbolOps.DecodeCard[seb[sei].idInfo] MOD bitsPerWord # 0) THEN GO TO fail;

GO TO pass;

};

subtree => {

subNode ¬ index;

SELECT tb[subNode].name FROM

dot, dollar => v ¬ tb[subNode].son[2];

index, dindex, seqindex =>

FOR type ¬ SymbolOps.NormalType[SymbolOps.own, OperandType[tb[subNode].son[1]]], next DO

et: Type;

WITH t: seb[type] SELECT FROM

array => {

IF NOT t.packed THEN GO TO pass;

et ¬ t.componentType;

};

sequence => {

IF NOT t.packed THEN GO TO pass;

et ¬ t.componentType;

};

arraydesc => {

next ¬ LocalUnderType[t.describedType];

LOOP;

};

ENDCASE => ERROR;

We get to this point for a packed sequence or array, but we check to make sure that the elements are really less than a word.

IF MimP4.BitsForType[et] <= bitsPerWord/2 THEN GO TO fail;

GO TO pass;

ENDLOOP;

apply => GO TO fail;

uparrow, reloc => GO TO pass;

cast, chop => v ¬ tb[subNode].son[1];

base, length => GO TO pass;

ENDCASE => ERROR;

};

ENDCASE => ERROR;

REPEAT

pass => NULL;

fail => {MimosaLog.ErrorTree[nonAddressable, son1]; extraCheck ¬ FALSE};

ENDLOOP;

IF extraCheck AND v # Tree.Null THEN {

An extra check is made here to make sure that the item being addressed is an integral number of words long. Obviously, this is overkill, but it's not a bad idea, either.

vType: Type = MimP4.OperandType[v];

vBits: BitCount = MimP4.BitsForType[vType];

IF vBits MOD bitsPerWord # 0 THEN

MimosaLog.WarningTree[notPortable, val];

};

VSetTop[MimP4.nullBias, [prop: prop, rep: unsigned], 1];

};

base => {

tb[node].son[1] ¬ Exp[tb[node].son[1], none];

attr ¬ [prop: VProp[], rep: unsigned];

VSetTop[MimP4.nullBias, attr, 1];

};

length => {

son1: Tree.Link ¬ tb[node].son[1] ¬ Exp[tb[node].son[1], none];

type: CSEIndex ¬ OperandStruct[son1, TRUE];

WITH seb[type] SELECT FROM

array => {

val ¬ MakeTreeLiteralCard[SymbolOps.Cardinality[SymbolOps.own, indexType]];

FreeNode[node];

attr ¬ LiteralAttr[either];

};

ENDCASE => {

attr ¬ [prop: VProp[], rep: either];

};

VSetTop[MimP4.nullBias, attr, 1];

};

arraydesc =>

val ¬ IF OpName[tb[node].son[1]] # list THEN Desc[node] ELSE DescList[node];

ENDCASE => {

MimosaLog.Error[unimplemented];

VPush[MimP4.nullBias, voidAttr];

};

RETURN [val];

};

Desc: PROC [node: Tree.Index] RETURNS [Tree.Link] = {

subNode: Tree.Index = GetNode[tb[node].son[1]];

long: BOOL = tb[subNode].attr2;

sub1: Tree.Link ¬ tb[subNode].son[1] ¬ Exp[tb[subNode].son[1], none];

prop: Prop = VProp[];

subType: CSEIndex ¬ OperandStruct[sub1, TRUE];

VPop[];

WITH t: seb[subType] SELECT FROM

array => {

n: CARD = SymbolOps.Cardinality[SymbolOps.own, t.indexType];

IF n = 0 THEN MimosaLog.WarningTree[emptyArray, sub1];

IF t.packed AND (BitsForType[subType] MOD bitsPerWord # 0) THEN

MimosaLog.ErrorTree[nonAddressable, sub1];

PushTree[[subtree[subNode]]];

PushTree[MakeTreeLiteralCard[n]];

};

sequence => {

copy: Tree.Link = IdentityMap[sub1];

cNode: Tree.Index = GetNode[copy];

PushTree[sub1];

PushTree[MakeTreeLiteralCard[0]];

PushNode[seqindex, 2]; SetType[t.componentType];

SetAttr[2, long]; SetAttr[3, FALSE];

tb[subNode].son[1] ¬ sub1 ¬ PopTree[];

PushTree[[subtree[subNode]]];

tb[cNode].son[2] ¬ FreeTree[tb[cNode].son[2]];

tb[cNode].son[2] ¬ [symbol[index: t.tagSei]];

tb[cNode].info ¬ SymbolOps.FromType[ComputeSizeType[]];

PushTree[copy];

};

record => {

StringBody only (compatibility glitch)

copy: Tree.Link = IdentityMap[sub1];

sei: Symbols.ISEIndex = SymbolOps.NextSe[SymbolOps.own, SymbolOps.NextSe[SymbolOps.own, SymbolOps.FirstCtxSe[SymbolOps.own, t.fieldCtx]]];

PushTree[sub1];

PushSe[sei];

PushNode[dollar, 2];

SetType[seb[sei].idType];

SetAttr[2, long];

tb[subNode].son[1] ¬ sub1 ¬ PopTree[];

PushTree[[subtree[subNode]]];

PushTree[copy];

PushSe[SymbolOps.NextSe[SymbolOps.own,
SymbolOps.FirstCtxSe[SymbolOps.own, t.fieldCtx]]];

PushNode[dollar, 2];

SetType[ComputeSizeType[]]; SetAttr[2, long];

};

ENDCASE => {

PushTree[[subtree[subNode]]];

PushTree[Tree.Null];

};

PushTree[Tree.Null];

PushNode[list, 3];

tb[node].son[1] ¬ PopTree[];

VPush[MimP4.nullBias, [prop: prop, rep: other]];

RETURN [[subtree[index: node]]];

};

DescList: PROC [node: Tree.Index] RETURNS [Tree.Link] = {

subNode: Tree.Index = GetNode[tb[node].son[1]];

type: Type = SymbolOps.ToType[tb[node].info];

son1: Tree.Link = RValue[tb[subNode].son[1], MimP4.nullBias, unsigned];

prop: Prop ¬ VProp[];

subType: CSEIndex = OperandStruct[son1, TRUE];

tb[subNode].son[1] ¬ son1;

WITH se: seb[subType] SELECT FROM

ref => {

refElemType: CSEIndex = LocalUnderType[se.refType];

bits: CARD = BitsForType[refElemType];

IF bits < bitsPerWord AND NAT[bits] MOD bitsPerWord # 0 THEN {

In some cases the addressing assumed by the descriptor is not compatible with the address given. This is because variables less than a word are padded on the left.

descType: CSEIndex = LocalUnderType[type];

WITH dt: seb[descType] SELECT FROM

arraydesc => {

descArrayType: CSEIndex = LocalUnderType[dt.describedType];

WITH dat: seb[descArrayType] SELECT FROM

array => {

descElemType: CSEIndex = LocalUnderType[dat.componentType];

IF refElemType = descElemType THEN

IF NOT dat.packed OR bits > bitsPerWord/2 THEN GO TO ok;

If the element type described by the desc is padded the same way that the referent type of the pointer is padded then we need not issue a warning.

};

ENDCASE;

};

ENDCASE;

MimosaLog.WarningTree[nonAddressable, son1];

EXITS ok => {};

};

ENDCASE;

tb[subNode].son[2] ¬ RValue[tb[subNode].son[2], MimP4.nullBias, none];

prop ¬ CommonProp[VProp[], prop];

IF tb[subNode].son[3] # Tree.Null THEN TypeExp[tb[subNode].son[3]];

VSetTop[MimP4.nullBias, [prop: prop, rep: other], 2];

RETURN [[subtree[index: node]]];

};

LocalUnderType: PROC [type: Type] RETURNS [CSEIndex] = {

RETURN [SymbolOps.UnderType[SymbolOps.own, type]];

};

TypeTree: PROC [tree: Tree.Link] RETURNS [Type] = {

TypeExp[tree];

RETURN [MimP4.TypeForTree[tree]];

};