-- file Pass3M.mesa
-- last modified by Satterthwaite, May 10, 1983 9:21 am
-- last modified by Donahue, 9-Dec-81 14:45:35
DIRECTORY
A3: TYPE USING [
Bundling, CanonicalType, DefaultInit, LongPath, NewableType, OperandInternal,
OperandLhs, OperandType, TypeForTree, Unbundle, Voidable],
Alloc: TYPE USING [Notifier, Top],
ComData: TYPE USING [
bodyIndex, idUNWIND, ownSymbols, seAnon, stopping, table, textIndex,
typeCONDITION, typeListANY, typeLOCK],
Log: TYPE USING [Error, ErrorSei, ErrorTree],
Pass3: TYPE USING [lockNode],
P3: TYPE USING [
Attr, fullAttr, NPUse, Safety, TextForm,
pathNP, phraseNP, BoundNP, MergeNP, SequenceNP, SetNP,
And, Apply, BindTree, BumpArgRefs, CheckLocals, CheckScope,
ClearRefStack, CopyTree, EnterType, EnterComposite, Exp, FirstId, InitialExp,
MakeLongType, MakeRefType, MatchFields, PopCtx, PushCtx,
RAttr, Rhs, RPop, RPush, RType, SafetyAttr, SetSafety, SealRefStack, SearchCtxList,
Stmt, TypeAppl, UnsealRefStack, UpdateTreeAttr, VoidExp],
P3S: TYPE USING [BodyData, continued, currentBody, markCatch, safety],
Strings: TYPE USING [String, SubStringDescriptor],
Symbols: TYPE USING [
Base, HTIndex, SERecord, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, RefSEIndex,
CTXIndex, BodyRecord, BTIndex, CBTIndex,
HTNull, SENull, ISENull, CSENull, RecordSENull, CTXNull, CBTNull,
lG, lZ, RootBti, typeANY, seType, ctxType, mdType, bodyType],
SymbolOps: TYPE USING [
ArgCtx, ArgRecord, EnterString, FindString, FirstCtxSe, MakeNonCtxSe,
NextSe, NormalType, ReferentType, TransferTypes, TypeRoot, UnderType],
Tree: TYPE USING [Base, Index, Link, Map, NodeName, Null, NullIndex, Scan, treeType],
TreeOps: TYPE USING [
FreeNode, FreeTree, GetNode, ListLength, MakeList, MakeNode,
NthSon, PopTree, PushList, PushTree, PushSe, PushNode, OpName,
ReverseUpdateList, ScanList, SetAttr, SetInfo, UpdateList],
Types: TYPE USING [Assignable, Equivalent];
Pass3M: PROGRAM
IMPORTS
A3, Alloc, Log, P3, P3S, SymbolOps, TreeOps, Types,
dataPtr: ComData, passPtr: Pass3
EXPORTS P3 = {
OPEN SymbolOps, Symbols, A3, P3, TreeOps;
InsertCatchLabel: PUBLIC SIGNAL [catchSeen, exit: BOOL] = CODE;
tb: Tree.Base; -- tree base address (local copy)
seb: Symbols.Base; -- se table base address (local copy)
ctxb: Symbols.Base; -- context table base (local copy)
mdb: Symbols.Base; -- module table base (local copy)
bb: Symbols.Base; -- body table base (local copy)
MiscNotify: PUBLIC Alloc.Notifier = {
-- called by allocator whenever table area is repacked
tb ← base[Tree.treeType];
seb ← base[seType]; ctxb ← base[ctxType]; mdb ← base[mdType];
bb ← base[bodyType]};
current: POINTER TO P3S.BodyData = @P3S.currentBody;
-- statements
MiscStmt: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
val ← [subtree[index: node]]; -- the default
SELECT tb[node].name FROM
signal, error, start, join, wait => {
PushTree[SELECT tb[node].name FROM
start => Start[node],
join => Join[node],
wait => Wait[node],
ENDCASE => Signal[node]];
SELECT RType[] FROM
CSENull, typeANY => NULL;
ENDCASE => Log.Error[nonVoidStmt];
SetInfo[dataPtr.textIndex]; val ← PopTree[]; RPop[];
pathNP ← SequenceNP[pathNP][phraseNP];
IF OpName[val] = error THEN current.reachable ← FALSE};
xerror => {
subNode: Tree.Index;
IF current.catchDepth # 0 THEN Log.Error[misplacedReturn];
tb[node].name ← error;
val ← MiscStmt[node]; subNode ← GetNode[val];
IF tb[subNode].attr1 THEN Log.ErrorTree[typeClash, val];
SELECT tb[subNode].name FROM
error, errorx => tb[subNode].name ← xerror;
ENDCASE => NULL;
tb[subNode].attr1 ← current.entry; tb[subNode].attr3 ← FALSE;
IF current.entry THEN tb[subNode].attr2 ← CheckLocals[tb[subNode].son[2]];
IF tb[subNode].nSons > 2 THEN Log.Error[misplacedCatch];
current.reachable ← FALSE};
resume => Resume[node];
reject => {
IF current.catchDepth = 0 THEN Log.Error[misplacedResume];
current.reachable ← FALSE};
continue, retry => {
SIGNAL InsertCatchLabel[catchSeen:FALSE, exit:tb[node].name=continue];
current.reachable ← FALSE};
restart => {val ← Restart[node]; pathNP ← SequenceNP[pathNP][phraseNP]};
stop => {
IF dataPtr.bodyIndex # RootBti OR current.catchDepth # 0
OR current.returnRecord # SENull THEN Log.Error[misplacedStop];
dataPtr.stopping ← TRUE; pathNP ← SetNP[pathNP]};
notify, broadcast => {
OPEN tb[node];
type: CSEIndex;
IF ~current.lockHeld THEN Log.Error[misplacedMonitorRef];
son[1] ← Exp[son[1], typeANY];
IF OperandLhs[son[1]] = none THEN Log.ErrorTree[nonLHS, son[1]];
type ← RType[]; RPop[]; pathNP ← SequenceNP[pathNP][phraseNP];
IF type # dataPtr.typeCONDITION THEN Log.ErrorTree[typeClash, son[1]]};
free => {
OPEN tb[node];
type, subType: CSEIndex;
long, counted: BOOL;
[v:son[1], long:long, counted:counted] ← EvalZone[son[1]]; RPop[];
son[2] ← Exp[son[2], typeANY]; type ← RType[]; RPop[];
subType ← NormalType[type];
WITH s: seb[subType] SELECT FROM
ref => {
IF s.readOnly THEN Log.ErrorTree[nonLHS, son[2]];
type ← UnderType[s.refType];
IF long # (seb[type].typeTag = long) THEN GO TO fail;
type ← NormalType[type];
WITH t: seb[type] SELECT FROM
ref => IF t.counted # counted THEN GO TO fail;
ENDCASE => GO TO fail;
IF P3S.safety = checked AND ~counted THEN
Log.ErrorTree[unsafeOperation, [subtree[node]]];
EXITS
fail => Log.ErrorTree[typeClash, son[2]]};
ENDCASE => Log.ErrorTree[typeClash, son[2]];
IF nSons > 3 THEN {
saveNP: NPUse = phraseNP;
[] ← CatchPhrase[son[4]]; phraseNP ← MergeNP[saveNP][phraseNP]};
attr2 ← long; attr3 ← counted;
SELECT TRUE FROM
~counted => attr1 ← FALSE;
(OpName[son[2]] # addr) => {Log.ErrorTree[other, son[2]]; attr1 ← FALSE};
ENDCASE => attr1 ← OperandLhs[NthSon[son[2], 1]] = counted};
dst, lst, lste, lstf => {
OPEN tb[node];
v: Tree.Link;
v ← son[1] ← Exp[son[1], typeANY]; RPop[];
SELECT name FROM
dst => IF OperandLhs[son[1]] = none THEN GO TO fail;
lst => NULL;
lste => current.noXfers ← FALSE;
lstf => current.reachable ← FALSE;
ENDCASE;
IF name = lste OR name = lstf THEN phraseNP ← SetNP[phraseNP];
pathNP ← SequenceNP[pathNP][phraseNP];
-- check for simple addressability
DO
WITH v SELECT FROM
symbol => IF seb[index].constant THEN GO TO fail ELSE EXIT;
subtree => {
IF tb[index].name # dollar THEN GO TO fail; v ← tb[index].son[1]};
ENDCASE => GO TO fail;
ENDLOOP;
IF P3S.safety = checked THEN Log.ErrorTree[unsafeOperation, [subtree[node]]];
EXITS
fail => Log.ErrorTree[nonLHS, tb[node].son[1]]};
enable => {
OPEN tb[node];
saveEnabled: BOOL = current.unwindEnabled;
IF CatchPhrase[son[1]].unwindCaught THEN current.unwindEnabled ← TRUE;
IF phraseNP # none THEN pathNP ← unsafe;
son[2] ← UpdateList[son[2], Stmt]; attr3 ← FALSE;
current.unwindEnabled ← saveEnabled};
ENDCASE => Log.Error[unimplemented];
RETURN};
-- dynamic storage allocation
New: PROC [node: Tree.Index, target: CSEIndex] RETURNS [Tree.Link] = {
OPEN tb[node];
pType: RefSEIndex;
subType, rootType: SEIndex;
attr: Attr;
saveNP: NPUse;
long, counted: BOOL;
[v:son[1], long:long, counted:counted] ← EvalZone[son[1]];
attr ← RAttr[]; RPop[]; saveNP ← phraseNP;
current.noXfers ← attr.noXfer ← FALSE; attr.const ← FALSE;
son[2] ← TypeAppl[son[2]];
attr ← And[attr, RAttr[]]; saveNP ← MergeNP[saveNP][phraseNP]; RPop[];
subType ← TypeForTree[son[2]]; rootType ← TypeRoot[subType];
IF ~NewableType[subType] THEN Log.ErrorTree[typeLength, son[2]];
IF counted THEN EnterType[rootType, FALSE];
IF son[3] = Tree.Null THEN son[3] ← DefaultInit[subType]
ELSE {
StringInit: PROC [t: Tree.Link] RETURNS [BOOL] = INLINE {
RETURN [SELECT OpName[t] FROM
stringinit => TRUE,
lengthen => (OpName[NthSon[t, 1]] = stringinit),
ENDCASE => FALSE]};
extFlag: BOOL;
[son[3], extFlag] ← InitialExp[son[3], subType];
SELECT TRUE FROM
extFlag => Log.ErrorTree[misusedInline, son[3]];
StringInit[son[3]] => Log.ErrorTree[defaultForm, son[3]];
ENDCASE};
attr ← And[attr, RAttr[]]; phraseNP ← SequenceNP[saveNP][phraseNP]; RPop[];
pType ← MakeRefType[
cType: subType, readOnly: tb[node].attr1, counted: counted,
hint: NormalType[target]];
IF counted AND son[3] # Tree.Null THEN
EnterComposite[UnderType[subType], son[3], TRUE];
IF son[3] = Tree.Null AND ~Voidable[subType] THEN
Log.ErrorTree[missingInit, [subtree[node]]];
IF nSons > 3 THEN {
saveNP: NPUse = phraseNP;
[] ← CatchPhrase[son[4]]; phraseNP ← MergeNP[saveNP][phraseNP]};
attr2 ← long; attr3 ← counted;
RPush[IF long THEN MakeLongType[pType, target] ELSE pType, attr];
RETURN [[subtree[index: node]]]};
EvalZone: PROC [t: Tree.Link] RETURNS [v: Tree.Link, long, counted: BOOL] = {
type, nType: CSEIndex;
nDerefs: CARDINAL;
long ← counted ← TRUE;
IF t = Tree.Null THEN {v ← Tree.Null; RPush[typeANY, fullAttr]}
ELSE {
v ← Exp[t, typeANY]; type ← RType[]; nDerefs ← 0;
DO
nType ← NormalType[type];
WITH s: seb[nType] SELECT FROM
zone => {long ← ~s.mds; counted ← s.counted; GO TO success};
ref => {
IF (nDerefs ← nDerefs + 1) > 63 THEN GO TO failure;
PushTree[v]; PushNode[uparrow, 1]; SetAttr[2, seb[type].typeTag = long];
type ← UnderType[s.refType]; SetInfo[type]; v ← PopTree[]};
record =>
IF Bundling[nType] # 0 THEN type ← Unbundle[LOOPHOLE[nType, RecordSEIndex]]
ELSE GO TO failure;
ENDCASE => GO TO failure;
REPEAT
success => NULL;
failure => Log.ErrorTree[typeClash, v];
ENDLOOP};
RETURN};
-- list allocation
Cons: PROC [node: Tree.Index, target: CSEIndex] RETURNS [Tree.Link] = {
nType: CSEIndex = NodeType[target, [subtree[node]]];
PushTree[tb[node].son[1]]; tb[node].son[1] ← Tree.Null;
PushNode[implicitTC, 0]; SetInfo[nType];
PushTree[tb[node].son[2]]; tb[node].son[2] ← Tree.Null;
PushTree[Tree.Null]; PushNode[apply, -2]; SetAttr[1, FALSE];
IF tb[node].nSons > 2 THEN {
PushTree[tb[node].son[3]]; tb[node].son[3] ← Tree.Null; PushNode[new, 4]}
ELSE PushNode[new, 3];
FreeNode[node];
RETURN [Exp[PopTree[], target]]};
ListCons: PROC [node: Tree.Index, target: CSEIndex] RETURNS [Tree.Link] = {
nType: CSEIndex = NodeType[target, [subtree[node]]];
n: CARDINAL = ListLength[tb[node].son[2]];
k: CARDINAL ← n;
list, zone: Tree.Link;
ListItem: Tree.Map = {
PushTree[IF (k←k-1) = 0 THEN zone ELSE P3.CopyTree[zone]];
PushNode[implicitTC, 0]; SetInfo[nType];
PushTree[t]; PushTree[list]; PushList[2];
PushTree[Tree.Null]; PushNode[apply, -2]; SetAttr[1, FALSE];
list ← MakeNode[new, 3];
RETURN [Tree.Null]};
PushTree[Tree.Null]; list ← MakeNode[nil, 1];
IF n = 0 THEN [v: tb[node].son[1]] ← EvalZone[tb[node].son[1]]
ELSE {
zone ← tb[node].son[1]; tb[node].son[1] ← Tree.Null;
tb[node].son[2] ← ReverseUpdateList[tb[node].son[2], ListItem]};
FreeNode[node];
RETURN [Exp[list, target]]};
NodeType: PROC [target: CSEIndex, t: Tree.Link] RETURNS [nType: CSEIndex] = {
subType: CSEIndex = NormalType[target];
WITH r: seb[subType] SELECT FROM
ref => {
rType: CSEIndex = UnderType[r.refType];
IF ~r.list AND (seb[rType].typeTag = any OR rType = typeANY) THEN
nType ← ReferentType[dataPtr.typeListANY]
ELSE {
IF ~r.list THEN Log.ErrorTree[typeClash, t];
nType ← rType}};
ENDCASE =>
IF subType = typeANY THEN nType ← ReferentType[dataPtr.typeListANY]
ELSE {Log.ErrorTree[typeClash, t]; nType ← typeANY};
RETURN};
-- control transfers
MiscXfer: PUBLIC PROC [node: Tree.Index, target: CSEIndex] RETURNS [val: Tree.Link] = {
SELECT tb[node].name FROM
new => val ← New[node, target];
signalx, errorx => val ← Signal[node];
create => val ← Create[node, target];
startx => val ← Start[node];
fork => val ← Fork[node, target];
joinx => val ← Join[node];
cons => val ← Cons[node, target];
listcons => val ← ListCons[node, target];
ENDCASE => {Log.Error[unimplemented]; val ← [subtree[node]]};
RETURN};
MakeFrameRecord: PUBLIC PROC [t: Tree.Link] RETURNS [rSei: CSEIndex] = {
bti: CBTIndex = XferBody[t];
IF bti # CBTNull THEN {
argType: SEIndex = TransferTypes[bb[bti].ioType].typeIn;
rSei ← IF bb[bti].type # RecordSENull AND argType = SENull
THEN bb[bti].type
ELSE AllocFrameRecord[bti, argType]}
ELSE {Log.Error[nonTypeCons]; rSei ← typeANY};
RETURN};
AllocFrameRecord: PROC [bti: CBTIndex, link: SEIndex] RETURNS [sei: RecordSEIndex] = {
sei ← LOOPHOLE[MakeNonCtxSe[SERecord.cons.record.linked.SIZE]];
seb[sei] ← SERecord[mark3: TRUE, mark4: FALSE,
body: cons[record[
machineDep: FALSE,
painted: TRUE, argument: FALSE,
hints: [
unifield: FALSE, variant: FALSE,
assignable: FALSE, comparable: FALSE, privateFields: TRUE,
refField: TRUE, default: FALSE, voidable: FALSE],
fieldCtx: bb[bti].localCtx,
length: IF bb[bti].type # RecordSENull THEN seb[bb[bti].type].length ELSE 0,
monitored: bb[bti].monitored,
linkPart: linked[link]]]];
RETURN};
XferBody: PROC [t: Tree.Link] RETURNS [bti: CBTIndex] = {
sei: ISEIndex;
type: CSEIndex;
WITH t SELECT FROM
symbol => {
sei ← index; type ← UnderType[seb[sei].idType];
bti ← WITH seb[type] SELECT FROM
transfer =>
IF ~seb[sei].immutable
THEN CBTNull
ELSE
SELECT mode FROM
program =>
IF seb[sei].mark4
THEN (IF seb[sei].constant THEN seb[sei].idInfo ELSE CBTNull)
ELSE RootBti,
proc =>
IF sei = bb[dataPtr.bodyIndex].id THEN dataPtr.bodyIndex ELSE CBTNull,
ENDCASE => CBTNull,
ENDCASE => CBTNull};
ENDCASE => bti ← CBTNull;
RETURN};
XferForFrame: PUBLIC PROC [ctx: CTXIndex] RETURNS [type: CSEIndex ← CSENull] = {
bti: BTIndex ← BTIndex.FIRST;
btLimit: BTIndex = (dataPtr.table).Top[bodyType];
UNTIL bti = btLimit DO
WITH entry: bb[bti] SELECT FROM
Callable => {
IF entry.localCtx = ctx THEN RETURN [UnderType[entry.ioType]];
bti ← bti + (WITH entry SELECT FROM
Inner => BodyRecord.Callable.Inner.SIZE,
Catch => BodyRecord.Callable.Catch.SIZE,
ENDCASE => BodyRecord.Callable.Outer.SIZE)};
ENDCASE => bti ← bti + BodyRecord.Other.SIZE;
ENDLOOP;
RETURN [CSENull]};
Create: PROC [node: Tree.Index, target: CSEIndex] RETURNS [val: Tree.Link] = {
subNode: Tree.Index;
val ← ForceApplication[tb[node].son[1]];
tb[node].son[1] ← Tree.Null; FreeNode[node];
subNode ← GetNode[val];
BEGIN OPEN tb[subNode];
type, mType, rType: CSEIndex;
attr: Attr;
CreateError: PROC = {Log.ErrorTree[typeClash, son[1]]; type ← typeANY};
name ← create; attr1 ← TRUE;
son[1] ← Exp[son[1], typeANY];
mType ← RType[]; attr ← RAttr[]; RPop[]; phraseNP ← SetNP[phraseNP];
WITH seb[mType] SELECT FROM
transfer =>
IF mode = program THEN
SELECT XferBody[son[1]] FROM
CBTNull => type ← mType;
RootBti => {
type ← IF seb[target].typeTag = ref
THEN MakeRefType[MakeFrameRecord[son[1]], target]
ELSE mType;
attr1 ← FALSE};
ENDCASE => CreateError[]
ELSE CreateError[];
ref => {
type ← mType; rType ← UnderType[refType];
WITH seb[rType] SELECT FROM
record =>
SELECT TRUE FROM
(ctxb[fieldCtx].level # lG) => CreateError[];
(seb[target].typeTag = transfer) => {
type ← XferForFrame[fieldCtx];
IF type = CSENull THEN {Log.Error[unimplemented]; type ← typeANY}};
ENDCASE;
ENDCASE => IF refType # typeANY THEN CreateError[]};
ENDCASE => IF mType = typeANY THEN type ← typeANY ELSE CreateError[];
IF son[2] # Tree.Null THEN {
Log.ErrorTree[noApplication, son[1]]; son[2] ← UpdateList[son[2], VoidExp]};
IF nSons > 2 THEN [] ← CatchPhrase[son[3]];
current.noXfers ← attr.noXfer ← FALSE; attr.const ← FALSE;
RPush[type, attr];
END;
RETURN};
Start: PROC [node: Tree.Index] RETURNS [Tree.Link] = {
subNode: Tree.Index;
subNode ← Apply[GetNode[ForceApplication[tb[node].son[1]]], typeANY, TRUE];
SELECT tb[subNode].name FROM
start, startx, apply => NULL;
ENDCASE => Log.ErrorTree[typeClash, tb[subNode].son[1]];
tb[node].son[1] ← Tree.Null; FreeNode[node];
RETURN [[subtree[subNode]]]};
Restart: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
subNode: Tree.Index;
type: CSEIndex;
val ← ForceApplication[tb[node].son[1]];
subNode ← GetNode[val];
BEGIN OPEN tb[subNode];
name ← tb[node].name; info ← tb[node].info;
son[1] ← Exp[son[1], typeANY]; type ← RType[]; RPop[];
phraseNP ← SetNP[phraseNP];
WITH seb[type] SELECT FROM
ref => NULL; -- a weak check for now
transfer =>
IF mode # program OR XferBody[son[1]] # CBTNull THEN Log.ErrorTree[typeClash, son[1]];
ENDCASE => IF type # typeANY THEN Log.ErrorTree[typeClash, son[1]];
IF son[2] # Tree.Null THEN {
Log.ErrorTree[noApplication, son[1]]; son[2] ← UpdateList[son[2], VoidExp]};
IF nSons > 2 THEN [] ← CatchPhrase[son[3]];
END;
current.noXfers ← FALSE;
tb[node].son[1] ← Tree.Null; FreeNode[node]; RETURN};
Fork: PROC [node: Tree.Index, target: CSEIndex] RETURNS [Tree.Link] = {
subNode: Tree.Index;
type: CSEIndex;
attr: Attr;
t: Tree.Link ← ForceApplication[tb[node].son[1]];
tb[node].son[1] ← Tree.Null; FreeNode[node];
subNode ← Apply[GetNode[t], typeANY, TRUE]; attr ← RAttr[]; RPop[];
SELECT tb[subNode].name FROM
call, callx => {
s: Tree.Link ← tb[subNode].son[1];
subType: CSEIndex;
IF OpName[s] = thread THEN {
s ← NthSon[s, 1]; Log.ErrorTree[misusedInline, s]};
IF current.lockHeld AND OperandInternal[s] THEN
Log.ErrorTree[internalCall, s];
subType ← OperandType[s];
WITH procType: seb[subType] SELECT FROM
transfer => {
type ← MakeNonCtxSe[SERecord.cons.transfer.SIZE];
seb[type] ← SERecord[mark3: TRUE, mark4: TRUE,
body: cons[transfer[
mode: process, safe: procType.safe,
typeIn: RecordSENull,
typeOut: procType.typeOut]]];
IF P3S.safety = checked THEN {
CheckArg: Tree.Map = {
argType: CSEIndex = OperandType[t];
subType: CSEIndex = NormalType[argType];
WITH s: seb[subType] SELECT FROM
ref => {IF s.var THEN Log.ErrorTree[unsafeOperation, t]; v ← t};
transfer => v ← CheckScope[t, argType];
ENDCASE => v ← t;
RETURN};
tb[subNode].son[1] ← CheckScope[s, subType];
tb[subNode].son[2] ← UpdateList[tb[subNode].son[2], CheckArg]}};
ENDCASE => ERROR;
tb[subNode].name ← fork};
apply => type ← typeANY;
ENDCASE => {Log.ErrorTree[typeClash, tb[node].son[1]]; type ← typeANY};
tb[subNode].info ← type; RPush[type, attr];
RETURN [[subtree[subNode]]]};
Join: PROC [node: Tree.Index] RETURNS [Tree.Link] = {
subNode: Tree.Index;
subNode ← Apply[GetNode[ForceApplication[tb[node].son[1]]], typeANY, TRUE];
SELECT tb[subNode].name FROM
join, joinx => NULL;
apply => NULL;
ENDCASE => Log.ErrorTree[typeClash, tb[subNode].son[1]];
tb[node].son[1] ← Tree.Null; FreeNode[node];
RETURN [[subtree[subNode]]]};
Wait: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
subNode: Tree.Index;
saveNP: NPUse;
IF ~current.lockHeld THEN Log.Error[misplacedMonitorRef];
subNode ← Apply[GetNode[ForceApplication[tb[node].son[1]]], typeANY, TRUE];
SELECT tb[subNode].name FROM
wait => NULL;
apply => NULL;
ENDCASE => Log.ErrorTree[typeClash, tb[subNode].son[1]];
tb[node].son[1] ← Tree.Null; FreeNode[node];
IF OperandLhs[tb[subNode].son[1]] = none THEN Log.ErrorTree[nonLHS, tb[subNode].son[1]];
[] ← FreeTree[tb[subNode].son[2]];
saveNP ← phraseNP;
tb[subNode].son[2] ← tb[subNode].son[1]; tb[subNode].son[1] ← CopyLock[];
phraseNP ← MergeNP[saveNP][phraseNP];
RETURN [[subtree[subNode]]]};
-- monitors
LockVar: PUBLIC PROC [t: Tree.Link] RETURNS [val: Tree.Link] = {
type, nType: CSEIndex;
desc: Strings.SubStringDescriptor;
sei: ISEIndex;
nDerefs: CARDINAL;
long, b: BOOL;
Dereference: PROC [type: CSEIndex] = {
PushTree[val]; PushNode[uparrow, 1]; SetInfo[type]; SetAttr[2, long];
val ← PopTree[]};
val ← Exp[t, typeANY]; long ← LongPath[val];
type ← RType[]; RPop[]; nDerefs ← 0;
DO
IF type = dataPtr.typeLOCK THEN {IF nDerefs # 0 THEN Dereference[type]; GO TO success};
type ← UnderType[TypeRoot[type]]; nType ← NormalType[type];
WITH seb[nType] SELECT FROM
record => {
IF monitored THEN {
desc ← ["LOCK"L, 0, ("LOCK"L).length];
[b, sei] ← SearchCtxList[EnterString[@desc], fieldCtx];
IF ~b THEN {Log.Error[noAccess]; sei ← dataPtr.seAnon};
PushTree[val]; PushSe[sei];
PushNode[IF nDerefs = 0 THEN dollar ELSE dot, 2];
SetInfo[dataPtr.typeLOCK]; SetAttr[2, long]; val ← PopTree[];
GO TO success};
GO TO failure};
ref => {
IF (nDerefs ← nDerefs + 1) > 63 THEN GO TO failure;
long ← seb[type].typeTag = long;
IF nDerefs > 1 THEN Dereference[type];
type ← UnderType[refType]};
ENDCASE => GO TO failure;
REPEAT
success => NULL;
failure => Log.ErrorTree[typeClash, val];
ENDLOOP;
IF OperandLhs[val] = none THEN Log.ErrorTree[nonLHS, val];
RETURN};
FindLockParams: PUBLIC PROC RETURNS [formal, actual: ISEIndex] = {
node: Tree.Index = GetNode[tb[passPtr.lockNode].son[1]];
found: BOOL;
IF node = Tree.NullIndex THEN formal ← actual ← ISENull
ELSE {
formal ← FirstId[node];
IF current.inputRecord = SENull THEN found ← FALSE
ELSE [found, actual] ← SearchCtxList[
seb[formal].hash,
seb[current.inputRecord].fieldCtx];
IF ~found THEN actual ← ISENull};
RETURN};
LambdaApply: PROC [t: Tree.Link, formal, actual: ISEIndex] RETURNS [v: Tree.Link] = {
BindFormal: PROC [sei: ISEIndex] RETURNS [Tree.Link] = {
RETURN [[symbol[index: IF sei = formal THEN actual ELSE sei]]]};
v ← BindTree[t, BindFormal];
[] ← UpdateTreeAttr[v];
RETURN};
CopyLock: PUBLIC PROC RETURNS [val: Tree.Link] = {
formal, actual: ISEIndex;
SELECT TRUE FROM
passPtr.lockNode = Tree.NullIndex => val ← Tree.Null;
tb[current.bodyNode].son[4] # Tree.Null =>
val ← LambdaApply[tb[current.bodyNode].son[4], ISENull, ISENull];
ENDCASE => {
[formal:formal, actual:actual] ← FindLockParams[];
IF formal # SENull THEN {
IF actual = SENull THEN {Log.ErrorSei[missingLock, formal]; actual ← dataPtr.seAnon};
IF ~Types.Assignable[
[dataPtr.ownSymbols, UnderType[seb[formal].idType]],
[dataPtr.ownSymbols, UnderType[seb[actual].idType]]] THEN
Log.ErrorSei[typeClash, actual]};
val ← LambdaApply[tb[passPtr.lockNode].son[2], formal, actual]};
RETURN};
-- signals
Signal: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
subNode: Tree.Index;
nodeTag: Tree.NodeName = tb[node].name;
subNode ← Apply[GetNode[ForceApplication[tb[node].son[1]]], typeANY, TRUE];
SELECT tb[subNode].name FROM
signal, signalx => tb[subNode].name ← nodeTag;
error, errorx => {
SELECT nodeTag FROM
signal, signalx => Log.ErrorTree[typeClash, tb[subNode].son[1]];
ENDCASE => NULL;
tb[subNode].name ← nodeTag};
apply => NULL;
ENDCASE => Log.ErrorTree[typeClash, tb[subNode].son[1]];
tb[node].son[1] ← Tree.Null; FreeNode[node];
RETURN [[subtree[subNode]]]};
ForceApplication: PROC [t: Tree.Link] RETURNS [Tree.Link] = {
IF OpName[t] = apply THEN RETURN [t];
PushTree[t]; PushTree[Tree.Null];
RETURN [MakeNode[apply, 2]]};
-- catch phrases
CatchPhrase: PUBLIC PROC [t: Tree.Link] RETURNS [unwindCaught: BOOL] = {
saveReachable: BOOL = current.reachable;
savePathNP: NPUse = pathNP;
saveSafety: Safety = P3S.safety;
enclosingSafe: BOOL = (saveSafety = checked);
entryNP, exitNP: NPUse;
CatchItem: Tree.Scan = {
node: Tree.Index = GetNode[t];
type: CSEIndex ← typeANY;
mixed, safe, error: BOOL ← FALSE;
saveIndex: CARDINAL = dataPtr.textIndex;
CatchLabel: Tree.Map = {
subType: CSEIndex;
v ← Exp[t, typeANY]; subType ← CanonicalType[RType[]]; RPop[];
entryNP ← SequenceNP[entryNP][phraseNP];
WITH t: seb[subType] SELECT FROM
transfer =>
IF t.mode = signal OR t.mode = error THEN {
IF type = typeANY THEN type ← subType
ELSE IF ~Types.Equivalent[
[dataPtr.ownSymbols, type], [dataPtr.ownSymbols, subType]] THEN
mixed ← TRUE;
IF t.safe THEN safe ← TRUE;
IF t.mode = error THEN error ← TRUE}
ELSE Log.ErrorTree[typeClash, v];
ENDCASE => IF subType # typeANY THEN Log.ErrorTree[typeClash, v];
RETURN};
dataPtr.textIndex ← tb[node].info;
tb[node].son[1] ← UpdateList[tb[node].son[1], CatchLabel];
IF mixed THEN type ← typeANY;
tb[node].son[2] ← CatchBody[
tb[node].son[2], type, safe OR (error AND enclosingSafe)];
IF tb[node].son[1] = Tree.Link[symbol[index: dataPtr.idUNWIND]] THEN {
unwindCaught ← TRUE;
IF current.entry AND ~current.unwindEnabled AND current.catchDepth = 0 THEN {
PushTree[tb[node].son[2]]; PushTree[CopyLock[]];
PushNode[unlock, 1]; SetInfo[dataPtr.textIndex];
tb[node].son[2] ← MakeList[2]}};
tb[node].info ← IF type # typeANY THEN type ELSE SENull;
dataPtr.textIndex ← saveIndex; RETURN};
CatchBody: PROC [body: Tree.Link, type: CSEIndex, safe: BOOL]
RETURNS [val: Tree.Link] = {
saveRecord: RecordSEIndex = current.resumeRecord;
saveFlag: BOOL = current.resumeFlag;
current.catchDepth ← current.catchDepth + 1;
WITH t: seb[type] SELECT FROM
transfer => {
current.resumeFlag ← t.mode = signal;
PushArgCtx[t.typeIn];
BumpArgRefs[ArgRecord[t.typeIn], TRUE];
PushArgCtx[current.resumeRecord ← ArgRecord[t.typeOut]];
ClearRefStack[]};
ENDCASE => {
current.resumeFlag ← FALSE; current.resumeRecord ← RecordSENull};
current.reachable ← TRUE; pathNP ← entryNP;
SELECT OpName[body] FROM
block, checked => SetSafety[SafetyAttr[GetNode[body]]];
ENDCASE;
IF safe AND P3S.safety = none THEN Log.Error[unsafeBlock];
val ← UpdateList[body, Stmt ! InsertCatchLabel => {IF catchSeen THEN RESUME}];
exitNP ← BoundNP[exitNP][pathNP];
WITH t: seb[type] SELECT FROM
transfer => {PopArgCtx[t.typeOut]; PopArgCtx[t.typeIn]};
ENDCASE;
current.catchDepth ← current.catchDepth - 1;
current.resumeRecord ← saveRecord; current.resumeFlag ← saveFlag;
SetSafety[saveSafety]; RETURN};
setLabel, continued: BOOL;
node: Tree.Index = GetNode[t];
SealRefStack[];
setLabel ← continued ← unwindCaught ← FALSE; entryNP ← exitNP ← none;
BEGIN
ENABLE InsertCatchLabel => {
IF ~catchSeen THEN {
setLabel ← TRUE; IF exit THEN continued ← TRUE;
SIGNAL InsertCatchLabel[catchSeen:TRUE, exit:exit]; RESUME}};
ScanList[tb[node].son[1], CatchItem];
IF tb[node].nSons > 1 THEN
tb[node].son[2] ← CatchBody[tb[node].son[2], typeANY, enclosingSafe];
END;
IF setLabel THEN {P3S.markCatch ← TRUE; P3S.continued ← continued};
UnsealRefStack[]; current.reachable ← saveReachable;
phraseNP ← exitNP; pathNP ← savePathNP; RETURN};
PushArgCtx: PROC [sei: CSEIndex] = {
ctx: CTXIndex = ArgCtx[sei];
IF ctx # CTXNull THEN {
ctxb[ctx].level ← current.level + current.catchDepth; PushCtx[ctx]}};
PopArgCtx: PROC [sei: CSEIndex] = {
ctx: CTXIndex = ArgCtx[sei];
IF ctx # CTXNull THEN {PopCtx[]; ctxb[ctx].level ← lZ}};
Resume: PROC [node: Tree.Index] = {
OPEN tb[node];
rSei: RecordSEIndex = current.resumeRecord;
IF ~current.resumeFlag THEN Log.Error[misplacedResume];
IF rSei # SENull AND son[1] = Tree.Null THEN {
n: CARDINAL ← 0;
BumpArgRefs[rSei, FALSE];
FOR sei: ISEIndex ← FirstCtxSe[seb[rSei].fieldCtx], NextSe[sei] UNTIL sei = SENull DO
n ← n+1;
IF n=1 AND seb[sei].hash = HTNull THEN Log.Error[illDefinedReturn];
PushSe[sei];
ENDLOOP;
son[1] ← MakeList[n]}
ELSE {
son[1] ← IF attr1 AND rSei # SENull
THEN Rhs[son[1], rSei]
ELSE MatchFields[rSei, son[1]];
RPop[];
pathNP ← SequenceNP[pathNP][phraseNP]};
current.reachable ← FALSE};
-- Rope identification (temporary)
CheckHash: PROC [hti: HTIndex, s: Strings.String] RETURNS [BOOL] = {
desc: Strings.SubStringDescriptor;
desc ← [base: s, offset: 0, length: s.length];
RETURN [FindString[@desc] = hti]};
TextRep: PUBLIC PROC [rType: SEIndex] RETURNS [form: TextForm ← text] = {
type: CSEIndex = UnderType[rType];
rope: STRING = "Rope"L;
ropeRep: STRING = "RopeRep"L;
textRep: STRING = "TextRep"L;
WITH se: seb[rType] SELECT FROM
id =>
IF CheckHash[se.hash, ropeRep] THEN form ← rope
ELSE IF CheckHash[se.hash, textRep] THEN form ← ropeText;
ENDCASE;
WITH t: seb[type] SELECT FROM
record =>
WITH c: ctxb[t.fieldCtx] SELECT FROM
included => IF ~CheckHash[mdb[c.module].moduleId, rope] THEN form ← text;
ENDCASE => form ← text;
ENDCASE => form ← text;
RETURN};
}.