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

Pass4D.mesa

Satterthwaite, June 18, 1986 11:43:47 am PDT

Russ Atkinson (RRA) December 17, 1991 8:36 pm PST

Willie-s, September 24, 1991 2:12 pm PDT

DIRECTORY

Basics USING [BITXOR, LowHalf],

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

LiteralOps USING [Value],

Literals USING [LitClass],

MimData USING [base, bitsToAlignment, idCARDINAL, interface, mainCtx, textIndex],

MimosaLog USING [Error, ErrorSei, ErrorTree, WarningSei],

MimosaEvents USING [Callback, Register],

MimP4 USING [AdjustBias, Bias, BitsForType, Bounds, CheckFields, ConstantInterval, currentLevel, EmptyInterval, ForceType, Interval, IsSize, LayoutArgs, LayoutFields, MakeEPLink, mark, nullBias, ownGfi, Prop, RepForType, Repr, RewriteAssign, Rhs, SetType, StructuredLiteral, TreeLiteral, TreeLiteralCard, TreeLiteralInt, VPop, VProp, VRep, WordsForType],

MimZones USING [tempZone],

MobDefs USING [Link, ModuleIndex],

SourceMap USING [Loc, nullLoc],

SymbolOps USING [ArgRecord, BitsPerElement, Cardinality, ConstantId, CtxEntries, CtxLevel, DecodeBti, DecodeCard, DecodeTreeIndex, DecodeType, EncodeBti, EncodeCard, EncodeLink, EnterExtension, FindExtension, FirstCtxSe, FromBti, LinkMode, NextSe, NormalType, own, RCType, SearchContext, SetCtxLevel, ToBti, ToType, TypeLink, UnderType, XferMode],

Symbols USING [Base, BitCount, BitOrder, bodyType, CBTIndex, CBTNull, codeANY, codeCHAR, ContextLevel, CSEIndex, CSENull, CSEPointer, CTXIndex, ctxType, ExtensionType, ISEFirst, ISEIndex, ISENull, lG, lZ, nullType, RecordSEIndex, RecordSENull, RootBti, SEPointer, seType, Type, typeANY, TypeClass, typeTYPE, UNSPEC],

Target: TYPE MachineParms USING [bitOrder, bitsPerAU, bitsPerWord, maxWord],

Tree USING [Base, Index, Link, Map, NodeName, Null, Scan, treeType],

TreeOps USING [CopyTree, FreeNode, FreeTree, GetNode, GetTag, IdentityMap, ListHead, ListLength, NthSon, OpName, PopTree, PushList, PushNode, PushTree, ScanList, SetAttr, SetAttrs, SetInfo, ToCard, ToLoc, UpdateList],

Types USING [OpaqueValue];

Pass4D: PROGRAM

IMPORTS Basics, ConstArith, LiteralOps, MimData, MimosaEvents, MimosaLog, MimP4, MimZones, SymbolOps, TreeOps, Types

EXPORTS MimP4 = {

OPEN Symbols, TreeOps;

Options

suspectFlaw: BOOL ¬ FALSE;

Types, constants & variables

Bias: TYPE = MimP4.Bias;

Repr: TYPE = MimP4.Repr;

ownGfi: MobDefs.ModuleIndex = MimP4.ownGfi;

bitsPerAU: NAT = Target.bitsPerAU;

bitsPerWord: NAT = Target.bitsPerWord;

grain: NAT ¬ bitsPerAU;

targetBitOrder: Symbols.BitOrder ¬ SELECT Target.bitOrder FROM

msBit => msBit, lsBit => lsBit, ENDCASE => ERROR;

nullValue: UNSPEC = SymbolOps.EncodeCard[0];

Tables set by DeclNotify

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

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

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

bb: Symbols.Base ¬ NIL; -- body table base address (local copy)

Type stack for TypeExp

TypeStack: TYPE = RECORD [

next: NAT,

elems: SEQUENCE len: NAT OF Type];

typeStack: REF TypeStack ¬ NIL;

Public procedures & signals

VarInit: PUBLIC SIGNAL RETURNS [BOOL] = CODE;

DeclItem: PUBLIC PROC [item: Tree.Link] = {

node: Tree.Index = GetNode[item];

son1: Tree.Link = tb[node].son[1]; -- the id list

son2: Tree.Link ¬ tb[node].son[2]; -- the type expression (optional)

son3: Tree.Link ¬ tb[node].son[3]; -- the initialization (optional)

initFlag: BOOL ¬ son3 # Tree.Null;

saveIndex: SourceMap.Loc = MimData.textIndex;

newIndex: SourceMap.Loc = ToLoc[tb[node].info];

checkTypeSize: BOOL ¬ FALSE;

IF tb[node].attr3 = MimP4.mark THEN RETURN; -- already processed

tb[node].attr3 ¬ MimP4.mark;

IF newIndex # SourceMap.nullLoc THEN MimData.textIndex ¬ newIndex;

IF tb[node].name = typedecl

THEN {

ENABLE VarInit => {RESUME[FALSE]};

TypeExp[son2];

CheckDefaults[item];

}

ELSE {

op: Tree.NodeName = OpName[son3];

IF son2 # Tree.Null THEN TypeExp[son2, op = body];

IF initFlag THEN {

There is an initialization expression

eqFlag: BOOL = tb[node].attr1;

SELECT op FROM

body, procinit => {

expNode: Tree.Index = GetNode[son3];

bti: CBTIndex = LOOPHOLE[SymbolOps.ToBti[tb[expNode].info]];

IF eqFlag

THEN {

IF tb[expNode].attr3

THEN {

inline

DefineSEValue[ids: son1, info: bti];

AugmentSEValue[son1, form,
IF MimData.interface THEN TrimTree[son3] ELSE Tree.Null];

}

ELSE DefineSEValue[

ids: son1,

value: SymbolOps.EncodeLink[ MimP4.MakeEPLink[bb[bti].entryIndex, ownGfi]],

info: bti];

son3 ¬ tb[node].son[3] ¬ Tree.Null;

}

ELSE {

PushNode[body, 0];

SetInfo[SymbolOps.FromBti[bti]];

son3 ¬ tb[node].son[3] ¬ PopTree[];

};

signalinit =>

IF eqFlag THEN {

expNode: Tree.Index = GetNode[son3];

link: MobDefs.Link ¬ MimP4.MakeEPLink[ToCard[tb[expNode].info], ownGfi];

DefineSEValue[

son1,

SymbolOps.EncodeLink[link],

RootBti];

son3 ¬ tb[node].son[3] ¬ FreeTree[son3];

};

inline => {

expNode: Tree.Index = GetNode[son3];

tb[expNode].son[1] ¬ UpdateList[tb[expNode].son[1], InlineOp];

DefineSEValue[ids: son1];

AugmentSEValue[son1, value, son3];

son3 ¬ tb[node].son[3] ¬ Tree.Null;

};

ENDCASE => {

type: Type = TypeForDecl[node];

ut: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];

IF MimP4.IsSize[son3] THEN ScanList[son1, MarkSize];

If the initialization is a SIZE expression, mark it

son3 ¬ tb[node].son[3] ¬ MimP4.Rhs[son3, type, $init];

The initialization expression (not null)

<<WITH se: seb[ut] SELECT FROM

subrange => IF se.empty THEN {

MimosaLog.ErrorTree[boundsFault, son3];

GO TO donePop;

};

ENDCASE;>>

IF eqFlag THEN {

In this case the value will not change.

t: Tree.Link ¬ son3;

prop: MimP4.Prop = MimP4.VProp[];

isTransfer: BOOL ¬ seb[ut].typeTag = transfer;

WHILE OpName[t] = cast DO t ¬ NthSon[t, 1] ENDLOOP;

WITH e: t SELECT GetTag[t] FROM

literal => {

val: Symbols.UNSPEC;

class: Literals.LitClass;

[class, val] ¬ LiteralOps.Value[e.index];

DefineSEValue[ids: son1, value: val];

GO TO definedFree;

};

ENDCASE;

SELECT SymbolOps.XferMode[SymbolOps.own, ut] FROM

proc, signal, error, program => {

isTransfer ¬ TRUE;

WITH e: t SELECT GetTag[t] FROM

symbol => {

sei: ISEIndex = e.index;

IF seb[sei].constant THEN {

DefineSEValue[ids: son1, value: seb[sei].idValue, info: SymbolOps.DecodeBti[seb[sei].idInfo]];

IF seb[sei].extended THEN {

ext: Tree.Link = SymbolOps.FindExtension[SymbolOps.own, sei].tree;

AugmentSEValue[son1, form, ext, TRUE];

};

GO TO definedFree;

};

ENDCASE;

};

ENDCASE;

IF (prop.noFreeVar AND prop.noXfer AND NOT isTransfer)
OR OpName[t] = nil THEN {

DefineSEValue[ids: son1];

AugmentSEValue[son1, value, son3];

GO TO donePop;

};

DefineSEVar[ids: son1];

EXITS

definedFree => son3 ¬ tb[node].son[3] ¬ FreeTree[son3];

};

MimP4.VPop[];

EXITS

donePop => {son3 ¬ tb[node].son[3] ¬ Tree.Null; MimP4.VPop[]};

};

MarkAndCheckSE[son1, initFlag];

MimData.textIndex ¬ saveIndex;

};

DeclUpdate: PUBLIC PROC [item: Tree.Link] RETURNS [update: Tree.Link ¬ Tree.Null] = {

node: Tree.Index = GetNode[item];

IF tb[node].name # typedecl AND tb[node].son[3] # Tree.Null THEN {

type: Type = TypeForDecl[node];

rewrite: BOOL = SELECT OpName[tb[node].son[3]] FROM

body, signalinit => FALSE,

ENDCASE => TRUE;

n: CARDINAL = ListLength[tb[node].son[1]];

ScanList[tb[node].son[1], PushTree];

PushTree[tb[node].son[3]];

FOR i: CARDINAL IN [1 .. n] DO

IF i = n

THEN PushNode[assign, 2]

ELSE {PushNode[assignx, 2]; MimP4.SetType[type]};

SetInitAttr[type, ConstInit[tb[node].son[3]]];

IF rewrite THEN PushTree[MimP4.RewriteAssign[GetNode[PopTree[]], type]];

ENDLOOP;

SetInfo[tb[node].info];

update ¬ PopTree[];

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

};

FreeNode[node];

};

TypeExp: PUBLIC PROC [typeExp: Tree.Link, body: BOOL ¬ FALSE, avoidId: BOOL ¬ FALSE] = {

body => arg records subsumed by frame

WITH typeExp SELECT GetTag[typeExp] FROM

symbol => IF NOT avoidId THEN {

iSei: ISEIndex = index;

IF NOT seb[iSei].mark4 THEN

DeclItem[[subtree[index: SymbolOps.DecodeTreeIndex[seb[iSei].idValue]]]];

};

subtree => {

node: Tree.Index = index;

SELECT tb[node].name FROM

discrimTC => TypeExp[tb[node].son[1], FALSE, avoidId]; -- RRA: avoidId??

longTC, optionTC => TypeExp[tb[node].son[1]]; -- RRA: no avoidId??

cdot => TypeExp[tb[node].son[2], body, avoidId];

implicitTC, linkTC => NULL;

frameTC => NULL;

ENDCASE => {

sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, SymbolOps.ToType[tb[node].info]];

IF NOT seb[sei].mark4 THEN {

oldLen: NAT ¬ IF typeStack = NIL THEN 0 ELSE typeStack.next;

FOR i: NAT IN [0..oldLen) DO

IF typeStack[i] = sei THEN {

MimosaLog.ErrorTree[circularType, typeExp];

GO TO noProcess;

};

ENDLOOP;

IF oldLen = 0 OR oldLen = typeStack.len THEN {

Need to expand the type stack

newLen: NAT ¬ oldLen+16;

newStack: REF TypeStack ¬ MimZones.tempZone.NEW[TypeStack[newLen]];

FOR i: NAT IN [0..oldLen) DO newStack[i] ¬ typeStack[i]; ENDLOOP;

MimZones.tempZone.FREE[@typeStack];

typeStack ¬ newStack;

};

typeStack[oldLen] ¬ sei;

typeStack.next ¬ oldLen + 1;

WITH type: seb[sei] SELECT FROM

enumerated =>

IF type.machineDep THEN

[empty: type.empty, range: type.range, sparse: type.sparse] ¬

LayoutEnum[tb[node].son[1], type.valueCtx];

record => {

ENABLE VarInit => {RESUME[FALSE]};

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

machineDepCons: BOOL = tb[node].attr1;

oldGrain: NAT ¬ grain;

oldBitOrder: Symbols.BitOrder ¬ targetBitOrder;

rSei: RecordSEIndex = LOOPHOLE[sei, RecordSEIndex];

targetBitOrder ¬ type.bitOrder;

grain ¬ type.grain;

type.align ¬ MimData.bitsToAlignment[grain];

ScanList[son1, DeclItem];

IF machineDepCons THEN ScanList[son1, AssignPositions];

WITH st: type SELECT FROM

notLinked =>

IF machineDepCons

THEN MimP4.CheckFields[rSei, 0]

ELSE MimP4.LayoutFields[rSei, 0];

ENDCASE;

ExtractFieldAttributes[rSei];

CheckDefaults[son1];

targetBitOrder ¬ oldBitOrder;

grain ¬ oldGrain;

};

ref => {

seb[sei].mark4 ¬ TRUE;

To break indirection recursion

TypeExp[tb[node].son[1], FALSE, TRUE];

};

array => {

maxArraySize: CARD = BitCount.LAST/bitsPerAU;

packed: BOOL = type.packed;

et: Type = type.componentType;

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

IF son1 # Tree.Null THEN TypeExp[son1];

TypeExp[tb[node].son[2], FALSE, avoidId]; -- RRA: avoidId??

IF SymbolOps.Cardinality[SymbolOps.own, type.indexType]
> MaxCardinality[et, packed, maxArraySize] THEN

MimosaLog.Error[arraySize];

seb[sei].mark4 ¬ TRUE;

To allow BitsForType to win!

IF packed THEN {

May need to adjust the alignment

nb: BitCount ¬ MimP4.BitsForType[sei];

IF nb < bitsPerWord THEN {

elemBits: BitCount
= SymbolOps.BitsPerElement[SymbolOps.own, et, TRUE];

IF elemBits < bitsPerWord THEN

type.align ¬ MimData.bitsToAlignment[elemBits];

};

arraydesc => {

seb[sei].mark4 ¬ TRUE;

To break indirection recursion

TypeExp[tb[node].son[1], FALSE, TRUE];

};

transfer => {

origin: CARDINAL ¬ 0;

newOrigin: CARDINAL ¬ 0;

rSei: RecordSEIndex;

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

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

seb[sei].mark4 ¬ TRUE;

To break indirection recursion

IF OpName[son1] # anyTC THEN {

ScanList[son1, DeclItem];

CheckDefaults[son1];

};

rSei ¬ SymbolOps.ArgRecord[SymbolOps.own, type.typeIn];

IF rSei # RecordSENull THEN {

seb[rSei].hints.comparable ¬ TRUE; -- for now

newOrigin ¬ MimP4.LayoutArgs[rSei, origin, body];

seb[rSei].length ¬ newOrigin - origin;

seb[rSei].mark4 ¬ TRUE;

};

IF OpName[son2] # anyTC THEN {

ScanList[son2, DeclItem];

CheckDefaults[son2];

};

rSei ¬ SymbolOps.ArgRecord[SymbolOps.own, type.typeOut];

IF rSei # RecordSENull THEN {

seb[rSei].hints.comparable ¬ TRUE; -- for now

seb[rSei].length ¬ MimP4.LayoutArgs[rSei, origin, body] - origin;

seb[rSei].mark4 ¬ TRUE;

}

};

definition => NULL;

union => {

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

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

DeclItem[son1];

IF tb[node].attr1 AND type.controlled THEN AssignPositions[son1];

ProcessVariants[seb[type.tagSei].idType, son2];

};

sequence => {

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

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

DeclItem[son1];

IF tb[node].attr1 AND type.controlled THEN AssignPositions[son1];

TypeExp[son2, FALSE, avoidId]; -- RRA: avoidId??

};

relative => {

seb[sei].mark4 ¬ TRUE;

To break indirection recursion

TypeExp[tb[node].son[1], FALSE, TRUE];

TypeExp[tb[node].son[2], FALSE, TRUE];

};

opaque => {

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

IF son1 # Tree.Null THEN {

son1 ¬ tb[node].son[1] ¬ MimP4.Rhs[son1, MimData.idCARDINAL];

MimP4.VPop[];

IF MimP4.TreeLiteral[son1] THEN

type.length ¬ MimP4.TreeLiteralInt[son1]*bitsPerAU;

};

zone => NULL;

subrange => {

tSei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type.rangeType];

tRep: Repr = MimP4.RepForType[tSei];

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

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

TypeExp[son1, FALSE, avoidId]; -- RRA: avoidId??

IF MimP4.Interval[son2, MimP4.nullBias, tRep]

THEN {

origin, range: Bias;

[origin, range] ¬ MimP4.ConstantInterval[son2

! MimP4.EmptyInterval => {type.empty ¬ TRUE; RESUME}];

type.origin ¬ ConstArith.ToInt[origin];

IF type.empty

THEN type.range ¬ 0

ELSE type.range ¬ ConstArith.ToCard[range];

}

ELSE type.origin ¬ type.range ¬ 0;

type.filled ¬ TRUE;

{

rep: Repr = MimP4.VRep[];

MimP4.VPop[];

SELECT TRUE FROM

rep = Repr.none => MimosaLog.ErrorTree[mixedRepresentation, son2];

type.empty => {};

ENDCASE => {

ENABLE ConstArith.Overflow => GO TO dreck;

start: ConstArith.Const = ConstArith.FromInt[type.origin];

stop: ConstArith.Const = ConstArith.Add[start, ConstArith.FromCard[type.range]];

lb, ub: ConstArith.Const;

[lb, ub] ¬ MimP4.Bounds[tSei, MimP4.RepForType[tSei]];

IF ConstArith.Compare[start, lb] = less THEN GO TO dreck;

IF ConstArith.Compare[stop, ub] = greater THEN GO TO dreck;

EXITS dreck => MimosaLog.Error[subrangeNesting];

};

tb[node].son[2] ¬ FreeTree[son2];

};

any => NULL;

ENDCASE => ERROR;

typeStack.next ¬ oldLen;

EXITS noProcess => {};

};

seb[sei].mark4 ¬ TRUE;

};

ENDCASE => ERROR;

};

MaxCardinality: PUBLIC PROC
[type: Type, packed: BOOL, maxSize: CARD] RETURNS [CARD] = {

eSize: BitCount = SymbolOps.BitsPerElement[SymbolOps.own, type, packed];

maxBits: CARD ¬ maxSize*bitsPerAU;

IF maxBits > CARD[BitCount.LAST] OR maxBits < maxSize THEN maxBits ¬ BitCount.LAST;

IF eSize > 1 THEN RETURN [maxBits/eSize];

RETURN [maxBits];

};

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

RETURN [WITH t SELECT GetTag[t] FROM

symbol => index,

subtree => SymbolOps.ToType[tb[index].info],

ENDCASE => typeANY]

};

ClearType: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {

sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];

IF sei # CSENull THEN

WITH t: seb[sei] SELECT FROM

opaque => {

nSei: CSEIndex ¬
Types.OpaqueValue[ [SymbolOps.own, sei], SymbolOps.own].sei;

IF nSei # sei THEN {type ¬ nSei; LOOP};

};

record =>

IF t.hints.unifield
AND SymbolOps.CtxEntries[SymbolOps.own, t.fieldCtx] = 1 THEN {

type ¬ seb[ctxb[t.fieldCtx].seList].idType;

LOOP;

};

ENDCASE;

RETURN [sei];

ENDLOOP;

};

CanonicalType: PUBLIC PROC [type: Type] RETURNS [Type] = {

sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];

IF sei # CSENull THEN

WITH t: seb[sei] SELECT FROM

opaque => {

nSei: CSEIndex ¬
Types.OpaqueValue[ [SymbolOps.own, sei], SymbolOps.own].sei;

IF nSei # sei THEN {type ¬ nSei; LOOP};

};

record =>

IF t.hints.unifield
AND SymbolOps.CtxEntries[SymbolOps.own, t.fieldCtx] = 1 THEN {

type ¬ seb[ctxb[t.fieldCtx].seList].idType;

LOOP;

};

subrange => {type ¬ t.rangeType; LOOP};

ENDCASE;

RETURN [type];

ENDLOOP;

};

BiasForType: PUBLIC PROC [type: Type] RETURNS [Bias] = {

sei: CSEIndex = ClearType[type];

IF sei # CSENull THEN

WITH t: seb[sei] SELECT FROM

subrange => IF t.biased THEN RETURN [ConstArith.FromInt[t.origin]];

ENDCASE;

RETURN [MimP4.nullBias];

ENDLOOP;

};

RepForType: PUBLIC PROC [type: Type] RETURNS [MimP4.Repr] = {

eitherOK: BOOL ¬ FALSE;

lastInt: CARD = CARD[INT.LAST];

sei: CSEIndex = ClearType[type];

IF sei = CSENull

THEN RETURN [MimP4.Repr.none]

ELSE {

sep: Symbols.CSEPointer = @seb[sei];

WITH t: sep SELECT FROM

basic =>

SELECT t.code FROM

codeANY => RETURN [MimP4.Repr.all];

codeCHAR => GO TO retEither;

ENDCASE;

enumerated => {

IF eitherOK OR t.range <= lastInt THEN GO TO retEither;

RETURN [MimP4.Repr.unsigned];

};

ref => RETURN [MimP4.Repr.addr];

relative => {

type ¬ t.offsetType;

LOOP;

};

subrange => {

org: CARD = LOOPHOLE[t.origin];

lim: CARD = org + t.range;

IF NOT eitherOK THEN

SELECT TRUE FROM

t.empty => eitherOK ¬ TRUE;

org > lastInt, lim > lastInt, lim < org => eitherOK ¬ FALSE;

ENDCASE => eitherOK ¬ TRUE;

type ¬ t.rangeType;

LOOP;

};

real => RETURN [MimP4.Repr.real];

signed => IF eitherOK
THEN GO TO retEither ELSE RETURN [MimP4.Repr.signed];

unsigned => IF eitherOK
THEN GO TO retEither ELSE RETURN [MimP4.Repr.unsigned];

ENDCASE;

};

RETURN [MimP4.Repr.other];

ENDLOOP;

EXITS retEither => RETURN [MimP4.Repr.either];

};

ComparableType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {

compatibility version

sei: CSEIndex = ClearType[type];

sep: Symbols.CSEPointer = @seb[sei];

WITH t: sep SELECT FROM

record => RETURN [t.hints.comparable OR t.argument];

array => RETURN [~SparseRep[t.indexType] AND ComparableType[t.componentType]];

opaque => RETURN [t.lengthKnown];

any => RETURN [FALSE];

ENDCASE => RETURN [TRUE];

};

DefaultBasicOps: PUBLIC PROC [type: Type, size: BitCount] RETURNS [BOOL] = {

next: Type;

FOR s: Type ¬ type, next DO

sep: Symbols.SEPointer = @seb[s];

WITH se: sep SELECT FROM

id => {

sei: ISEIndex = LOOPHOLE[s];

IF se.extended THEN {

IF OpName[SymbolOps.FindExtension[SymbolOps.own, sei].tree] # void THEN RETURN [FALSE];

EXIT;

};

next ¬ SymbolOps.DecodeType[se.idInfo];

};

cons =>

WITH t: se SELECT FROM

ref => IF t.counted THEN RETURN [FALSE] ELSE EXIT;

array => next ¬ t.componentType;

record => IF t.hints.default THEN RETURN [FALSE] ELSE EXIT;

transfer => IF t.mode = port THEN RETURN [FALSE] ELSE EXIT;

zone => IF t.counted THEN RETURN [FALSE] ELSE EXIT;

ENDCASE => EXIT;

ENDCASE;

ENDLOOP;

IF MimP4.BitsForType[type] > size THEN RETURN [FALSE];

IF MimP4.WordsForType[type] # CARD[size+bitsPerWord-1]/bitsPerWord THEN RETURN [FALSE];

IF NOT ComparableType[type] THEN RETURN [FALSE];

IF SymbolOps.TypeLink[SymbolOps.own, type] # nullType THEN RETURN [FALSE];

RETURN [TRUE];

};

Private procedures

ItemId: PROC [t: Tree.Link] RETURNS [ISEIndex] = {

WITH t SELECT GetTag[t] FROM

symbol => RETURN [index];

subtree => t ¬ tb[index].son[1];

ENDCASE => ERROR;

ENDLOOP;

};

FirstId: PROC [node: Tree.Index] RETURNS [ISEIndex] = {

RETURN [ItemId[ListHead[tb[node].son[1]]]];

};

TypeForDecl: PROC [node: Tree.Index] RETURNS [Type] = {

RETURN [IF tb[node].son[2] # Tree.Null

THEN TypeForTree[tb[node].son[2]]

ELSE seb[FirstId[node]].idType]

};

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

IF OpName[t] = all THEN {t ¬ NthSon[t, 1]; LOOP};

RETURN [MimP4.StructuredLiteral[t]];

ENDLOOP;

};

InlineByte: Tree.Map = {

v ¬ MimP4.Rhs[t, MimData.idCARDINAL];

MimP4.VPop[];

IF ~MimP4.TreeLiteral[v] THEN MimosaLog.ErrorTree[nonConstant, v];

};

InlineOp: Tree.Map = {

WITH t SELECT GetTag[t] FROM

string => {v ¬ MimP4.Rhs[t, typeANY]; MimP4.VPop[]};

ENDCASE => v ¬ UpdateList[t, InlineByte];

};

DefineSEVar: PROC [ids: Tree.Link] = {

UpdateSE: Tree.Scan = {

sei: ISEIndex = ItemId[t];

seb[sei].constant ¬ FALSE};

ScanList[ids, UpdateSE];

};

DefineSEValue: PROC
[ids: Tree.Link, value: UNSPEC¬nullValue, info: CBTIndex¬CBTNull] = {

UpdateSE: Tree.Scan = {

sei: ISEIndex = ItemId[t];

seb[sei].constant ¬ TRUE;

seb[sei].idValue ¬ value;

seb[sei].idInfo ¬ SymbolOps.EncodeBti[info];

};

ScanList[ids, UpdateSE];

};

MarkSize: Tree.Scan = {

sei: ISEIndex = ItemId[t];

seb[sei].flags.sized ¬ TRUE;

};

AugmentSEValue: PROC
[ids: Tree.Link, type: ExtensionType, extension: Tree.Link, copy: BOOL ¬ FALSE] = {

UpdateSE: Tree.Scan = {

sei: ISEIndex = ItemId[t];

SymbolOps.EnterExtension[sei, type, IF copy THEN IdentityMap[extension] ELSE extension];

copy ¬ TRUE;

};

ScanList[ids, UpdateSE];

};

MarkAndCheckSE: PROC [ids: Tree.Link, initialized: BOOL] = {

UpdateSE: Tree.Scan = {

sei: ISEIndex = ItemId[t];

level: ContextLevel = SymbolOps.CtxLevel[SymbolOps.own, seb[sei].idCtx];

seb[sei].mark4 ¬ TRUE;

IF MimData.interface THEN CheckDefinition[sei, initialized];

IF seb[sei].idType = typeTYPE AND level # lZ THEN

seb[sei].idValue ¬ SymbolOps.EncodeCard[sei - ISEFirst];

IF seb[sei].idType # typeTYPE AND level > lG AND level < MimP4.currentLevel THEN {

IF suspectFlaw THEN MimosaLog.WarningSei[other, sei];

SymbolOps.SetCtxLevel[seb[sei].idCtx, MimP4.currentLevel];

};

ScanList[ids, UpdateSE];

};

CheckDefinition: PROC [sei: ISEIndex, initialized: BOOL] = {

SELECT seb[sei].idCtx FROM

MimData.mainCtx =>

SELECT SymbolOps.LinkMode[SymbolOps.own, sei] FROM

val => IF ~initialized OR seb[sei].extended THEN RETURN;

ref => IF ~initialized THEN RETURN;

manifest, type => IF SymbolOps.ConstantId[sei] THEN RETURN;

ENDCASE;

ENDCASE => RETURN;

MimosaLog.ErrorSei[nonDefinition, sei];

};

CheckDefaults: PROC [t: Tree.Link] = {

TestDefaults: Tree.Scan = {

node: Tree.Index = GetNode[t];

saveIndex: SourceMap.Loc = MimData.textIndex;

sei: ISEIndex = FirstId[node];

MimData.textIndex ¬ ToLoc[tb[node].info];

IF seb[sei].extended THEN {

type: Type = (IF seb[sei].idType = typeTYPE THEN sei ELSE seb[sei].idType);

nType: CSEIndex = SymbolOps.NormalType[SymbolOps.own, type];

TestDefault: Tree.Map = {

IF OpName[t] = void

THEN v ¬ t

ELSE {

v ¬ MimP4.Rhs[t, type, $init];

v ¬ MimP4.AdjustBias[v, MimP4.VRep[], BiasForType[type], TRUE];

IF MimP4.TreeLiteral[v] THEN {

WITH n: seb[nType] SELECT FROM

signed =>

IF MimP4.VRep[] = MimP4.Repr.signed THEN GO TO noForce;

unsigned =>

IF MimP4.VRep[] = MimP4.Repr.unsigned THEN GO TO noForce;

real =>

IF MimP4.VRep[] = MimP4.Repr.real THEN GO TO noForce;

ENDCASE;

v ¬ MimP4.ForceType[v, type];

EXITS noForce => {};

};

IF ~(MimP4.VProp[].noFreeVar OR (SIGNAL VarInit[])) THEN

MimosaLog.ErrorTree[nonConstant, v];

MimP4.VPop[];

};

t: Tree.Link ¬ SymbolOps.FindExtension[SymbolOps.own, sei].tree;

v: Tree.Link ¬ UpdateList[IdentityMap[t], TestDefault];

IF GetTag[t] # symbol AND MimP4.StructuredLiteral[v]

THEN UpdateDefaults[tb[node].son[1], v]

ELSE v ¬ FreeTree[v];

};

MimData.textIndex ¬ saveIndex;

};

IF MimData.interface THEN ScanList[t, TestDefaults];

};

UpdateDefaults: PROC [ids: Tree.Link, v: Tree.Link] = {

copy: BOOL ¬ FALSE;

UpdateDefault: Tree.Scan = {

sei: ISEIndex = ItemId[t];

old: Tree.Link ¬ SymbolOps.FindExtension[SymbolOps.own, sei].tree;

SymbolOps.EnterExtension[sei, default, IF copy THEN IdentityMap[v] ELSE v];

copy ¬ TRUE;

[] ¬ FreeTree[old];

};

ScanList[ids, UpdateDefault];

};

TrimTree: Tree.Map = {

v ¬ t;

WITH t SELECT GetTag[t] FROM

subtree => {

node: Tree.Index = index;

SELECT tb[node].name FROM

body => {

PushTree[TrimTree[tb[node].son[1]]];

PushTrimDecls[tb[node].son[2]];

PushTree[TrimTree[tb[node].son[3]]];

PushTree[TrimTree[tb[node].son[4]]];

PushNode[body, 4];

SetInfo[tb[node].info];

SetAttrs[tb[node].attr1, tb[node].attr2, tb[node].attr3];

v ¬ PopTree[];

};

block => {

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

PushTree[TrimTree[tb[node].son[2]]];

PushNode[block, 2];

SetInfo[tb[node].info];

SetAttrs[tb[node].attr1, tb[node].attr2, tb[node].attr3];

v ¬ PopTree[];

};

cdot => v ¬ TrimTree[tb[node].son[2]];

ENDCASE => IF t # Tree.Null THEN v ¬ CopyTree[[@tb, t], TrimTree]};

ENDCASE;

};

PushTrimDecls: PROC [t: Tree.Link] = {

IF OpName[t] = initlist

THEN {

node: Tree.Index = GetNode[t];

PushTree[TrimTree[tb[node].son[1]]];

PushTrimDecls[tb[node].son[2]];

PushNode[initlist, 2];

SetInfo[tb[node].info];

}

ELSE {

n: CARDINAL ¬ 0;

PushDecl: Tree.Scan = {

node: Tree.Index = GetNode[t];

SELECT tb[node].name FROM

typedecl => NULL;

decl => {

init: Tree.Link = tb[node].son[3];

PushTree[TrimTree[tb[node].son[1]]]; PushTree[Tree.Null];

PushTree[TrimTree[init]];

PushNode[decl, 3]; SetInfo[tb[node].info];

SetAttrs[tb[node].attr1, tb[node].attr2, ~MimP4.mark];

n ¬ n+1;

};

ENDCASE => ERROR;

};

ScanList[t, PushDecl];

PushList[n];

};

SetInitAttr: PROC [type: Type, const: BOOL] = INLINE {

SetAttr[1, TRUE];

IF MimP4.currentLevel = lG AND ~const

THEN

SELECT SymbolOps.RCType[SymbolOps.own, type] FROM

simple => {SetAttr[2, TRUE]; SetAttr[3, FALSE]};

composite => {SetAttr[2, TRUE]; SetAttr[3, TRUE]};

ENDCASE => SetAttr[2, FALSE]

ELSE

SetAttr[2, FALSE];

};

EvalUnsigned: PROC [t: Tree.Link, default: CARD] RETURNS [v: Tree.Link, n: CARD] = {

v ¬ MimP4.Rhs[t, MimData.idCARDINAL];

MimP4.VPop[];

IF MimP4.TreeLiteral[v]

THEN n ¬ MimP4.TreeLiteralCard[v]

ELSE {MimosaLog.ErrorTree[nonConstant, v]; n ¬ default};

};

LayoutEnum: PROC [t: Tree.Link, ctx: CTXIndex]
RETURNS [empty: BOOL ¬ TRUE, range: CARD ¬ 0, sparse: BOOL ¬ FALSE] = {

AssignElement: Tree.Scan = {

val: CARD ¬ range;

WITH e: t SELECT GetTag[t] FROM

subtree => [tb[e.index].son[2], val] ¬ EvalUnsigned[tb[e.index].son[2], val];

ENDCASE;

IF val > Target.maxWord THEN MimosaLog.ErrorSei[addressOverflow, sei];

IF empty

THEN {

IF val # 0 THEN sparse ¬ TRUE;

empty ¬ FALSE;

}

ELSE {

IF val < range THEN MimosaLog.ErrorSei[enumOrder, sei];

IF val # range THEN sparse ¬ TRUE;

};

range ¬ val+1;

seb[sei].idValue ¬ SymbolOps.EncodeCard[val];

sei ¬ SymbolOps.NextSe[SymbolOps.own, sei];

};

sei: ISEIndex ¬ SymbolOps.FirstCtxSe[SymbolOps.own, ctx];

ScanList[t, AssignElement];

IF NOT empty THEN range ¬ range - 1;

};

AssignPositions: PROC [item: Tree.Link] = {

node: Tree.Index = GetNode[item];

saveIndex: SourceMap.Loc = MimData.textIndex;

type: Type = TypeForTree[tb[node].son[2]];

nB: CARD;

lastSei: ISEIndex ¬ ISENull;

AssignPosition: Tree.Scan = {

fStart: CARD;

fBits: CARD;

ud, bL, bR: CARD;

sei: ISEIndex = ItemId[t];

node: Tree.Index = GetNode[NthSon[t, 2]];

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

[tb[node].son[1], ud] ¬ EvalUnsigned[tb[node].son[1], 0];

SELECT targetBitOrder FROM

msBit => {bL ¬ 0; bR ¬ nB-1};

lsBit => {bL ¬ nB-1; bR ¬ 0};

ENDCASE => ERROR;

IF son2 = Tree.Null

THEN {

Round up the number of bits to the appropriate grain.

mod: NAT = Basics.LowHalf[nB] MOD grain;

IF mod # 0 THEN {

nB ¬ nB + (grain - mod);

SELECT targetBitOrder FROM

msBit => bR ¬ nB-1;

lsBit => bL ¬ nB-1;

ENDCASE => ERROR;

};

}

ELSE {

Bit positions specified, so evaluate them

subNode: Tree.Index = GetNode[son2];

[tb[subNode].son[1], bL] ¬ EvalUnsigned[tb[subNode].son[1], bL];

[tb[subNode].son[2], bR] ¬ EvalUnsigned[tb[subNode].son[2], bR];

};

Convert bL & bR from relative bit numbers (either bit order) into absolute

ud ¬ ud * grain;

bL ¬ bL + ud;

bR ¬ bR + ud;

fStart ¬ bL; -- most significant bit order is always the left number

SELECT targetBitOrder FROM

msBit => fBits ¬ bR-bL+1;

lsBit => fBits ¬ bL-bR+1;

ENDCASE => ERROR;

IF fBits < nB OR LOOPHOLE[fBits, INT] < 0 THEN {

The field is not large enough to contain the value

MimosaLog.ErrorSei[fieldPosition, sei];

fBits ¬ nB;

};

IF targetBitOrder = lsBit THEN

Convert bL into internal bit numbering (MSBIT)

fStart ¬ Basics.BITXOR[fStart, bitsPerWord-1];

IF SymbolOps.RCType[SymbolOps.own, seb[sei].idType] # none THEN

An RC field must be properly aligned!

IF (Basics.LowHalf[bL] MOD bitsPerWord) # 0 THEN

MimosaLog.ErrorSei[fieldPosition, sei];

seb[sei].idValue ¬ SymbolOps.EncodeCard[fStart];

seb[sei].idInfo ¬ SymbolOps.EncodeCard[fBits];

};

MimData.textIndex ¬ ToLoc[tb[node].info];

nB ¬ MimP4.BitsForType[type];

ScanList[tb[node].son[1], AssignPosition];

MimData.textIndex ¬ saveIndex;

};

ExtractFieldAttributes: PROC [rType: RecordSEIndex] = {

compatibility version

comparable: BOOL ¬ TRUE;

privateFields: BOOL ¬ FALSE;

FOR sei: ISEIndex ¬ SymbolOps.FirstCtxSe[SymbolOps.own, seb[rType].fieldCtx], SymbolOps.NextSe[SymbolOps.own, sei]
UNTIL sei = ISENull DO

type: CSEIndex ¬ SymbolOps.UnderType[SymbolOps.own, seb[sei].idType];

sep: Symbols.CSEPointer = @seb[type];

WITH t: sep SELECT FROM

record =>

IF ~t.hints.comparable AND ~ComparableType[type] THEN comparable ¬ FALSE;

array => IF ~ComparableType[type] THEN comparable ¬ FALSE;

union => IF ~t.hints.equalLengths THEN comparable ¬ FALSE;

sequence => comparable ¬ FALSE;

ENDCASE;

IF ~seb[sei].public THEN privateFields ¬ TRUE;

ENDLOOP;

seb[rType].hints.comparable ¬ comparable;

seb[rType].hints.privateFields ¬ privateFields;

};

ProcessVariants: PROC [tt: Type, list: Tree.Link] = {

MapTag: PROC [vSei: ISEIndex] RETURNS [CARD] = {

WITH t: seb[tagType] SELECT FROM

enumerated =>

IF t.machineDep THEN {

sei: ISEIndex = SymbolOps.SearchContext[
SymbolOps.own, seb[vSei].hash, t.valueCtx];

IF sei # ISENull THEN vSei ¬ sei;

};

ENDCASE;

RETURN [SymbolOps.DecodeCard[seb[vSei].idValue]];

};

CheckTag: Tree.Scan = {

sei: ISEIndex = ItemId[t];

tag: Bias = ConstArith.FromCard[MapTag[sei]];

SELECT TRUE FROM

ConstArith.Compare[tag, lb] = less, ConstArith.Compare[tag, ub] # less => {

MimosaLog.ErrorSei[boundsFault, sei];

seb[sei].idValue ¬ SymbolOps.EncodeCard[0];

};

ENDCASE => {

delta: CARD ¬ ConstArith.ToCard[ConstArith.Sub[tag, lb]];

seb[sei].idValue ¬ SymbolOps.EncodeCard[delta];

};

ProcessVariant: Tree.Scan = {

saveIndex: SourceMap.Loc = MimData.textIndex;

node: Tree.Index = GetNode[t];

MimData.textIndex ¬ ToLoc[tb[node].info];

ScanList[tb[node].son[1], CheckTag];

DeclItem[t];

MimData.textIndex ¬ saveIndex;

};

tagType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, tt];

lb: Bias ¬ BiasForType[tagType];

ub: Bias ¬ ConstArith.Add[lb,
ConstArith.FromCard[SymbolOps.Cardinality[SymbolOps.own, tagType]]];

ScanList[list, ProcessVariant];

};

SparseRep: PROC [type: Type] RETURNS [BOOL] = {

nType: CSEIndex = SymbolOps.NormalType[SymbolOps.own, type];

RETURN [WITH t: seb[nType] SELECT FROM

enumerated => t.sparse,

ENDCASE => FALSE]

};

Initialization & notification

DeclNotify: MimosaEvents.Callback = {

called by allocator whenever table area is repacked

SELECT class FROM

relocate => {

tb ¬ MimData.base[Tree.treeType];

seb ¬ MimData.base[seType];

ctxb ¬ MimData.base[ctxType];

bb ¬ MimData.base[bodyType];

};

cleanup => {

MimZones.tempZone.FREE[@typeStack];

};

ENDCASE;

};

MimosaEvents.Register[DeclNotify, relocate];

MimosaEvents.Register[DeclNotify, cleanup];