-- file Pass2.mesa
-- last modified by Satterthwaite, May 10, 1983 3:50 pm
-- last modified by Donahue, 9-Dec-81 12:03:59
DIRECTORY
Alloc: TYPE USING [Notifier, AddNotify, Bounds, DropNotify, Words],
ComData: TYPE USING [
bodyIndex, catchIndex, defBodyLimit, idLOCK, importCtx, interface, mainCtx,
moduleCtx, monitored, nBodies, nInnerBodies, nSigCodes, table, textIndex],
CompilerUtil: TYPE USING [],
Log: TYPE USING [Error, ErrorHti],
Symbols: TYPE USING [
Base, BodyLink, BodyRecord, ContextLevel, SERecord, TransferMode,
Name, Type, CSEIndex, ISEIndex, RecordSEIndex,
CTXIndex, BTIndex, CBTIndex, CCBTIndex,
nullName, nullType, CSENull, ISENull, RecordSENull,
CTXNull, BTNull, CBTNull,
lG, lL, lZ, RootBti, typeANY, typeTYPE, seType, ctxType, bodyType],
SymbolOps: TYPE USING [
BlockLevel, FillCtxSe, FirstCtxSe, NewCtx, MakeNonCtxSe, MakeSeChain,
NameClash, NextLevel, NextSe, SetMainCtx, StaticNestError],
Tree: TYPE USING [
Base, Index, Link, Map, NodeName, Null, NullIndex, Scan, treeType],
TreeOps: TYPE USING [
FreeNode, GetInfo, GetNode, ListHead, ListLength, NthSon, OpName, PutInfo,
ScanList, UpdateList];
Pass2: PROGRAM
IMPORTS
Alloc, Log, SymbolOps, TreeOps,
dataPtr: ComData
EXPORTS CompilerUtil = {
OPEN TreeOps, SymbolOps, Symbols;
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]};
ContextInfo: TYPE = RECORD [
ctx: CTXIndex,
staticLevel: ContextLevel,
seChain: ISEIndex];
current: ContextInfo;
NewContext: PROC [level: ContextLevel, entries: NAT, unique: BOOL] = {
OPEN c: current;
c.staticLevel ← level;
IF entries = 0 AND ~unique THEN {c.ctx ← CTXNull; c.seChain ← ISENull}
ELSE {
c.ctx ← NewCtx[level];
ctxb[c.ctx].seList ← c.seChain ← MakeSeChain[c.ctx, entries, level=lG]}};
-- main driver
P2Unit: PUBLIC PROC [t: Tree.Link] RETURNS [Tree.Link] = {
node: Tree.Index;
(dataPtr.table).AddNotify[Notify]; anySei ← CSENull;
node ← GetNode[t];
BEGIN
ENABLE { -- default error reporting
NameClash => {Log.ErrorHti[duplicateId, name]; RESUME};
StaticNestError => {Log.Error[staticNesting]; RESUME}};
dataPtr.textIndex ← tb[node].info;
dataPtr.bodyIndex ← CBTNull;
dataPtr.nBodies ← dataPtr.nInnerBodies ← dataPtr.nSigCodes ← 0;
dataPtr.catchIndex ← 0;
btLink ← [which:parent, index:BTNull]; catchParent ← ISENull;
NewContext[
level: lZ,
entries: ListLength[tb[node].son[1]] + CountIds[tb[node].son[6]],
unique: FALSE];
dataPtr.moduleCtx ← current.ctx;
ScanList[tb[node].son[1], IdItem];
ImportList[tb[node].son[2]];
-- process LOCKS clause
dataPtr.monitored ← tb[node].son[5] # Tree.Null;
lockLambda ← Lambda[tb[node].son[5], lL];
MainBody[tb[node].son[6]];
dataPtr.defBodyLimit ← (dataPtr.table).Bounds[bodyType].size;
END;
(dataPtr.table).DropNotify[Notify];
RETURN [t]};
ImportList: PROC [t: Tree.Link] = {
saved: ContextInfo = current;
NewContext[lG, ListLength[t], FALSE];
dataPtr.importCtx ← current.ctx;
ScanList[t, IdItem];
current ← saved};
MainBody: PROC [t: Tree.Link] = INLINE {
dataPtr.interface ← (OpName[NthSon[t, 2]] = definitionTC);
DeclList[t];
BodyList[RootBti]};
-- 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 ← current.ctx;
DeclList[tb[node].son[1]]; Exp[tb[node].son[2]];
current ← saved};
RETURN};
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 ← dataPtr.idLOCK; seb[sei].idInfo ← 1; seb[sei].mark3 ← TRUE};
-- body processing
btLink: BodyLink;
catchParent: ISEIndex;
AllocateBody: PROC [node: Tree.Index, id: ISEIndex] RETURNS [bti: CBTIndex] = {
-- queue body for later processing
-- force nesting message here
SELECT NextLevel[current.staticLevel] FROM
lG, lL => {
bti ← (dataPtr.table).Words[bodyType, BodyRecord.Callable.Outer.SIZE];
bb[bti] ← [,,,,,,, Callable[,,,,,,,,,,Outer[]]]};
ENDCASE => {
bti ← (dataPtr.table).Words[bodyType, BodyRecord.Callable.Inner.SIZE];
bb[bti] ← [,,,,,,, Callable[,,,,,,,,,, Inner[frameOffset: ]]]};
bb[bti].firstSon ← BTNull;
bb[bti].sourceIndex ← dataPtr.textIndex;
bb[bti].info ← [Internal[bodyTree:node, thread:Tree.NullIndex, frameSize: ]];
bb[bti].id ← id;
bb[bti].entry ← bb[bti].internal ← FALSE;
-- conservative initial approximations
bb[bti].ioType ← typeANY;
bb[bti].noXfers ← FALSE;
bb[bti].hints ← [safe:FALSE, argUpdated:TRUE, nameSafe:FALSE, noStrings:FALSE];
LinkBody[bti]; RETURN};
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 ~dataPtr.monitored THEN Log.Error[misplacedEntry]
ELSE { -- see AllocateBody
bti: CBTIndex = GetInfo[t];
SELECT attr FROM
entry => bb[bti].entry ← TRUE;
internal => bb[bti].internal ← TRUE;
ENDCASE}};
BodyList: PROC [firstBti: BTIndex] = {
FOR bti: BTIndex ← firstBti, bb[bti].link.index UNTIL bti = BTNull DO
WITH bb[bti] SELECT FROM
Callable => IF nesting # Catch THEN Body[LOOPHOLE[bti, CBTIndex]];
ENDCASE => NULL;
IF bb[bti].link.which = parent THEN EXIT;
ENDLOOP};
Body: PROC [bti: CBTIndex] = {
node: Tree.Index = WITH bb[bti].info SELECT FROM
Internal => bodyTree,
ENDCASE => ERROR;
level: ContextLevel;
nLocks: [0..1];
oldBodyIndex: CBTIndex = dataPtr.bodyIndex;
oldBtLink: BodyLink = btLink;
oldCatchParent: ISEIndex = catchParent;
saved: ContextInfo = current;
dataPtr.bodyIndex ← bti;
btLink ← [which:parent, index:bti]; catchParent ← bb[bti].id;
level ← NextLevel[saved.staticLevel ! StaticNestError => {RESUME}];
nLocks ← IF level = lG AND dataPtr.monitored AND tb[lockLambda].attr1
THEN 1
ELSE 0;
NewContext[
level: level,
entries: nLocks + CountIds[tb[node].son[2]],
unique: level = lG];
bb[bti].localCtx ← current.ctx; bb[bti].level ← BlockLevel[level];
bb[bti].monitored ← nLocks # 0; bb[bti].inline ← tb[node].attr3;
bb[bti].type ← IF current.ctx = CTXNull OR bb[bti].inline
THEN RecordSENull
ELSE BodyType[current.ctx, bb[bti].monitored];
IF level = lG THEN {
IF bti # RootBti THEN ERROR;
dataPtr.mainCtx ← current.ctx; SetMainCtx[current.ctx]};
ExpList[tb[node].son[1]];
IF nLocks # 0 THEN ImplicitLock[];
DeclList[tb[node].son[2]];
StmtList[tb[node].son[3]];
BodyList[bb[bti].firstSon];
current ← saved; dataPtr.bodyIndex ← oldBodyIndex;
catchParent ← oldCatchParent; btLink ← oldBtLink};
NewScope: PROC [node: Tree.Index, decls: Tree.Link] RETURNS [bti: BTIndex] = {
level: ContextLevel = BlockLevel[current.staticLevel];
NewContext[level:level, entries:CountIds[decls], unique:FALSE];
bti ← (dataPtr.table).Words[bodyType, BodyRecord.Other.SIZE];
bb[bti] ← [
link: ,
firstSon: BTNull,
type: IF bb[dataPtr.bodyIndex].inline
THEN RecordSENull ELSE BodyType[current.ctx, FALSE],
localCtx: current.ctx, level: level,
sourceIndex: tb[node].info,
info: [Internal[bodyTree:node, thread:Tree.NullIndex, frameSize: ]],
extension: Other[relOffset: ]];
LinkBody[bti]; btLink ← [which:parent, index:bti];
DeclList[decls]};
NewCatchScope: PROC [node: Tree.Index] RETURNS [bti: CCBTIndex] = {
-- force nesting message here
level: ContextLevel;
level ← NextLevel[current.staticLevel ! StaticNestError => {RESUME}];
NewContext[level:level, entries:0, unique:FALSE];
bti ← (dataPtr.table).Words[bodyType, BodyRecord.Callable.Catch.SIZE];
bb[bti] ← [
link: ,
firstSon: BTNull,
type: RecordSENull,
localCtx: CTXNull, level: level,
sourceIndex: tb[node].info,
info: [Internal[bodyTree:node, thread:Tree.NullIndex, frameSize: ]],
extension: Callable[
inline: FALSE,
id: catchParent,
ioType: CSENull,
monitored: FALSE, noXfers: FALSE, resident: FALSE,
entry: FALSE, internal: FALSE,
entryIndex: 0,
hints: [FALSE, FALSE, FALSE, FALSE],
closure: Catch[index: ]]];
LinkBody[bti]; btLink ← [which:parent, index:bti];
RETURN};
BodyType: PROC [ctx: CTXIndex, monitored: BOOL] RETURNS [rSei: RecordSEIndex] = {
rSei ← LOOPHOLE[MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE]];
seb[rSei].typeInfo ← record[
machineDep: FALSE, painted: TRUE, argument: 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[]];
RETURN};
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: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← tb[node].info;
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 => Log.Error[unimplemented];
dataPtr.textIndex ← saveIndex};
ScanList[t, DeclItem]};
CountIds: PROC [declList: Tree.Link] RETURNS [n: NAT𡤀] = {
NIds: Tree.Scan = {n ← n + ListLength[NthSon[t, 1]]};
ScanList[declList, NIds]; RETURN};
InitialValue: PROC [t: Tree.Link, id: ISEIndex] RETURNS [v: Tree.Link] = {
v ← t; -- the default
IF t # Tree.Null THEN
WITH t SELECT FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
body => {
bti: CBTIndex = AllocateBody[node, id];
tb[node].info ← bti;
IF ~tb[node].attr3 THEN {
dataPtr.nBodies ← dataPtr.nBodies+1;
IF current.staticLevel >= lL THEN
dataPtr.nInnerBodies ← dataPtr.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 ← dataPtr.nSigCodes;
dataPtr.nSigCodes ← dataPtr.nSigCodes+1};
inline => CodeBody[node];
ENDCASE => ExpList[t]};
ENDCASE => ExpList[t]};
IdItem: Tree.Scan = {
node: Tree.Index = GetNode[t];
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← tb[node].info;
tb[node].son[1] ← Ids[list: tb[node].son[1], public: FALSE, link: node];
dataPtr.textIndex ← saveIndex};
-- id list manipulation
Ids: PROC [
list: Tree.Link,
public: BOOL,
type: BOOL ← FALSE,
link: Tree.Index]
RETURNS [Tree.Link] = {
Id: Tree.Map = {
WITH t SELECT FROM
hash, symbol => {
name: Name = (WITH t SELECT FROM
hash => index,
symbol => seb[index].hash,
ENDCASE => ERROR);
sei: ISEIndex = current.seChain;
current.seChain ← NextSe[current.seChain];
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 ← link; seb[sei].idInfo ← 0;
seb[sei].extended ← seb[sei].linkSpace ← FALSE;
v ← [symbol[index: sei]]};
subtree => {
node: Tree.Index = index;
tb[node].son[1] ← Id[tb[node].son[1]]; Position[tb[node].son[2]];
v ← t};
ENDCASE => ERROR;
RETURN};
RETURN [UpdateList[list, Id]]};
FirstId: PROC [t: Tree.Link] RETURNS [ISEIndex] = {
head: Tree.Link = ListHead[t];
RETURN [WITH head SELECT FROM
symbol => index,
subtree => FirstId[tb[index].son[1]],
ENDCASE => ERROR]};
-- type manipulation
TypeExp: PROC [t: Tree.Link, typeId, linkId: Type←nullType] = {
sei: CSEIndex;
WITH t SELECT FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
enumeratedTC => {
sei ← MakeNonCtxSe[SERecord.cons.enumerated.SIZE];
seb[sei].typeInfo ← enumerated[
ordered: TRUE, sparse: FALSE,
machineDep: tb[node].attr2,
unpainted: ~(tb[node].attr2 OR dataPtr.interface),
valueCtx: Enumeration[node], empty: , nValues: ];
AssignValues[sei, IF typeId # nullType THEN typeId ELSE sei]};
recordTC, monitoredTC => {
tCtx: CTXIndex;
nFields: NAT;
sei ← MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE];
[tCtx, nFields] ← FieldList[
t: tb[node].son[1],
level: lZ,
typeId: IF typeId # nullType THEN typeId ELSE sei];
seb[sei].typeInfo ← record[
machineDep: tb[node].attr1,
painted: tb[node].attr1 OR (dataPtr.interface AND tb[node].attr3),
argument: FALSE,
hints: [
unifield: nFields = 1 AND ~tb[node].attr2,
variant: tb[node].attr2,
assignable: TRUE, comparable: FALSE, privateFields: FALSE,
refField: FALSE, default: FALSE, voidable: TRUE],
length: ,
fieldCtx: tCtx,
monitored: tb[node].name = monitoredTC,
linkPart: notLinked[]];
IF tb[node].name = monitoredTC AND tb[node].attr1 THEN Log.Error[attrClash]};
variantTC => {
sei ← MakeNonCtxSe[SERecord.cons.record.linked.SIZE];
seb[sei].typeInfo ← record[
machineDep: tb[node].attr1,
painted: tb[node].attr3,
argument: FALSE,
hints: [
unifield: FALSE,
variant: tb[node].attr2,
assignable: TRUE, comparable: FALSE, privateFields: FALSE,
refField: FALSE, default: FALSE, voidable: TRUE],
length: ,
fieldCtx: FieldList[t:tb[node].son[1], level:lZ, typeId:typeId].ctx,
monitored: FALSE,
linkPart: linked[linkId]]};
refTC, listTC, pointerTC, varTC => {
sei ← MakeNonCtxSe[SERecord.cons.ref.SIZE];
seb[sei].typeInfo ← ref[
counted: tb[node].name = refTC OR tb[node].name = listTC,
var: tb[node].name = varTC,
ordered: tb[node].attr1,
basing: tb[node].attr2,
list: tb[node].name = listTC,
readOnly: tb[node].attr3,
refType: ];
TypeExp[tb[node].son[1]]};
arrayTC => {
sei ← MakeNonCtxSe[SERecord.cons.array.SIZE];
seb[sei].typeInfo ← array[
packed: tb[node].attr3,
indexType: ,
componentType: ];
OptTypeExp[tb[node].son[1]]; TypeExp[tb[node].son[2]]};
arraydescTC => {
sei ← MakeNonCtxSe[SERecord.cons.arraydesc.SIZE];
seb[sei].typeInfo ← arraydesc[
readOnly: tb[node].attr3, var: FALSE, describedType: ];
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];
sei ← MakeNonCtxSe[SERecord.cons.transfer.SIZE];
seb[sei].typeInfo ← transfer[
mode: modeMap[tb[node].name], safe: tb[node].attr3,
typeIn: ArgList[tb[node].son[1]],
typeOut: ArgList[tb[node].son[2]]]};
anyTC => sei ← TypeAny[];
definitionTC => {
sei ← MakeNonCtxSe[SERecord.cons.definition.SIZE];
seb[sei].typeInfo ← definition[nGfi: 1, named: FALSE, defCtx: ]};
unionTC => sei ← Union[node, linkId];
sequenceTC => sei ← Sequence[node];
relativeTC => {
sei ← MakeNonCtxSe[SERecord.cons.relative.SIZE];
seb[sei].typeInfo ← relative[baseType: , offsetType: , resultType: ];
TypeExp[tb[node].son[1]]; TypeExp[tb[node].son[2]]};
subrangeTC => {
sei ← MakeNonCtxSe[SERecord.cons.subrange.SIZE];
seb[sei].typeInfo ← subrange[
filled: FALSE, empty: FALSE,
rangeType: ,
origin: , range: ];
TypeExp[tb[node].son[1]]; Exp[tb[node].son[2]]};
longTC => {
sei ← MakeNonCtxSe[SERecord.cons.long.SIZE];
seb[sei].typeInfo ← long[rangeType: ];
TypeExp[tb[node].son[1]]};
opaqueTC => {
sei ← 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 => {
sei ← MakeNonCtxSe[SERecord.cons.zone.SIZE];
seb[sei].typeInfo ← zone[counted: ~tb[node].attr1, mds: tb[node].attr2]};
paintTC => {
sei ← CSENull;
TypeExp[tb[node].son[1]]; TypeExp[tb[node].son[2]]};
implicitTC, linkTC, frameTC => sei ← CSENull;
dot, discrimTC => {TypeExp[tb[node].son[1]]; sei ← CSENull};
apply => {TypeExp[tb[node].son[1]]; Exp[tb[node].son[2]]; sei ← CSENull};
ENDCASE => {sei ← CSENull; Log.Error[nonTypeCons]};
tb[node].info ← sei};
ENDCASE => NULL};
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; RETURN};
AssignValues: PROC [type: CSEIndex, valueType: Type] = {
WITH t: seb[type] SELECT FROM
enumerated => {
i: CARDINAL ← 0;
FOR sei: ISEIndex ← FirstCtxSe[t.valueCtx], NextSe[sei] UNTIL sei = ISENull DO
seb[sei].idType ← valueType; seb[sei].idInfo ← 0;
seb[sei].idValue ← i; i ← i+1;
seb[sei].immutable ← seb[sei].constant ← TRUE;
seb[sei].mark3 ← seb[sei].mark4 ← TRUE;
ENDLOOP;
t.empty ← (i=0); t.nValues ← i};
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; RETURN};
ArgList: PROC [t: Tree.Link] RETURNS [sei: CSEIndex] = {
IF t = Tree.Null THEN sei ← RecordSENull
ELSE IF OpName[t] = anyTC THEN sei ← TypeAny[]
ELSE {
tCtx: CTXIndex;
nFields: NAT;
sei ← MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE];
[tCtx, nFields] ← FieldList[t, lZ, sei];
seb[sei].typeInfo ← record[
machineDep: FALSE,
painted: FALSE,
argument: TRUE,
hints: [
unifield: nFields = 1,
variant: FALSE,
assignable: TRUE, comparable: FALSE, privateFields: FALSE,
refField: FALSE, default: FALSE, voidable: TRUE],
length: ,
fieldCtx: tCtx,
monitored: FALSE,
linkPart: notLinked[]]};
RETURN};
anySei: CSEIndex;
TypeAny: PROC RETURNS [CSEIndex] = {
IF anySei = CSENull THEN {
anySei ← MakeNonCtxSe[SERecord.cons.any.SIZE];
seb[anySei] ← [mark3: TRUE, mark4: TRUE, body: cons[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 ← 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]];
IF MakeTagType # NIL THEN tb[subNode].info ← MakeTagType[]
ELSE {Log.Error[attrClash]; tb[subNode].info ← typeANY}};
current ← saved; RETURN};
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
! NameClash => {RESUME}]};
NewContext[lZ, CountIds[tb[node].son[2]], TRUE];
type ← MakeNonCtxSe[SERecord.cons.enumerated.SIZE];
seb[type].typeInfo ← enumerated[
ordered: FALSE, sparse: FALSE,
machineDep: FALSE,
unpainted: ~dataPtr.interface,
valueCtx: current.ctx, empty: , nValues: ];
ScanList[tb[node].son[2], CollectTags];
AssignValues[type, type];
current ← saved; RETURN};
tagId: ISEIndex = TagField[tb[node].son[1], MakeTagType];
NewContext[lZ, CountIds[tb[node].son[2]], TRUE];
DeclList[tb[node].son[2], linkId
! NameClash => {Log.ErrorHti[duplicateTag, name]; RESUME}];
sei ← 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]];
current ← saved; RETURN};
Sequence: PROC [node: Tree.Index] RETURNS [sei: CSEIndex] = {
tagId: ISEIndex = TagField[tb[node].son[1], NIL];
IF tb[node].attr2 THEN Log.Error[attrClash];
TypeExp[tb[node].son[2]];
sei ← MakeNonCtxSe[SERecord.cons.sequence.SIZE];
seb[sei].typeInfo ← sequence[
packed: tb[node].attr3,
controlled: seb[tagId].hash # nullName,
machineDep: tb[node].attr1,
tagSei: tagId,
componentType: ];
RETURN};
-- statements
Stmt: PROC [stmt: Tree.Link] = {
node: Tree.Index;
saveIndex: CARDINAL = dataPtr.textIndex;
IF stmt = Tree.Null THEN RETURN;
WITH stmt SELECT FROM
subtree => {
node ← index;
dataPtr.textIndex ← tb[node].info;
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 => Block[node];
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 => Log.Error[unimplemented]};
ENDCASE => NULL;
dataPtr.textIndex ← saveIndex};
StmtList: PROC [list: Tree.Link] = Stmt;
Block: PROC [node: Tree.Index] = {
saved: ContextInfo = current;
bti: BTIndex = NewScope[node, tb[node].son[1]];
tb[node].info ← bti;
StmtList[tb[node].son[2]];
BodyList[bb[bti].firstSon];
current ← saved; btLink ← [which:sibling, index:bti]};
SelectionList: PROC [t: Tree.Link, selection: Tree.Scan] = {
Item: Tree.Scan = {
node: Tree.Index = GetNode[t];
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← 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 ← bti; tb[node].attr3 ← FALSE;
selection[tb[node].son[2]];
current ← saved; btLink ← [which:sibling, index:bti]};
dataPtr.textIndex ← saveIndex};
ScanList[t, Item]};
DoStmt: PROC [node: Tree.Index] = {
OPEN tb[node];
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, 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];
oldBodyIndex: CBTIndex = dataPtr.bodyIndex;
saveIndex: CARDINAL = dataPtr.textIndex;
saved: ContextInfo = current;
bti: CCBTIndex;
dataPtr.textIndex ← tb[node].info;
dataPtr.bodyIndex ← bti ← NewCatchScope[node];
tb[node].info ← bti;
SelectionList[tb[node].son[1], Stmt]; Stmt[tb[node].son[2]];
BodyList[bb[bti].firstSon];
dataPtr.textIndex ← saveIndex;
current ← saved;
dataPtr.bodyIndex ← oldBodyIndex;
btLink ← [which:sibling, index:bti]};
-- expressions
Exp: PROC [exp: Tree.Link] = {
IF exp = Tree.Null THEN RETURN;
WITH exp SELECT 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, 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 => Log.Error[unimplemented]};
ENDCASE => NULL};
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] = {
node: Tree.Index;
WITH t SELECT FROM
subtree => {
node ← 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]};
}.