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

Pass2.mesa

Satterthwaite, June 18, 1986 12:20:58 pm PDT

Russ Atkinson (RRA) November 20, 1989 10:55:04 pm PST

DIRECTORY

Alloc USING [AddNotify, Bounds, DropNotify, Notifier, OrderedIndex, Units],

CompilerUtil USING [],

MimData USING [bitsToAlignment, bodyIndex, defBodyLimit, idLOCK, importCtx, interface, mainCtx, moduleCtx, monitored, nBodies, nErrors, nInnerBodies, nSigCodes, ownSymbols, table, textIndex, wordAlignment, worstAlignment],

MimosaLog USING [Error, ErrorHti, ErrorRope],

MimZonePort,

SourceMap USING [Down, Loc, nullLoc],

SourceMarks,

SymbolOps USING [BlockLevel, EncodeCard, EncodeTreeIndex, FillCtxSe, FirstCtxSe, FromBti, FromCtx, FromType, NewCtx, MakeNonCtxSe, MakeSeChain, NameClash, NextLevel, NextSe, SetMainCtx, StaticNestError, ToBti],

Symbols USING [Base, BitOrder, BodyInfo, BodyLink, BodyRecord, bodyType, BTIndex, BTNull, CBTIndex, CBTNull, ContextLevel, CSEIndex, CSENull, CTXIndex, CTXNull, ctxType, ISEIndex, ISENull, lG, lL, lZ, Name, nullName, nullType, RecordSEIndex, RecordSENull, RootBti, SERecord, seType, TransferMode, Type, typeANY, typeTYPE],

Target: TYPE MachineParms USING [bitOrder, bitsPerAU, bitsPerLink, bitsPerMonLock, bitsPerProc, bitsPerProcess, bitsPerPort, bitsPerSignal, bitsPerProgram, bitsPerPtr, bitsPerRef, bitsPerWord],

Tree USING [Base, Index, Link, lsbitOption, Map, msbitOption, nativeOption, NodeName, Null, nullIndex, packedOption, Scan, treeType, word16Option, word32Option, word64Option, word8Option],

TreeOps USING [FreeNode, FromCard, GetInfo, GetNode, GetTag, ListHead, ListLength, NthSon, OpName, PutInfo, ScanList, ToLoc, UpdateList];

Pass2: PROGRAM

IMPORTS Alloc, MimData, MimosaLog, MimZonePort, SourceMap, SourceMarks, SymbolOps, TreeOps

EXPORTS CompilerUtil = {

OPEN TreeOps, Symbols;

recordPainted: BOOL ¬ TRUE;

If TRUE, then records default to being painted (but not argument records).

enumPainted: BOOL ¬ TRUE;

If TRUE, then enumerations default to being painted.

recordPacked: BOOL ¬ FALSE;

If TRUE, then records default to being packed.

targetBitOrder: Symbols.BitOrder = SELECT Target.bitOrder FROM

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

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

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

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

bb: Symbols.Base; -- body table base (private copy)

Notify: Alloc.Notifier = {

called by allocator whenever tables are repacked

tb ¬ base[Tree.treeType];

seb ¬ base[seType];

ctxb ¬ base[ctxType];

bb ¬ base[bodyType];

};

bbZoneScratch: MimZonePort.Scratch;

bbZone: UNCOUNTED ZONE ¬ MimZonePort.MakeZone[
alloc: BbZoneProc, free: NIL, scratch: @bbZoneScratch];

BbZoneProc: PROC
[self: UNCOUNTED ZONE, size: CARDINAL] RETURNS [ptr: LONG POINTER] = {

index: Alloc.OrderedIndex = (MimData.table).Units[bodyType, size];

ptr ¬ @bb[index];

};

CBTRelative: PROC
[ptr: LONG POINTER TO BodyRecord.Callable] RETURNS [CBTIndex] = INLINE {

RETURN [LOOPHOLE[ptr-LOOPHOLE[bb, LONG POINTER TO BodyRecord.Callable]]];

};

BTRelative: PROC [ptr: LONG POINTER TO BodyRecord] RETURNS [BTIndex] = INLINE {

RETURN [LOOPHOLE[ptr-LOOPHOLE[bb, LONG POINTER TO BodyRecord]]];

};

ContextInfo: TYPE = RECORD [

ctx: CTXIndex,

staticLevel: ContextLevel,

seChain: ISEIndex];

current: ContextInfo;

NewContext: PROC [level: ContextLevel, entries: NAT, unique: BOOL] = {

current.staticLevel ¬ level;

IF entries = 0 AND ~unique

THEN {

current.ctx ¬ CTXNull;

current.seChain ¬ ISENull;

}

ELSE {

current.ctx ¬ SymbolOps.NewCtx[level];

ctxb[current.ctx].seList ¬ current.seChain ¬
SymbolOps.MakeSeChain[current.ctx, entries, level=lG];

};

parentRecordType: RecordSEIndex ¬ RecordSENull;

main driver

TypeOptions: TYPE = RECORD [

packed: BOOL ¬ FALSE,

orderOption: Symbols.BitOrder ¬ targetBitOrder,

grain: NAT ¬ Target.bitsPerWord

];

defaultOptions: TypeOptions ¬ [];

globalOptions: TypeOptions ¬ [];

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

node: Tree.Index;

(MimData.table).AddNotify[Notify];

anySei ¬ CSENull;

globalOptions ¬ [];

node ¬ GetNode[t];

{

ENABLE {

default error reporting

SymbolOps.NameClash => {MimosaLog.ErrorHti[duplicateId, name]; RESUME};

SymbolOps.StaticNestError => {MimosaLog.Error[staticNesting]; RESUME};

};

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

MimData.bodyIndex ¬ CBTNull;

MimData.nBodies ¬ MimData.nInnerBodies ¬ MimData.nSigCodes ¬ 0;

btLink ¬ [which: parent, index: BTNull];

NewContext[

level: lZ,

entries: ListLength[tb[node].son[1]] + CountIds[tb[node].son[6]],

unique: FALSE];

MimData.moduleCtx ¬ current.ctx;

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

{

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

saved: ContextInfo = current;

NewContext[lG, ListLength[t], FALSE];

MimData.importCtx ¬ current.ctx;

ScanList[t, IdItem];

current ¬ saved;

};

process LOCKS clause

MimData.monitored ¬ tb[node].son[5] # Tree.Null;

lockLambda ¬ Lambda[tb[node].son[5], lL];

{

t: Tree.Link = tb[node].son[6];

MimData.interface ¬ (OpName[NthSon[t, 2]] = definitionTC);

DeclList[t];

BodyList[RootBti];

};

MimData.defBodyLimit ¬ (MimData.table).Bounds[bodyType].size;

};

IF MimData.nErrors = 0 THEN {

[] ¬ ProcessSourceList[SourceMap.Down[MimData.textIndex]];

ExtendBodySource[RootBti];

};

(MimData.table).DropNotify[Notify];

RETURN [t];

};

ExtendBodySource: PROC [firstBti: BTIndex] = {

FOR bti: BTIndex ¬ firstBti, bb[bti].link.index UNTIL bti = BTNull DO

WITH bb[bti] SELECT FROM

Callable => {

node: Tree.Index = NARROW[bb[bti].info, BodyInfo.Internal].bodyTree;

startPos: INT ¬ bb[bti].sourceIndex;

endPos: INT ¬ ExtendTreeSource[[subtree[node]]];

IF endPos > startPos THEN SourceMarks.EndSource[startPos, endPos];

ExtendBodySource[bb[bti].firstSon];

};

ENDCASE;

IF bb[bti].link.which = parent THEN EXIT;

ENDLOOP

};

ExtendTreeSource: PROC [tree: Tree.Link] RETURNS [INT] = {

end: INT ¬ -1;

IF tree # Tree.Null THEN

WITH e: tree SELECT GetTag[tree] FROM

subtree => {

node: Tree.Index = e.index;

nSons: NAT ¬ tb[node].nSons;

IF nSons # 0 THEN {

firstSon: NAT ¬ 1;

fixup: BOOL ¬ FALSE;

SELECT name FROM

assign, extract, apply, if, case, bind, do, return, resume, label, free, signal, error, xerror, start, restart, join, wait, notify, broadcast, dst, lst, lste, lstf, open, enable, checked =>

These are statements

fixup ¬ TRUE;

basicTC, enumeratedTC, recordTC, monitoredTC, variantTC, refTC, pointerTC, listTC, arrayTC, arraydescTC, sequenceTC, procTC, processTC, portTC, signalTC, errorTC, programTC, anyTC, definitionTC, unionTC, relativeTC, subrangeTC, longTC, opaqueTC, zoneTC, linkTC, varTC, implicitTC, frameTC, discrimTC, paintTC, optionTC, spareTC =>

Type constructors, no subsidiary statements

GO TO done;

atom, clit, continue, exit, first, goto, last, llit, loop, mwconst, nil, null, reject, retry, stop, syserror, syserrorx, typecode, void =>

No possible statements to process

GO TO done;

arraydesc => IF nSons > 2 THEN nSons ¬ 2;

size, item => firstSon ¬ 2;

new, narrow, istype, loophole => {

Skip son[2], which is a type expression

end ¬ ExtendTreeSource[tb[node].son[1]];

firstSon ¬ 3;

};

ENDCASE;

FOR i: NAT IN [firstSon..nSons] DO

t: Tree.Link ¬ tb[node].son[i];

IF t # Tree.Null THEN

WITH ee: t SELECT GetTag[t] FROM

subtree => end ¬ MAX[end, ExtendTreeSource[t]];

ENDCASE;

ENDLOOP;

IF fixup THEN {

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

IF loc # SourceMap.nullLoc THEN {

start: INT ¬ SourceMap.Down[loc];

max: INT;

found: BOOL;

[found: found, endPos: max] ¬ SourceMarks.GetProps[start];

IF found THEN {

max ¬ MAX[start, max];

IF end > 1000000 OR start > 1000000 THEN ERROR;

IF end > max

THEN SourceMarks.EndSource[start, end]

ELSE end ¬ max;

};

EXITS done => {};

};

ENDCASE;

RETURN [end];

};

ProcessSourceList: PROC [start: INT] RETURNS [INT] = {

The idea is to set the end positions based on the marks that we have inserted. A source range that starts with $Begin ends with a matching position marked by $End. A source range that starts with $Stmt or $Decl ends with the next marked position.

pos: INT ¬ start;

lag: INT ¬ -1;

WHILE pos >= 0 DO

mark: REF ¬ SourceMarks.GetProps[pos].mark;

IF mark # NIL THEN {

IF lag >= 0 THEN {

We have terminated the lagging item

SourceMarks.EndSource[lag, pos];

lag ¬ -1;

};

SELECT mark FROM

$Begin => {

next: INT ¬ SourceMarks.GetNext[pos];

stop: INT ¬ ProcessSourceList[next];

IF stop < 0 THEN RETURN [stop];

SourceMarks.EndSource[pos, stop];

pos ¬ stop;

};

$End => RETURN [pos];

$Stmt, $Decl => lag ¬ pos;

ENDCASE;

};

pos ¬ SourceMarks.GetNext[pos];

ENDLOOP;

RETURN [pos];

};

monitor lock processing

lockLambda: Tree.Index;

Lambda: PROC [item: Tree.Link, level: ContextLevel] RETURNS [node: Tree.Index] = {

node ¬ GetNode[item];

IF node # Tree.nullIndex THEN {

saved: ContextInfo = current;

NewContext[level, CountIds[tb[node].son[1]], FALSE];

tb[node].info ¬ SymbolOps.FromCtx[current.ctx];

DeclList[tb[node].son[1]]; Exp[tb[node].son[2]];

current ¬ saved;

};

ImplicitLock: PROC = {

sei: ISEIndex = current.seChain;

tb[lockLambda].son[2] ¬ Ids[

list: tb[lockLambda].son[2],

public: tb[lockLambda].attr2,

link: Tree.nullIndex];

seb[sei].idType ¬ MimData.idLOCK;

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

seb[sei].idInfo ¬ SymbolOps.EncodeCard[Target.bitsPerMonLock];

seb[sei].mark3 ¬ TRUE;

};

body processing

btLink: BodyLink;

AllocateBody: PROC [node: Tree.Index, id: ISEIndex] RETURNS [bti: CBTIndex] = {

queue body for later processing

force nesting message here

bPtr: LONG POINTER TO BodyRecord.Callable ¬ bbZone.NEW[BodyRecord.Callable];

bti ¬ CBTRelative[bPtr];

SELECT SymbolOps.NextLevel[current.staticLevel] FROM

lG, lL => {

bPtr.kind ¬ Outer;

};

ENDCASE => {

bPtr.kind ¬ Inner;

};

bPtr.frameOffset ¬ 0;

bPtr.firstSon ¬ BTNull;

bPtr.sourceIndex ¬ MimData.textIndex.Down;

bPtr.info ¬ [cases: Internal[bodyTree:node, thread:Tree.nullIndex, frameSize: 0]];

bPtr.id ¬ id;

bPtr.entry ¬ bPtr.internal ¬ FALSE;

conservative initial approximations

bPtr.ioType ¬ typeANY;

bPtr.noXfers ¬ FALSE;

bPtr.hints ¬ [safe: FALSE, argUpdated: TRUE, nameSafe: FALSE, noStrings: FALSE];

LinkBody[bti];

};

LinkBody: PROC [bti: BTIndex] = {

IF btLink.which = parent

THEN {

bb[bti].link ¬ btLink;

IF btLink.index # BTNull

THEN bb[btLink.index].firstSon ¬ bti

ELSE IF bti # RootBti THEN ERROR;

}

ELSE {

bb[bti].link ¬ bb[btLink.index].link;

bb[btLink.index].link ¬ [which: sibling, index: bti];

}

};

SetEntryAttr: PROC [t: Tree.Link, attr: Tree.NodeName] = {

IF OpName[t] # body OR ~MimData.monitored

THEN MimosaLog.Error[misplacedEntry]

ELSE {

see AllocateBody

bti: BTIndex = SymbolOps.ToBti[GetInfo[t]];

WITH body: bb[bti] SELECT FROM

Callable =>

SELECT attr FROM

entry => body.entry ¬ TRUE;

internal => body.internal ¬ TRUE;

ENDCASE;

};

BodyList: PROC [firstBti: BTIndex] = {

FOR bti: BTIndex ¬ firstBti, bb[bti].link.index UNTIL bti = BTNull DO

WITH cb: bb[bti] SELECT FROM

Callable => {

cbti: CBTIndex = LOOPHOLE[bti];

node: Tree.Index = NARROW[cb.info, BodyInfo.Internal].bodyTree;

level: ContextLevel;

nLocks: [0..1] ¬ 0;

oldBodyIndex: CBTIndex = MimData.bodyIndex;

oldBtLink: BodyLink = btLink;

saved: ContextInfo = current;

MimData.bodyIndex ¬ cbti;

btLink ¬ [which: parent, index: bti];

level ¬ SymbolOps.NextLevel[saved.staticLevel

! SymbolOps.StaticNestError => {RESUME}];

IF level = lG AND MimData.monitored AND tb[lockLambda].attr1 THEN nLocks ¬ 1;

NewContext[

level: level,

entries: nLocks + CountIds[tb[node].son[2]],

unique: level = lG];

cb.localCtx ¬ current.ctx;

cb.level ¬ SymbolOps.BlockLevel[level];

cb.monitored ¬ nLocks # 0;

cb.inline ¬ tb[node].attr3;

cb.type ¬ IF current.ctx = CTXNull OR cb.inline

THEN RecordSENull

ELSE BodyType[current.ctx, cb.monitored];

IF level = lG THEN {

IF bti # RootBti THEN ERROR;

MimData.mainCtx ¬ current.ctx;

SymbolOps.SetMainCtx[current.ctx];

};

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

IF nLocks # 0 THEN ImplicitLock[];

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

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

BodyList[cb.firstSon];

current ¬ saved;

MimData.bodyIndex ¬ oldBodyIndex;

btLink ¬ oldBtLink;

};

ENDCASE;

IF bb[bti].link.which = parent THEN EXIT;

ENDLOOP

};

NewScope: PROC [node: Tree.Index, decls: Tree.Link] RETURNS [bti: BTIndex] = {

level: ContextLevel = SymbolOps.BlockLevel[current.staticLevel];

NewContext[level: level, entries: CountIds[decls], unique: FALSE];

{

rSei: RecordSEIndex = IF bb[MimData.bodyIndex].inline

THEN RecordSENull ELSE BodyType[current.ctx, FALSE];

bPtr: LONG POINTER TO BodyRecord.Other ¬ bbZone.NEW[BodyRecord.Other ¬ [

link: ,

firstSon: BTNull,

type: rSei,

localCtx: current.ctx,

level: level,

sourceIndex: ToLoc[tb[node].info].Down,

info: [cases: Internal[bodyTree: node, thread: Tree.nullIndex, frameSize: 0]],

extension: Other[relOffset: ]

]];

bti ¬ BTRelative[bPtr];

LinkBody[bti];

btLink ¬ [which: parent, index: bti];

DeclList[decls];

};

BodyType: PROC [ctx: CTXIndex, monitored: BOOL] RETURNS [rSei: RecordSEIndex] = {

rSei ¬ LOOPHOLE[SymbolOps.MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE]];

seb[rSei].align ¬ MimData.worstAlignment;

seb[rSei].typeInfo ¬ record[

machineDep: FALSE, painted: TRUE, argument: FALSE,

bitOrder: globalOptions.orderOption,

grain: globalOptions.grain,

packed: FALSE, spare: FALSE, list: FALSE,

hints: [

unifield: FALSE, variant: FALSE,

assignable: FALSE, comparable: FALSE, privateFields: TRUE,

refField: FALSE, default: FALSE, voidable: FALSE],

length: 0,

fieldCtx: ctx,

monitored: monitored,

linkPart: notLinked[]];

};

CodeBody: PROC [node: Tree.Index] = {

InlineOp: Tree.Scan = {ExpList[t]};

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

};

declarations

DeclList: PROC [t: Tree.Link, linkId: Type¬nullType] = {

DeclItem: Tree.Scan = {

node: Tree.Index = GetNode[t];

saveIndex: SourceMap.Loc = MimData.textIndex;

MarkSource[MimData.textIndex ¬ ToLoc[tb[node].info], $Decl];

tb[node].son[1] ¬ Ids[

list: tb[node].son[1],

type: (tb[node].name = typedecl),

public: tb[node].attr2,

link: node];

tb[node].attr2 ¬ tb[node].attr3 ¬ FALSE;

SELECT tb[node].name FROM

typedecl => {

TypeExp[t: tb[node].son[2], typeId: FirstId[tb[node].son[1]], linkId: linkId];

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

};

decl => {

TypeExp[t: tb[node].son[2], linkId: linkId];

tb[node].son[3] ¬ InitialValue[

tb[node].son[3],

IF tb[node].attr1 THEN FirstId[tb[node].son[1]] ELSE ISENull];

};

ENDCASE => MimosaLog.Error[unimplemented];

MimData.textIndex ¬ saveIndex;

};

ScanList[t, DeclItem];

};

CountIds: PROC [declList: Tree.Link] RETURNS [n: NAT¬0] = {

NIds: Tree.Scan = {n ¬ n + ListLength[NthSon[t, 1]]};

ScanList[declList, NIds];

};

InitialValue: PROC [t: Tree.Link, id: ISEIndex] RETURNS [v: Tree.Link] = {

v ¬ t; -- the default

IF t # Tree.Null THEN

WITH s: t SELECT GetTag[t] FROM

subtree => {

node: Tree.Index = s.index;

SELECT tb[node].name FROM

body => {

bti: CBTIndex = AllocateBody[node, id];

tb[node].info ¬ SymbolOps.FromBti[bti];

IF ~tb[node].attr3 THEN {

MimData.nBodies ¬ MimData.nBodies+1;

IF current.staticLevel >= lL THEN

MimData.nInnerBodies ¬ MimData.nInnerBodies + 1;

};

btLink ¬ [which: sibling, index: bti];

};

entry, internal => {

v ¬ InitialValue[tb[node].son[1], id];

SetEntryAttr[v, tb[node].name];

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

FreeNode[node];

};

signalinit => {

tb[node].info ¬ FromCard[MimData.nSigCodes];

MimData.nSigCodes ¬ MimData.nSigCodes+1;

};

inline => CodeBody[node];

ENDCASE => ExpList[t];

};

ENDCASE => ExpList[t]

};

IdItem: Tree.Scan = {

node: Tree.Index = GetNode[t];

saveIndex: SourceMap.Loc = MimData.textIndex;

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

tb[node].son[1] ¬ Ids[list: tb[node].son[1], public: FALSE, link: node];

MimData.textIndex ¬ saveIndex;

};

id list manipulation

Ids: PROC [list: Tree.Link, public: BOOL, type: BOOL ¬ FALSE, link: Tree.Index]
RETURNS [Tree.Link] = {

Id: Tree.Map = {

v ¬ t;

WITH t SELECT GetTag[t] FROM

hash, symbol => {

hash => index,

symbol => seb[index].hash,

ENDCASE => ERROR);

sei: ISEIndex = current.seChain;

current.seChain ¬ SymbolOps.NextSe[MimData.ownSymbols, current.seChain];

SymbolOps.FillCtxSe[sei, name, public];

seb[sei].idType ¬ (IF type THEN typeTYPE ELSE typeANY);

seb[sei].public ¬ public;

seb[sei].immutable ¬ seb[sei].constant ¬ FALSE;

seb[sei].idValue ¬ SymbolOps.EncodeTreeIndex[link];

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

seb[sei].extended ¬ seb[sei].linkSpace ¬ FALSE;

v ¬ [symbol[index: sei]];

};

subtree => IF OpName[t] # item

THEN MimosaLog.ErrorRope[other, "malformed id list"]

ELSE {

node: Tree.Index = index;

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

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

};

ENDCASE => ERROR;

};

RETURN [UpdateList[list, Id]];

};

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

head: Tree.Link = ListHead[t];

WHILE t # Tree.Null DO

head: Tree.Link = ListHead[t];

WITH head SELECT GetTag[head] FROM

symbol => RETURN [index];

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

ENDCASE => ERROR;

ENDLOOP;

RETURN [ISENull];

};

type manipulation

TypeExp: PROC [t: Tree.Link, typeId, linkId: Type¬nullType] = {

sei: CSEIndex ¬ CSENull;

WITH s: t SELECT GetTag[t] FROM

subtree => {

node: Tree.Index = s.index;

SELECT name FROM

enumeratedTC => {

machineDep: BOOL ¬ tb[node].attr2;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.enumerated.SIZE];

seb[sei].typeInfo ¬ enumerated[

ordered: TRUE, sparse: FALSE,

machineDep: machineDep,

painted: enumPainted OR machineDep OR MimData.interface,

valueCtx: Enumeration[node], empty: FALSE, range: 0];

AssignValues[sei, IF typeId # nullType THEN typeId ELSE sei];

};

recordTC, monitoredTC => {

tCtx: CTXIndex;

nFields: NAT;

machineDep: BOOL ¬ tb[node].attr1;

variant: BOOL ¬ tb[node].attr2;

painted: BOOL ¬ recordPainted
OR machineDep OR (MimData.interface AND tb[node].attr3);

packed: BOOL ¬ globalOptions.packed OR recordPacked OR machineDep;

oldParent: RecordSEIndex ¬ parentRecordType;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE];

parentRecordType ¬ LOOPHOLE[sei];

[tCtx, nFields] ¬ FieldList[

t: tb[node].son[1],

level: lZ,

typeId: IF typeId # nullType THEN typeId ELSE sei];

seb[sei].typeInfo ¬ record[

hints: [

unifield: nFields = 1 AND ~variant,

variant: variant,

assignable: TRUE, comparable: FALSE, privateFields: FALSE,

refField: FALSE, default: FALSE, voidable: TRUE],

machineDep: machineDep,

bitOrder: globalOptions.orderOption,

grain: globalOptions.grain,

painted: painted,

argument: FALSE, spare: FALSE,

list: FALSE, -- not set to TRUE until Pass3D.TypeLink

packed: packed,

length: 0,

fieldCtx: tCtx,

monitored: name = monitoredTC,

linkPart: notLinked[]];

IF name = monitoredTC AND machineDep THEN MimosaLog.Error[attrClash];

parentRecordType ¬ oldParent;

};

variantTC => {

machineDep: BOOL ¬ tb[node].attr1;

variant: BOOL ¬ tb[node].attr2;

painted: BOOL ¬ recordPainted OR tb[node].attr3;

packed: BOOL ¬ globalOptions.packed OR recordPacked OR machineDep;

oldParent: RecordSEIndex ¬ parentRecordType;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.record.linked.SIZE];

parentRecordType ¬ LOOPHOLE[sei];

seb[sei].typeInfo ¬ record[

machineDep: machineDep,

bitOrder: globalOptions.orderOption,

grain: globalOptions.grain,

painted: painted,

argument: FALSE, spare: FALSE, list: FALSE, monitored: FALSE,

packed: packed,

hints: [

unifield: FALSE,

variant: variant,

assignable: TRUE, comparable: FALSE, privateFields: FALSE,

refField: FALSE, default: FALSE, voidable: TRUE],

length: 0,

fieldCtx: FieldList[t: tb[node].son[1], level: lZ, typeId: typeId].ctx,

linkPart: linked[linkId]];

parentRecordType ¬ oldParent;

};

refTC, listTC, pointerTC, varTC => {

bits: NAT ¬ Target.bitsPerRef;

counted: BOOL ¬ FALSE;

SELECT name FROM

varTC => bits ¬ Target.bitsPerLink;

RRA: At this time (December 14, 1987), varTC is only used to indicate items in the interface that are definitely variable (via VAR or READONLY). If VAR ever becomes a genuine type constructor this may well have to change!

pointerTC => bits ¬ Target.bitsPerPtr;

ENDCASE => counted ¬ TRUE;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.ref.SIZE];

seb[sei].align ¬ MimData.bitsToAlignment[bits];

seb[sei].typeInfo ¬ ref[

counted: counted,

var: name = varTC,

ordered: tb[node].attr1,

basing: tb[node].attr2,

list: name = listTC,

readOnly: tb[node].attr3,

refType: nullType,

length: bits];

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

};

arrayTC => {

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.array.SIZE];

seb[sei].align ¬ MimData.wordAlignment;

seb[sei].typeInfo ¬ array[

packed: globalOptions.packed,

bitOrder: globalOptions.orderOption,

indexType: nullType,

componentType: ];

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

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

};

arraydescTC => {

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.arraydesc.SIZE];

seb[sei].align ¬ MimData.wordAlignment;

seb[sei].typeInfo ¬ arraydesc[

readOnly: tb[node].attr3,

var: FALSE,

bitOrder: globalOptions.orderOption,

describedType: nullType, length: Target.bitsPerWord*2];

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

};

procTC, processTC, portTC, signalTC, errorTC, programTC => {

modeMap: ARRAY Tree.NodeName[procTC..programTC] OF TransferMode = [

procTC: proc, processTC: process, portTC: port,

signalTC: signal, errorTC: error, programTC: program];

modeLength: ARRAY Tree.NodeName[procTC..programTC] OF NAT = [

procTC: Target.bitsPerProc,

processTC: Target.bitsPerProcess,

portTC: Target.bitsPerPort,

signalTC: Target.bitsPerSignal,

errorTC: Target.bitsPerSignal,

programTC: Target.bitsPerProgram];

bits: NAT = modeLength[name];

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.transfer.SIZE];

seb[sei].align ¬ MimData.bitsToAlignment[bits];

seb[sei].typeInfo ¬ transfer[

mode: modeMap[name],

safe: tb[node].attr3,

typeIn: ArgList[tb[node].son[1]],

typeOut: ArgList[tb[node].son[2]],

length: bits];

};

anyTC => sei ¬ TypeAny[];

definitionTC => {

bits: NAT ¬ Target.bitsPerRef;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.definition.SIZE];

seb[sei].align ¬ MimData.bitsToAlignment[bits];

seb[sei].typeInfo ¬ definition[slots: 0, named: FALSE, defCtx: CTXNull];

};

unionTC => sei ¬ Union[node, linkId];

sequenceTC => sei ¬ Sequence[node];

relativeTC => {

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.relative.SIZE];

seb[sei].typeInfo ¬ relative[
baseType: nullType,
offsetType: nullType,
resultType: nullType];

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

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

};

subrangeTC => {

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.subrange.SIZE];

seb[sei].typeInfo ¬ subrange[

filled: FALSE,

empty: FALSE,

rangeType: nullType,

biased: TRUE,

origin: 0, range: 0];

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

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

};

optionTC => {

saveOptions: TypeOptions ¬ globalOptions;

SELECT tb[node].subInfo FROM

Tree.packedOption => globalOptions.packed ¬ TRUE;

Tree.msbitOption => globalOptions.orderOption ¬ msBit;

Tree.lsbitOption => globalOptions.orderOption ¬ lsBit;

Tree.nativeOption => globalOptions.orderOption ¬
IF Target.bitOrder = msBit THEN msBit ELSE lsBit;

Tree.word8Option => globalOptions.grain ¬ 8;

Tree.word16Option => globalOptions.grain ¬ 16;

Tree.word32Option => globalOptions.grain ¬ 32;

Tree.word64Option => globalOptions.grain ¬ 64;

ENDCASE => ERROR;

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

globalOptions ¬ saveOptions;

};

longTC, dot, discrimTC =>

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

opaqueTC => {

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.opaque.SIZE];

seb[sei].typeInfo ¬ opaque[

lengthKnown: tb[node].son[1] # Tree.Null,

length: 0,

id: WITH seb[typeId] SELECT FROM

id => LOOPHOLE[typeId],

ENDCASE => ISENull];

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

};

zoneTC => {

isMds: BOOL ¬ tb[node].attr2;

bits: NAT ¬ IF isMds THEN Target.bitsPerWord ELSE Target.bitsPerRef;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.zone.SIZE];

seb[sei].align ¬ MimData.bitsToAlignment[bits];

seb[sei].typeInfo ¬ zone[counted: ~tb[node].attr1, mds: isMds,
length: IF isMds THEN Target.bitsPerWord ELSE Target.bitsPerRef];

};

paintTC => {

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

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

};

implicitTC, linkTC, frameTC => sei ¬ CSENull;

apply => {

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

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

};

ENDCASE => MimosaLog.Error[nonTypeCons];

tb[node].info ¬ SymbolOps.FromType[sei];

};

ENDCASE;

};

OptTypeExp: PROC [t: Tree.Link] = {IF t # Tree.Null THEN TypeExp[t]};

Enumeration: PROC [node: Tree.Index] RETURNS [ctx: CTXIndex] = {

saved: ContextInfo = current;

NewContext[lZ, ListLength[tb[node].son[1]], TRUE]; ctx ¬ current.ctx;

tb[node].son[1] ¬ Ids[

list: tb[node].son[1],

public: tb[node].attr1,

link: Tree.nullIndex];

current ¬ saved;

};

AssignValues: PROC [type: CSEIndex, valueType: Type] = {

WITH t: seb[type] SELECT FROM

enumerated => {

i: CARD ¬ 0;

FOR sei: ISEIndex ¬ SymbolOps.FirstCtxSe[MimData.ownSymbols, t.valueCtx], SymbolOps.NextSe[MimData.ownSymbols, sei]
UNTIL sei = ISENull DO

seb[sei].idType ¬ valueType;

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

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

i ¬ i+1;

seb[sei].immutable ¬ seb[sei].constant ¬ TRUE;

seb[sei].mark3 ¬ seb[sei].mark4 ¬ TRUE;

ENDLOOP;

t.empty ¬ (i=0);

t.range ¬ (IF i=0 THEN 0 ELSE i-1);

};

ENDCASE => ERROR;

};

FieldList: PROC [t: Tree.Link, level: ContextLevel, typeId: Type]
RETURNS [ctx: CTXIndex, nFields: NAT] = {

saved: ContextInfo = current;

nFields ¬ CountIds[t];

NewContext[level, nFields, TRUE];

ctx ¬ current.ctx;

DeclList[t, typeId];

current ¬ saved;

};

ArgList: PROC [t: Tree.Link] RETURNS [sei: CSEIndex] = {

SELECT TRUE FROM

t = Tree.Null => sei ¬ RecordSENull;

OpName[t] = anyTC => sei ¬ TypeAny[];

ENDCASE => {

tCtx: CTXIndex;

nFields: NAT;

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE];

[tCtx, nFields] ¬ FieldList[t, lZ, sei];

seb[sei].align ¬ MimData.worstAlignment;

seb[sei].typeInfo ¬ record[

argument: TRUE,

monitored: FALSE, machineDep: FALSE, painted: FALSE,

spare: FALSE, packed: FALSE, list: FALSE,

bitOrder: targetBitOrder,

grain: Target.bitsPerAU,

hints: [

unifield: nFields = 1,

variant: FALSE,

assignable: TRUE, comparable: FALSE, privateFields: FALSE,

refField: FALSE, default: FALSE, voidable: TRUE],

length: 0,

fieldCtx: tCtx,

linkPart: notLinked[]];

};

anySei: CSEIndex;

TypeAny: PROC RETURNS [CSEIndex] = {

IF anySei = CSENull THEN {

anySei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.any.SIZE];

seb[anySei] ¬ [mark3: TRUE, mark4: TRUE, body: cons[align: unknown, typeInfo: any[]]];

};

RETURN [anySei];

};

TagField: PROC [t: Tree.Link, MakeTagType: PROC RETURNS [CSEIndex]]
RETURNS [tagId: ISEIndex] = {

saved: ContextInfo = current;

node: Tree.Index;

current.ctx ¬ CTXNull;

current.seChain ¬ SymbolOps.MakeSeChain[CTXNull, 1, FALSE];

DeclList[t];

node ¬ GetNode[t];

tagId ¬ FirstId[tb[node].son[1]];

IF OpName[tb[node].son[2]] = implicitTC THEN {

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

tagType: Type;

IF MakeTagType # NIL

THEN tagType ¬ MakeTagType[]

ELSE {MimosaLog.Error[attrClash]; tagType ¬ typeANY};

tb[subNode].info ¬ SymbolOps.FromType[tagType];

};

current ¬ saved;

};

Union: PROC [node: Tree.Index, linkId: Type] RETURNS [sei: CSEIndex] = {

saved: ContextInfo = current;

MakeTagType: PROC RETURNS [type: CSEIndex] = {

saved: ContextInfo = current;

CollectTags: Tree.Scan = {

node: Tree.Index = GetNode[t];

tb[node].son[1] ¬ Ids[

list: tb[node].son[1],

public: tb[node].attr2,

link: Tree.nullIndex

! SymbolOps.NameClash => {RESUME}]

};

NewContext[lZ, CountIds[tb[node].son[2]], TRUE];

type ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.enumerated.SIZE];

seb[type].typeInfo ¬ enumerated[

ordered: FALSE, sparse: FALSE,

machineDep: FALSE,

painted: enumPainted OR MimData.interface,

valueCtx: current.ctx, empty: FALSE, range: 0];

ScanList[tb[node].son[2], CollectTags];

AssignValues[type, type];

current ¬ saved;

};

tagId: ISEIndex = TagField[tb[node].son[1], MakeTagType];

NewContext[lZ, CountIds[tb[node].son[2]], TRUE];

DeclList[tb[node].son[2], linkId

! SymbolOps.NameClash => {MimosaLog.ErrorHti[duplicateTag, name]; RESUME}];

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.union.SIZE];

seb[sei].typeInfo ¬ union[

caseCtx: current.ctx,

machineDep: tb[node].attr1,

overlaid: tb[node].attr2,

controlled: seb[tagId].hash # nullName,

tagSei: tagId,

hints: [equalLengths: FALSE, refField: FALSE, default: FALSE, voidable: TRUE],

bitOrder: globalOptions.orderOption,

grain: globalOptions.grain

];

current ¬ saved;

};

Sequence: PROC [node: Tree.Index] RETURNS [sei: CSEIndex] = {

tagId: ISEIndex = TagField[tb[node].son[1], NIL];

IF tb[node].attr2 THEN MimosaLog.Error[attrClash];

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

sei ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.sequence.SIZE];

seb[sei].typeInfo ¬ sequence[

parentType: parentRecordType,

packed: globalOptions.packed,

controlled: seb[tagId].hash # nullName,

machineDep: tb[node].attr1,

tagSei: tagId,

componentType: nullType,

bitOrder: globalOptions.orderOption,

grain: globalOptions.grain

];

};

statements

Stmt: PROC [stmt: Tree.Link] = {

IF stmt # Tree.Null THEN {

saveIndex: SourceMap.Loc = MimData.textIndex;

WITH stmt SELECT GetTag[stmt] FROM

subtree => {

node: Tree.Index ¬ index;

SELECT name FROM

list, block => {};

ENDCASE =>

MarkSource[MimData.textIndex ¬ ToLoc[tb[node].info], $Stmt];

SELECT tb[node].name FROM

assign => {

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

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

};

extract => {

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

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

};

apply => {

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

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

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

};

block => {

saved: ContextInfo = current;

bti: BTIndex = NewScope[node, tb[node].son[1]];

tb[node].info ¬ SymbolOps.FromBti[bti];

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

BodyList[bb[bti].firstSon];

current ¬ saved;

btLink ¬ [which: sibling, index: bti];

};

if => {

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

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

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

};

case => {

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

SelectionList[tb[node].son[2], Stmt];

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

};

bind => {

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

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

SelectionList[tb[node].son[3], Stmt];

Stmt[tb[node].son[4]];

};

do =>

DoStmt[node];

return, resume =>

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

label => {

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

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

};

goto, exit, loop, reject, continue, retry, syserror, stop, null => NULL;

free => {

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

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

IF tb[node].nSons > 3 THEN CatchPhrase[tb[node].son[4]];

};

signal, error, xerror, start, restart, join, wait, notify, broadcast, dst, lst, lste, lstf =>

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

open => {

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

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

};

enable => {

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

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

};

checked =>

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

list =>

ScanList[stmt, Stmt];

item =>

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

ENDCASE =>

MimosaLog.Error[unimplemented];

};

ENDCASE;

MimData.textIndex ¬ saveIndex;

};

StmtList: PROC [list: Tree.Link] = Stmt;

SelectionList: PROC [t: Tree.Link, selection: Tree.Scan] = {

Item: Tree.Scan = {

node: Tree.Index = GetNode[t];

saveIndex: SourceMap.Loc = MimData.textIndex;

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

IF OpName[tb[node].son[1]] # decl

THEN {

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

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

}

ELSE {

saved: ContextInfo = current;

bti: BTIndex = NewScope[node, tb[node].son[1]];

tb[node].name ¬ ditem;

tb[node].info ¬ SymbolOps.FromBti[bti];

tb[node].attr3 ¬ FALSE;

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

current ¬ saved;

btLink ¬ [which:sibling, index:bti];

};

MimData.textIndex ¬ saveIndex;

};

ScanList[t, Item];

};

DoStmt: PROC [node: Tree.Index] = {

saved: ContextInfo = current;

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

bti: BTIndex ¬ BTNull;

IF forTree # Tree.Null THEN {

subTree: Tree.Link = NthSon[forTree, 1];

IF OpName[subTree] # decl

THEN Exp[subTree]

ELSE bti ¬ NewScope[node, subTree];

PutInfo[forTree, SymbolOps.FromBti[bti]];

SELECT OpName[forTree] FROM

forseq => {

Exp[NthSon[forTree, 2]];

Exp[NthSon[forTree, 3]];

};

upthru, downthru =>

Range[NthSon[forTree, 2]];

ENDCASE => ERROR;

};

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

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

StmtList[tb[node].son[4]];

StmtList[tb[node].son[5]];

StmtList[tb[node].son[6]];

current ¬ saved;

IF bti # BTNull THEN btLink ¬ [which: sibling, index: bti];

};

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

node: Tree.Index = GetNode[t];

saved: ContextInfo = current;

NewContext[

level: SymbolOps.NextLevel[saved.staticLevel],

entries: 0,

unique: FALSE];

SelectionList[tb[node].son[1], Stmt];

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

current ¬ saved;

};

expressions

Exp: PROC [exp: Tree.Link] = {

IF exp # Tree.Null THEN

WITH exp SELECT GetTag[exp] FROM

subtree => {

node: Tree.Index = index;

SELECT tb[node].name FROM

apply => {

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

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

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

};

signalx, errorx, startx, fork, joinx, dot, uparrow, uminus, not, addr, create, cast =>

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

plus, minus, times, div, power, mod, relE, relN, relL, relGE, relG, relLE, intOO, intOC, intCO, intCC, or, and, assignx => {

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

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

};

in, notin => {

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

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

};

ifx => {

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

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

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

};

casex => {

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

SelectionList[tb[node].son[2], Exp];

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

};

bindx => {

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

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

SelectionList[tb[node].son[3], Exp];

Exp[tb[node].son[4]];

};

extractx => {

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

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

};

pred, succ, ord, lengthen, float, abs, min, max, base, length, all, val =>

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

arraydesc => {

SELECT ListLength[tb[node].son[1]] FROM

1 => Exp[tb[node].son[1]];

3 => {

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

Exp[tb[subNode].son[1]]; Exp[tb[subNode].son[2]];

OptTypeExp[tb[subNode].son[3]];

};

ENDCASE => ERROR;

};

void, clit, llit, atom, mwconst, syserrorx => NULL;

loophole => {

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

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

};

narrow, istype => {

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

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

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

};

new => {

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

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

tb[node].son[3] ¬ InitialValue[tb[node].son[3], ISENull];

IF tb[node].nSons > 3 THEN CatchPhrase[tb[node].son[4]];

};

cons, listcons => {

Exp[tb[node].son[1]]; ExpList[tb[node].son[2]];

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

};

first, last, typecode =>

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

size => {

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

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

};

nil =>

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

item =>

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

ENDCASE =>

MimosaLog.Error[unimplemented];

};

ENDCASE;

};

ExpList: PROC [list: Tree.Link] = INLINE {ScanList[list, Exp]};

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

IF OpName[t] = item

THEN {

node: Tree.Index = GetNode[t];

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

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

}

ELSE Exp[t];

};

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

WITH s: t SELECT GetTag[t] FROM

subtree => {

node: Tree.Index = s.index;

SELECT tb[node].name FROM

subrangeTC => {TypeExp[tb[node].son[1]]; Exp[tb[node].son[2]]};

IN [intOO .. intCC] => Exp[t];

ENDCASE => TypeExp[t];

};

ENDCASE => TypeExp[t];

};

MarkSource: PROC [loc: SourceMap.Loc, mark: ATOM] = {

IF MimData.nErrors = 0 AND loc # SourceMap.nullLoc THEN {

pos: INT ¬ SourceMap.Down[loc];

SourceMarks.MarkSource[pos, mark, FALSE];

};

Russ Atkinson (RRA) July 31, 1987 6:40:26 pm PDT

Changed to use optionTC instead of packedTC for packed, bitOrder, & grain options.

Russ Atkinson (RRA) August 4, 1987 4:48:22 pm PDT

changed Ids to check for malformed id lists and complain appropriately

Russ Atkinson (RRA) October 29, 1987 1:13:18 pm PST

Made FirstId more careful (graceful when the tree is null), DeclItem (local of DeclList), Pass2, AllocateBody, LinkBody, Body, Id (local of Ids)