-- file Pass2.Mesa
-- last modified by Satterthwaite, November 2, 1979 8:47 AM
DIRECTORY
ComData: FROM "comdata"
USING [
bodyIndex, bodyRoot, defBodyLimit, idINTEGER, idLOCK,
importCtx, mainBody, mainCtx, moduleCtx,
monitored, nBodies, nSigCodes, nTypeCodes, textIndex, typeMapId],
CompilerUtil: FROM "compilerutil",
Log: FROM "log" USING [Error, ErrorHti],
Symbols: FROM "symbols"
USING [
BodyLink, BodyInfo, BodyRecord, ContextLevel, SERecord, TransferMode,
HTIndex, SEIndex, CSEIndex, ISEIndex, RecordSEIndex,
CTXIndex, BTIndex, CBTIndex,
HTNull, SENull, CSENull, ISENull, RecordSENull,
CTXNull, BTNull, CBTNull,
lG, lL, lZ, typeANY, seType, ctxType, bodyType],
SymbolOps: FROM "symbolops"
USING [
FillCtxSe, NewCtx, MakeNonCtxSe, MakeSeChain, NameClash,
NextLevel, NextSe, StaticNestError],
Table: FROM "table"
USING [Base, Notifier, AddNotify, Allocate, DropNotify, Bounds],
Tree: FROM "tree" USING [Index, Link, Map, Null, NullIndex, Scan, treeType],
TreeOps: FROM "treeops"
USING [
FreeNode, GetNode, ListHead, ListLength,
ScanList, TestTree, UpdateList];
Pass2: PROGRAM
IMPORTS
Log, SymbolOps, Table, TreeOps,
dataPtr: ComData
EXPORTS CompilerUtil =
BEGIN
OPEN TreeOps, SymbolOps, Symbols;
tb: Table.Base; -- tree base (private copy)
seb: Table.Base; -- se table base (private copy)
ctxb: Table.Base; -- context table base (private copy)
bb: Table.Base; -- body table base (private copy)
Notify: Table.Notifier =
BEGIN -- called by allocator whenever tables are repacked
tb ← base[Tree.treeType];
seb ← base[seType]; ctxb ← base[ctxType]; bb ← base[bodyType];
END;
ContextInfo: TYPE = RECORD [
ctx: CTXIndex,
staticLevel: ContextLevel,
seChain: ISEIndex];
current: ContextInfo;
NewContext: PROCEDURE [level: ContextLevel, entries: CARDINAL, unique: BOOLEAN] =
BEGIN
OPEN current;
staticLevel ← level;
IF entries = 0 AND ~unique
THEN BEGIN ctx ← CTXNull; seChain ← ISENull END
ELSE
BEGIN
ctx ← NewCtx[level];
ctxb[ctx].seList ← seChain ← MakeSeChain[ctx, entries, FALSE];
END;
END;
-- main driver
P2Unit: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [Tree.Link] =
BEGIN
node: Tree.Index;
Table.AddNotify[Notify];
node ← GetNode[t];
BEGIN
ENABLE -- default error reporting
BEGIN
NameClash => BEGIN Log.ErrorHti[duplicateId, hti]; RESUME END;
StaticNestError => BEGIN Log.Error[staticNesting]; RESUME END;
END;
dataPtr.textIndex ← tb[node].info;
NewContext[lZ, ListLength[tb[node].son[1]]+ListLength[tb[node].son[2]], FALSE];
dataPtr.moduleCtx ← current.ctx;
ScanList[tb[node].son[1], IdDefinition];
ScanList[tb[node].son[2], Module];
END;
Table.DropNotify[Notify];
RETURN [t]
END;
lockLambda: Tree.Index;
Module: Tree.Scan =
BEGIN
saved: ContextInfo;
saveIndex: CARDINAL = dataPtr.textIndex;
node: Tree.Index = GetNode[t];
dataPtr.bodyIndex ← CBTNull; dataPtr.nBodies ← dataPtr.nSigCodes ← 0;
btLink ← [which:parent, index:BTNull];
dataPtr.textIndex ← tb[node].info;
-- process import list
saved ← current;
NewContext[lG, ListLength[tb[node].son[1]], FALSE];
dataPtr.importCtx ← current.ctx;
ScanList[tb[node].son[1], IdDefinition];
current ← saved;
dataPtr.monitored ← tb[node].son[4] # Tree.Null;
lockLambda ← Lambda[tb[node].son[4], lL];
DeclList[tb[node].son[5], SENull];
BodyList[dataPtr.bodyRoot];
dataPtr.defBodyLimit ← Table.Bounds[bodyType].size;
dataPtr.textIndex ← saveIndex;
END;
IdDefinition: Tree.Scan =
BEGIN
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;
END;
-- monitor lock processing
Lambda: PROCEDURE [item: Tree.Link, level: ContextLevel] RETURNS [node: Tree.Index] =
BEGIN
saved: ContextInfo = current;
node ← GetNode[item];
IF node # Tree.NullIndex
THEN
BEGIN
NewContext[level, CountIds[tb[node].son[1]], FALSE];
tb[node].info ← current.ctx;
DeclList[tb[node].son[1], SENull];
IF tb[node].son[2] # Tree.Null THEN Exp[tb[node].son[2]];
END;
current ← saved; RETURN
END;
ImplicitLock: PROCEDURE [sei: ISEIndex] =
BEGIN
WITH tb[lockLambda].son[2] SELECT FROM
hash => FillCtxSe[sei, index, tb[lockLambda].attr2];
ENDCASE => ERROR;
BEGIN OPEN seb[sei];
public ← tb[lockLambda].attr2;
extended ← immutable ← constant ← linkSpace ← FALSE;
idType ← dataPtr.idLOCK;
idInfo ← 1; idValue ← Tree.NullIndex;
mark3 ← TRUE; mark4 ← FALSE;
END;
tb[lockLambda].son[2] ← [symbol[index: sei]];
END;
-- type map processing
AllocateTypeMap: PROCEDURE [sei: ISEIndex] =
BEGIN
mapType, subType: CSEIndex;
FillCtxSe[sei, HTNull, FALSE];
subType ← MakeNonCtxSe[SIZE[subrange cons SERecord]];
seb[subType].typeInfo ← subrange[
filled: FALSE, empty: FALSE, flexible: FALSE,
rangeType: dataPtr.idINTEGER,
origin: , range: ];
seb[subType].mark3 ← TRUE;
mapType ← MakeNonCtxSe[SIZE[array cons SERecord]];
seb[mapType].typeInfo ← array[
oldPacked: FALSE, lengthUsed: TRUE, comparable: TRUE,
indexType: subType,
componentType: typeANY];
seb[mapType].mark3 ← TRUE;
BEGIN OPEN seb[sei];
public ← extended ← constant ← linkSpace ← FALSE; immutable ← TRUE;
idType ← mapType;
idInfo ← 1; idValue ← Tree.NullIndex;
mark3 ← TRUE; mark4 ← FALSE;
END;
END;
-- body processing
btLink: BodyLink;
AllocateBody: PROCEDURE [node: Tree.Index] RETURNS [bti: CBTIndex] =
BEGIN -- queue body for later processing
-- force nesting message here
SELECT NextLevel[current.staticLevel] FROM
lG, lL =>
BEGIN
bti ← Table.Allocate[bodyType, SIZE[Outer Callable BodyRecord]];
bb[bti] ← BodyRecord[,,,,, Callable[,,,,,,,,,, Outer[]]];
END;
ENDCASE =>
BEGIN
bti ← Table.Allocate[bodyType, SIZE[Inner Callable BodyRecord]];
bb[bti] ← BodyRecord[,,,,,Callable[,,,,,,,,,,Inner[frameOffset: ]]];
END;
bb[bti].firstSon ← BTNull;
bb[bti].info ← BodyInfo[Internal[
bodyTree: node,
sourceIndex: dataPtr.textIndex,
thread: Tree.NullIndex,
frameSize: ]];
bb[bti].id ← IF tb[node].attr1 THEN FirstId[tb[node].son[1]]
ELSE ISENull;
bb[bti].ioType ← typeANY;
LinkBody[bti]; RETURN
END;
LinkBody: PROCEDURE [bti: BTIndex] =
BEGIN
IF btLink.which = parent
THEN
BEGIN
bb[bti].link ← btLink;
IF btLink.index = BTNull THEN dataPtr.bodyRoot ← bti
ELSE bb[btLink.index].firstSon ← bti;
END
ELSE
BEGIN
bb[bti].link ← bb[btLink.index].link;
bb[btLink.index].link ← [which:sibling, index: bti];
END;
btLink ← [which:sibling, index: bti];
END;
BodyList: PROCEDURE [firstBti: BTIndex] =
BEGIN
bti: BTIndex;
IF (bti ← firstBti) # BTNull
THEN
DO
WITH bb[bti] SELECT FROM
Callable => Body[LOOPHOLE[bti, CBTIndex]];
ENDCASE => NULL;
IF bb[bti].link.which = parent THEN EXIT;
bti ← bb[bti].link.index;
ENDLOOP;
END;
Body: PROCEDURE [bti: CBTIndex] =
BEGIN
node: Tree.Index;
bodyLevel: ContextLevel;
nLocks, nMaps: [0..1];
oldBodyIndex: CBTIndex = dataPtr.bodyIndex;
oldBtLink: BodyLink = btLink;
saved: ContextInfo = current;
dataPtr.bodyIndex ← bti;
btLink ← [which:parent, index:bti];
node ← WITH bb[bti].info SELECT FROM
Internal => GetNode[tb[LOOPHOLE[bodyTree,Tree.Index]].son[3]],
ENDCASE => ERROR;
bodyLevel ← NextLevel[saved.staticLevel !StaticNestError => RESUME];
nLocks ← IF dataPtr.monitored AND
bodyLevel = lG AND tb[lockLambda].attr1 THEN 1 ELSE 0;
nMaps ← IF bodyLevel = lG AND dataPtr.nTypeCodes # 0 THEN 1 ELSE 0;
NewContext[
level: bodyLevel,
entries: nLocks + CountIds[tb[node].son[2]] + nMaps,
unique: bodyLevel = lG];
bb[bti].localCtx ← current.ctx; bb[bti].level ← bodyLevel;
bb[bti].monitored ← nLocks # 0;
bb[bti].inline ← tb[node].attr3;
IF bodyLevel = lG
THEN
BEGIN
dataPtr.mainCtx ← current.ctx; dataPtr.mainBody ← bti;
dataPtr.typeMapId ← ISENull;
END;
ScanList[tb[node].son[1], Exp];
IF nLocks # 0
THEN
BEGIN
ImplicitLock[current.seChain];
current.seChain ← NextSe[current.seChain]
END;
DeclList[tb[node].son[2], SENull];
IF nMaps # 0
THEN
BEGIN
dataPtr.typeMapId ← current.seChain;
current.seChain ← NextSe[current.seChain];
AllocateTypeMap[dataPtr.typeMapId];
END;
ScanList[tb[node].son[3], Stmt];
BodyList[bb[bti].firstSon];
current ← saved; dataPtr.bodyIndex ← oldBodyIndex; btLink ← oldBtLink;
END;
Inline: Tree.Scan = BEGIN ScanList[t, Exp] END;
-- declarations
DeclList: PROCEDURE [t: Tree.Link, linkId: SEIndex] =
BEGIN
DeclItem: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
subNode: Tree.Index;
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← tb[node].info;
tb[node].son[1] ← Ids[
list: tb[node].son[1],
public: tb[node].attr2,
readOnly: tb[node].attr3,
link: node];
tb[node].attr2 ← tb[node].attr3 ← FALSE;
IF tb[node].name = typedecl
THEN
BEGIN
TypeExp[tb[node].son[2], FirstId[tb[node].son[1]], linkId];
ScanList[tb[node].son[3], Exp];
END
ELSE
BEGIN
TypeExp[tb[node].son[2], SENull, linkId];
IF tb[node].son[3] # Tree.Null AND tb[node].son[3].tag = subtree
THEN
BEGIN
subNode ← GetNode[tb[node].son[3]];
SELECT tb[subNode].name FROM
entry, internal =>
BEGIN
IF ~dataPtr.monitored OR ~TestTree[tb[subNode].son[1], body]
THEN Log.Error[misplacedEntry]
ELSE
WITH tb[subNode].son[1] SELECT FROM
subtree =>
SELECT tb[subNode].name FROM
entry => tb[index].attr1 ← TRUE;
internal => tb[index].attr2 ← TRUE;
ENDCASE;
ENDCASE;
tb[node].son[3] ← tb[subNode].son[1];
tb[subNode].son[1] ← Tree.Null; FreeNode[subNode];
END;
ENDCASE;
END;
IF tb[node].son[3] # Tree.Null
THEN
WITH tb[node].son[3] SELECT FROM
subtree =>
BEGIN subNode ← index;
SELECT tb[subNode].name FROM
body =>
BEGIN
tb[subNode].info ← AllocateBody[node];
IF ~tb[subNode].attr3
THEN dataPtr.nBodies ← dataPtr.nBodies+1;
END;
signalinit =>
BEGIN
tb[subNode].info ← dataPtr.nSigCodes;
dataPtr.nSigCodes ← dataPtr.nSigCodes+1;
END;
inline => ScanList[tb[subNode].son[1], Inline];
ENDCASE => ScanList[tb[node].son[3], Exp];
END;
ENDCASE => ScanList[tb[node].son[3], Exp];
END;
dataPtr.textIndex ← saveIndex;
END;
ScanList[root:t, action:DeclItem];
END;
CountIds: PROCEDURE [declList: Tree.Link] RETURNS [n: CARDINAL] =
BEGIN
nIds: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
n ← n + ListLength[tb[node].son[1]];
END;
n ← 0; ScanList[declList, nIds]; RETURN
END;
-- id list manipulation
Ids: PROCEDURE [
list: Tree.Link,
public: BOOLEAN,
readOnly: BOOLEAN ← FALSE,
link: Tree.Index]
RETURNS [Tree.Link] =
BEGIN
Id: Tree.Map =
BEGIN
hti: HTIndex;
sei: ISEIndex;
ctx: CTXIndex = current.ctx;
hti ← WITH t SELECT FROM
hash => index,
symbol => seb[index].hash,
ENDCASE => ERROR;
sei ← current.seChain; current.seChain ← NextSe[current.seChain];
FillCtxSe[sei, hti, public];
v ← Tree.Link[symbol[index: sei]];
seb[sei].idType ← typeANY;
seb[sei].public ← public; seb[sei].immutable ← readOnly;
seb[sei].idValue ← link; seb[sei].idInfo ← 0;
seb[sei].extended ← seb[sei].linkSpace ← FALSE;
RETURN
END;
RETURN [UpdateList[root:list, map:Id]]
END;
FirstId: PROCEDURE [t: Tree.Link] RETURNS [ISEIndex] =
BEGIN
head: Tree.Link = ListHead[t];
RETURN [WITH head SELECT FROM symbol => index, ENDCASE => ERROR];
END;
-- type manipulation
TypeExp: PROCEDURE [t: Tree.Link, typeId, linkId: SEIndex] =
BEGIN
node: Tree.Index;
sei: CSEIndex;
tCtx: CTXIndex;
nFields: CARDINAL;
WITH t SELECT FROM
subtree =>
BEGIN node ← index;
SELECT tb[node].name FROM
enumeratedTC =>
BEGIN
sei ← MakeNonCtxSe[SIZE[enumerated cons SERecord]];
tCtx ← Enumeration[node];
seb[sei].typeInfo ← enumerated[
ordered: TRUE,
valueCtx: tCtx,
nValues: ];
AssignValues[sei, IF typeId # SENull THEN typeId ELSE sei];
END;
recordTC, monitoredTC =>
BEGIN
sei ← MakeNonCtxSe[SIZE[notLinked record cons SERecord]];
[tCtx, nFields] ← FieldList[
t: tb[node].son[1],
level: lZ,
typeId: IF typeId # SENull THEN typeId ELSE sei];
seb[sei].typeInfo ← record[
machineDep: tb[node].attr1,
argument: FALSE,
hints: [
unifield: nFields = 1 AND ~tb[node].attr2,
variant: tb[node].attr2,
comparable: FALSE, privateFields: FALSE],
length: ,
lengthUsed: FALSE,
fieldCtx: tCtx,
monitored: tb[node].name = monitoredTC,
linkPart: notLinked[]];
END;
variantTC =>
BEGIN
sei ← MakeNonCtxSe[SIZE[linked record cons SERecord]];
tCtx ← FieldList[t:tb[node].son[1], level:lZ, typeId:typeId].ctx;
seb[sei].typeInfo ← record[
machineDep: tb[node].attr1,
argument: FALSE,
hints: [
variant: tb[node].attr2,
unifield: FALSE, comparable: FALSE, privateFields: FALSE],
length: ,
lengthUsed: FALSE,
fieldCtx: tCtx,
monitored: FALSE,
linkPart: linked[linkId]];
END;
pointerTC =>
BEGIN sei ← MakeNonCtxSe[SIZE[pointer cons SERecord]];
seb[sei].typeInfo ← pointer[
ordered: tb[node].attr1,
basing: tb[node].attr2,
readOnly: tb[node].attr3,
dereferenced: FALSE,
refType: ];
TypeExp[tb[node].son[1], SENull, SENull];
END;
arrayTC =>
BEGIN sei ← MakeNonCtxSe[SIZE[array cons SERecord]];
seb[sei].typeInfo ← array[
oldPacked: tb[node].attr1,
lengthUsed: FALSE,
comparable: FALSE,
indexType: ,
componentType: ];
IF tb[node].son[1] # Tree.Null
THEN TypeExp[tb[node].son[1], SENull, SENull];
TypeExp[tb[node].son[2], SENull, SENull];
END;
arraydescTC =>
BEGIN sei ← MakeNonCtxSe[SIZE[arraydesc cons SERecord]];
seb[sei].typeInfo ← arraydesc[
readOnly: tb[node].attr3,
describedType: ];
TypeExp[tb[node].son[1], SENull, SENull];
END;
procTC => sei ← Transfer[node, procedure];
portTC => sei ← Transfer[node, port];
signalTC => sei ← Transfer[node, signal];
errorTC => sei ← Transfer[node, error];
processTC => sei ← Transfer[node, process];
programTC => sei ← Transfer[node, program];
definitionTC =>
BEGIN
sei ← MakeNonCtxSe[SIZE[definition cons SERecord]];
seb[sei].typeInfo ← definition[nGfi: 1, named: FALSE, defCtx: ];
END;
unionTC => sei ← Union[node, linkId];
relativeTC =>
BEGIN
sei ← MakeNonCtxSe[SIZE[relative cons SERecord]];
seb[sei].typeInfo ← relative[
baseType: ,
offsetType: ,
resultType: ];
TypeExp[tb[node].son[1], SENull, SENull];
TypeExp[tb[node].son[2], SENull, SENull];
END;
subrangeTC =>
BEGIN sei ← MakeNonCtxSe[SIZE[subrange cons SERecord]];
seb[sei].typeInfo ← subrange[
filled: FALSE,
empty: FALSE,
flexible: FALSE,
rangeType: ,
origin: ,
range: ];
TypeExp[tb[node].son[1], SENull, SENull];
Interval[tb[node].son[2]];
END;
longTC =>
BEGIN sei ← MakeNonCtxSe[SIZE[long cons SERecord]];
seb[sei].typeInfo ← long[rangeType: ];
TypeExp[tb[node].son[1], SENull, SENull];
END;
implicitTC, frameTC => sei ← CSENull;
dot, discrimTC =>
BEGIN TypeExp[tb[node].son[1], SENull, SENull]; sei ← CSENull END;
ENDCASE =>
BEGIN sei ← CSENull; Log.Error[nonTypeCons] END;
tb[node].info ← sei;
END;
ENDCASE => NULL;
END;
Enumeration: PROCEDURE [node: Tree.Index] RETURNS [ctx: CTXIndex] =
BEGIN
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
END;
AssignValues: PROCEDURE [type: CSEIndex, valueType: SEIndex] =
BEGIN
i: CARDINAL;
sei: ISEIndex;
WITH seb[type] SELECT FROM
enumerated =>
BEGIN i ← 0;
FOR sei ← ctxb[valueCtx].seList, NextSe[sei] UNTIL sei = SENull
DO OPEN seb[sei];
idType ← valueType; idInfo ← 0;
idValue ← i; i ← i+1;
immutable ← constant ← mark3 ← mark4 ← TRUE;
ENDLOOP;
nValues ← i;
END;
ENDCASE => ERROR;
END;
FieldList: PROCEDURE [t: Tree.Link, level: ContextLevel, typeId: SEIndex]
RETURNS [ctx: CTXIndex, nFields: CARDINAL] =
BEGIN
saved: ContextInfo = current;
nFields ← CountIds[t];
NewContext[level, nFields, TRUE]; ctx ← current.ctx;
DeclList[t, typeId];
current ← saved; RETURN
END;
Transfer: PROCEDURE [node: Tree.Index, mode: TransferMode] RETURNS [sei: CSEIndex] =
BEGIN
sei ← MakeNonCtxSe[SIZE[transfer cons SERecord]];
seb[sei].typeInfo ← transfer[
mode: mode,
inRecord: ArgList[tb[node].son[1]],
outRecord: ArgList[tb[node].son[2]]];
RETURN
END;
ArgList: PROCEDURE [t: Tree.Link] RETURNS [type: RecordSEIndex] =
BEGIN
tCtx: CTXIndex;
nFields: CARDINAL;
IF t = Tree.Null
THEN type ← RecordSENull
ELSE
BEGIN
type ← LOOPHOLE[MakeNonCtxSe[SIZE[notLinked record cons SERecord]]];
[tCtx, nFields] ← FieldList[t, lZ, type];
seb[type].typeInfo ← record[
machineDep: FALSE,
argument: TRUE,
hints: [
unifield: nFields = 1,
variant: FALSE, comparable: FALSE, privateFields: FALSE],
length: ,
lengthUsed: FALSE,
fieldCtx: tCtx,
monitored: FALSE,
linkPart: notLinked[]];
END;
RETURN
END;
Union: PROCEDURE [node: Tree.Index, linkId: SEIndex] RETURNS [sei: CSEIndex] =
BEGIN
tagId: ISEIndex;
subnode: Tree.Index;
saved: ContextInfo = current;
current.ctx ← CTXNull; current.seChain ← MakeSeChain[CTXNull, 1, FALSE];
DeclList[tb[node].son[1], SENull];
subnode ← GetNode[tb[node].son[1]];
tagId ← FirstId[tb[subnode].son[1]];
WITH tb[subnode].son[2] SELECT FROM
subtree =>
IF tb[index].name = implicitTC
THEN tb[index].info ← MakeTagType[tb[node].son[2]];
ENDCASE => NULL;
NewContext[lZ, CountIds[tb[node].son[2]], TRUE];
DeclList[tb[node].son[2], linkId
!NameClash =>
BEGIN Log.ErrorHti[duplicateTag, hti]; RESUME END];
sei ← MakeNonCtxSe[SIZE[union cons SERecord]];
seb[sei].typeInfo ← union[
caseCtx: current.ctx,
overlayed: tb[node].attr1,
controlled: seb[tagId].hash # HTNull,
tagSei: tagId,
equalLengths: FALSE];
current ← saved; RETURN
END;
MakeTagType: PROCEDURE [t: Tree.Link] RETURNS [type: CSEIndex] =
BEGIN
saved: ContextInfo = current;
CollectTags: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
tb[node].son[1] ← Ids[
list: tb[node].son[1],
public: tb[node].attr2,
link: Tree.NullIndex
!NameClash => RESUME];
END;
NewContext[lZ, CountIds[t], TRUE];
type ← MakeNonCtxSe[SIZE[enumerated cons SERecord]];
seb[type].typeInfo ← enumerated[
ordered: FALSE,
valueCtx: current.ctx,
nValues: ];
ScanList[t, CollectTags];
AssignValues[type, type];
current ← saved; RETURN
END;
-- statements
Stmt: PROCEDURE [stmt: Tree.Link] =
BEGIN
node, subNode: Tree.Index;
saveIndex: CARDINAL = dataPtr.textIndex;
IF stmt = Tree.Null THEN RETURN;
WITH stmt SELECT FROM
subtree =>
BEGIN node ← index;
dataPtr.textIndex ← tb[node].info;
SELECT tb[node].name FROM
assign => BEGIN Exp[tb[node].son[1]]; Exp[tb[node].son[2]] END;
extract =>
BEGIN ScanList[tb[node].son[1], Exp]; Exp[tb[node].son[2]] END;
apply =>
BEGIN
Exp[tb[node].son[1]]; ScanList[tb[node].son[2], Exp];
IF tb[node].nSons > 2 THEN CatchPhrase[tb[node].son[3]];
END;
block => Block[node];
if =>
BEGIN OPEN tb[node];
Exp[son[1]]; ScanList[son[2], Stmt]; ScanList[son[3], Stmt];
END;
case =>
BEGIN OPEN tb[node];
Exp[son[1]]; SelectionList[son[2], Stmt]; Stmt[son[3]];
END;
bind =>
BEGIN OPEN tb[node];
Exp[son[1]];
IF son[2] # Tree.Null THEN Exp[son[2]];
SelectionList[son[3], Stmt];
Stmt[son[4]];
END;
do =>
BEGIN OPEN tb[node];
IF son[1] # Tree.Null
THEN
BEGIN subNode ← GetNode[son[1]];
IF tb[subNode].son[1] # Tree.Null
THEN Exp[tb[subNode].son[1]];
SELECT tb[subNode].name FROM
forseq =>
BEGIN
Exp[tb[subNode].son[2]]; Exp[tb[subNode].son[3]];
END;
upthru, downthru => Range[tb[subNode].son[2]];
ENDCASE => ERROR;
END;
IF son[2] # Tree.Null THEN Exp[son[2]];
ScanList[son[3], Exp];
ScanList[son[4], Stmt];
ScanList[son[5], Stmt]; ScanList[son[6], Stmt];
END;
return, resume => ScanList[tb[node].son[1], Exp];
label =>
BEGIN
ScanList[tb[node].son[1], Stmt]; ScanList[tb[node].son[2], Stmt];
END;
goto, exit, loop, continue, retry, syserror, null => NULL;
signal, error, xerror, start, restart,
join, wait, notify, broadcast, dst, lst, lstf =>
Exp[tb[node].son[1]];
stop =>
IF tb[node].son[1] # Tree.Null THEN CatchPhrase[tb[node].son[1]];
open =>
BEGIN
ScanList[tb[node].son[1], Exp]; ScanList[tb[node].son[2], Stmt];
END;
enable =>
BEGIN
CatchPhrase[tb[node].son[1]]; ScanList[tb[node].son[2], Stmt];
END;
list => ScanList[stmt, Stmt];
item => Stmt[tb[node].son[2]];
ENDCASE => Log.Error[unimplemented];
END;
ENDCASE => NULL;
dataPtr.textIndex ← saveIndex;
END;
Block: PROCEDURE [node: Tree.Index] =
BEGIN
bti: BTIndex;
oldBtLink: BodyLink;
saved: ContextInfo = current;
NewContext[
level: saved.staticLevel,
entries: CountIds[tb[node].son[1]],
unique: FALSE];
bti ← Table.Allocate[bodyType, SIZE[Other BodyRecord]];
bb[bti] ← BodyRecord[
link: ,
firstSon: BTNull,
localCtx: current.ctx,
level: current.staticLevel,
info: BodyInfo[Internal[
bodyTree: node,
sourceIndex: tb[node].info,
thread: Tree.NullIndex,
frameSize: ]],
extension: Other[]];
LinkBody[bti]; oldBtLink ← btLink; btLink ← [which:parent, index:bti];
tb[node].info ← bti;
DeclList[tb[node].son[1], SENull];
ScanList[tb[node].son[2], Stmt];
BodyList[bb[bti].firstSon];
current ← saved; btLink ← oldBtLink;
END;
SelectionList: PROCEDURE [t: Tree.Link, selection: Tree.Scan] =
BEGIN
Item: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← tb[node].info;
ScanList[tb[node].son[1], Exp]; selection[tb[node].son[2]];
dataPtr.textIndex ← saveIndex;
END;
ScanList[t, Item];
END;
CatchPhrase: PROCEDURE [t: Tree.Link] =
BEGIN
node: Tree.Index = GetNode[t];
saved: ContextInfo = current;
NewContext[
level: NextLevel[saved.staticLevel],
entries: 0,
unique: FALSE];
SelectionList[tb[node].son[1], Stmt];
IF tb[node].nSons > 1 THEN ScanList[tb[node].son[2], Stmt];
current ← saved;
END;
-- expressions
Exp: PROCEDURE [exp: Tree.Link] =
BEGIN
node, subNode: Tree.Index;
IF exp = Tree.Null THEN RETURN;
WITH exp SELECT FROM
subtree =>
BEGIN node ← index;
SELECT tb[node].name FROM
apply =>
BEGIN
Exp[tb[node].son[1]]; ScanList[tb[node].son[2], Exp];
IF tb[node].nSons > 2 THEN CatchPhrase[tb[node].son[3]];
END;
signalx, errorx, startx, fork, joinx,
dot, uparrow,
uminus, not, addr, new =>
Exp[tb[node].son[1]];
plus, minus, times, div, mod,
relE, relN, relL, relGE, relG, relLE,
or, and, assignx =>
BEGIN Exp[tb[node].son[1]]; Exp[tb[node].son[2]] END;
in, notin =>
BEGIN Exp[tb[node].son[1]]; Range[tb[node].son[2]] END;
ifx =>
BEGIN
Exp[tb[node].son[1]]; Exp[tb[node].son[2]]; Exp[tb[node].son[3]];
END;
casex =>
BEGIN OPEN tb[node];
Exp[son[1]]; SelectionList[son[2], Exp]; Exp[son[3]];
END;
bindx =>
BEGIN OPEN tb[node];
Exp[son[1]];
IF son[2] # Tree.Null THEN Exp[son[2]];
SelectionList[son[3], Exp];
Exp[son[4]];
END;
lengthen, float, abs, min, max, base, length, all =>
ScanList[tb[node].son[1], Exp];
arraydesc =>
SELECT ListLength[tb[node].son[1]] FROM
1 => Exp[tb[node].son[1]];
3 =>
BEGIN
subNode ← GetNode[tb[node].son[1]];
Exp[tb[subNode].son[1]]; Exp[tb[subNode].son[2]];
IF tb[subNode].son[3] # Tree.Null
THEN TypeExp[tb[subNode].son[3], SENull, SENull];
END;
ENDCASE => ERROR;
void, clit, llit, mwconst, syserrorx => NULL;
loophole =>
BEGIN
Exp[tb[node].son[1]];
IF tb[node].son[2] # Tree.Null
THEN TypeExp[tb[node].son[2], SENull, SENull];
END;
size, first, last, typecode =>
TypeExp[tb[node].son[1], SENull, SENull];
item => Exp[tb[node].son[2]];
ENDCASE => Log.Error[unimplemented];
END;
ENDCASE => NULL;
END;
Interval: PROCEDURE [t: Tree.Link] =
BEGIN
node: Tree.Index = GetNode[t];
Exp[tb[node].son[1]]; Exp[tb[node].son[2]];
END;
Range: PROCEDURE [t: Tree.Link] =
BEGIN
node: Tree.Index;
WITH t SELECT FROM
subtree =>
BEGIN node ← index;
SELECT tb[node].name FROM
subrangeTC =>
BEGIN
TypeExp[tb[node].son[1], SENull, SENull];
Interval[tb[node].son[2]];
END;
IN [intOO .. intCC] => Interval[t];
ENDCASE => TypeExp[t, SENull, SENull];
END;
ENDCASE => TypeExp[t, SENull, SENull];
END;
END.