-- file Pass3Xa.Mesa
-- last modified by Satterthwaite, December 17, 1979 1:46 PM
DIRECTORY
ComData: FROM "comdata"
USING [
ownSymbols, seAnon,
typeCHARACTER, typeCONDITION, typeINTEGER, typeStringBody],
Copier: FROM "copier" USING [CompleteContext],
InlineDefs: FROM "inlinedefs" USING [BITAND],
Log: FROM "log"
USING [Error, ErrorHti, ErrorN, ErrorNode, ErrorSei, ErrorTree],
P3: FROM "p3"
USING [
Attr, EmptyAttr, FullAttr, VoidAttr, NPUse, MergeNP, SetNP,
--And,-- ArrangeKeys, Bundling, CanonicalType, CatchPhrase,
CompleteRecord, DefaultInit, DefinedId, DiscriminatedType, Exp,
FieldId, ForceType, OperandType, PopCtx, PushCtx,
RAttr, RecordLhs, Rhs, RPop, RPush, RType, Span, TargetType,
TypeForTree, Unbundle, UpdateTreeAttr,
VariantUnionType, Voidable, VoidExp, VoidItem, XferForFrame],
Pass3: FROM "pass3"
USING [
currentBody, enclosingBody,
implicitAttr, implicitRecord, implicitType, lockHeld],
Symbols: FROM "symbols"
USING [bodyType, ctxType, seType,
HTIndex, SEIndex, ISEIndex, CSEIndex, ArraySEIndex, RecordSEIndex,
CTXIndex, CBTIndex,
HTNull, SENull, ISENull, CSENull, CTXNull, CBTNull,
lG, typeANY, typeTYPE],
SymbolOps: FROM "symbolops"
USING [
ConstantId, FindExtension, FirstVisibleSe, NextSe,
NormalType, TypeRoot, UnderType, VisibleCtxEntries, XferMode],
Table: FROM "table" USING [Base, Notifier],
Tree: FROM "tree"
USING [Index, Link, Map, NodeName, Scan, Null, NullIndex, treeType],
TreeOps: FROM "treeops"
USING [
FreeNode, FreeTree, GetNode, IdentityMap, ListHead, ListLength,
ListTail, MakeList, MakeNode, PopTree, PushList, PushTree,
PushProperList, PushNode, ScanList, SetAttr, SetInfo, TestTree,
UpdateList],
Types: FROM "types" USING [SymbolTableBase, Assignable];
Pass3Xa: PROGRAM
IMPORTS
Copier, InlineDefs, Log, P3, SymbolOps, TreeOps, Types,
dataPtr: ComData, passPtr: Pass3
EXPORTS P3 =
BEGIN
OPEN SymbolOps, TreeOps, P3;
And: PROCEDURE [Attr, Attr] RETURNS [Attr] = LOOPHOLE[InlineDefs.BITAND];
-- pervasive definitions from Symbols
SEIndex: TYPE = Symbols.SEIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
CSEIndex: TYPE = Symbols.CSEIndex;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
SENull: Symbols.SEIndex = Symbols.SENull;
typeANY: Symbols.CSEIndex = Symbols.typeANY;
CTXIndex: TYPE = Symbols.CTXIndex;
tb: Table.Base; -- tree base address (local copy)
seb: Table.Base; -- se table base address (local copy)
ctxb: Table.Base; -- context table base address (local copy)
bb: Table.Base; -- body table base address (local copy)
own: Types.SymbolTableBase;
ExpANotify: PUBLIC Table.Notifier =
BEGIN -- called by allocator whenever table area is repacked
seb ← base[Symbols.seType]; ctxb ← base[Symbols.ctxType];
bb ← base[Symbols.bodyType];
tb ← base[Tree.treeType];
own ← dataPtr.ownSymbols;
END;
-- parameter reference bookkeeping
phraseNP: PUBLIC NPUse;
-- tree manipulation utilities
WritableRef: PROCEDURE [t: Tree.Link] RETURNS [BOOLEAN] =
BEGIN
type: CSEIndex;
phraseNP ← SetNP[phraseNP];
type ← OperandType[t];
DO
type ← NormalType[type];
WITH t: seb[type] SELECT FROM
pointer => RETURN [~t.readOnly];
arraydesc => RETURN [~t.readOnly];
relative => type ← UnderType[t.offsetType];
ENDCASE => RETURN [TRUE];
ENDLOOP;
END;
OperandLhs: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [BOOLEAN] =
BEGIN
DO
WITH t SELECT FROM
symbol =>
BEGIN
sei: ISEIndex = index;
ctx: CTXIndex = seb[sei].idCtx;
IF ctx # Symbols.CTXNull
THEN
BEGIN
ctxb[ctx].varUpdated ← TRUE;
IF ctxb[ctx].level < passPtr.currentBody.level
THEN phraseNP ← SetNP[phraseNP];
END;
RecordLhs[sei];
RETURN [~seb[sei].immutable]
END;
subtree =>
BEGIN
node: Tree.Index = index;
IF node = Tree.NullIndex THEN RETURN [FALSE];
SELECT tb[node].name FROM
dot =>
RETURN [WritableRef[tb[node].son[1]]
AND (WITH tb[node].son[2] SELECT FROM
symbol => ~seb[index].immutable,
ENDCASE => FALSE)];
uparrow, dindex, seqindex =>
RETURN [WritableRef[tb[node].son[1]]];
reloc => RETURN [WritableRef[tb[node].son[2]]];
dollar =>
WITH tb[node].son[2] SELECT FROM
symbol =>
IF ~seb[index].immutable
THEN t ← tb[node].son[1]
ELSE RETURN [FALSE];
ENDCASE => RETURN [FALSE];
index, loophole, cast, openx, pad, chop => t ← tb[node].son[1];
cdot => t ← tb[node].son[2];
apply => RETURN [ListLength[tb[node].son[1]] = 1];
ENDCASE => RETURN [FALSE];
END;
ENDCASE => RETURN [FALSE];
ENDLOOP;
END;
LongPath: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [long: BOOLEAN] =
BEGIN
node: Tree.Index;
WITH t SELECT FROM
subtree =>
BEGIN node ← index;
IF node = Tree.NullIndex
THEN long ← FALSE
ELSE SELECT tb[node].name FROM
loophole, cast, openx, pad, chop =>
long ← LongPath[tb[node].son[1]];
ENDCASE
-- dot, uparrow, dindex, reloc, seqindex, dollar, index -- =>
long ← tb[node].attr2;
END;
ENDCASE => long ← FALSE;
RETURN
END;
OperandInline: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [BOOLEAN] =
BEGIN
bti: Symbols.CBTIndex;
SELECT XferMode[OperandType[t]] FROM
procedure =>
BEGIN
bti ← BodyForTree[t];
RETURN [bti # Symbols.CBTNull AND bb[bti].inline]
END;
ENDCASE => RETURN [FALSE]
END;
OperandInternal: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [BOOLEAN] =
BEGIN
node: Tree.Index;
WITH t SELECT FROM
symbol =>
BEGIN
sei: ISEIndex = index;
subNode: Tree.Index;
bti: Symbols.CBTIndex;
IF ~seb[sei].immutable THEN RETURN [FALSE];
IF seb[sei].mark4
THEN
BEGIN
IF ~seb[sei].constant THEN RETURN [FALSE];
bti ← seb[sei].idInfo;
RETURN [bti # Symbols.CBTNull AND bb[bti].internal]
END;
subNode ← seb[sei].idValue;
RETURN [WITH tb[subNode].son[3] SELECT FROM
subtree => tb[index].name = body AND tb[index].attr2,
ENDCASE => FALSE]
END;
subtree =>
BEGIN node ← index;
RETURN [SELECT tb[node].name FROM
dot, cdot, assignx => OperandInternal[tb[node].son[2]],
ifx =>
OperandInternal[tb[node].son[2]] OR OperandInternal[tb[node].son[3]],
ENDCASE => FALSE] -- should check casex, bindx also
END;
ENDCASE => RETURN [FALSE];
END;
-- expression list manipulation
KeyedList: PROCEDURE [t: Tree.Link] RETURNS [BOOLEAN] =
BEGIN RETURN [t # Tree.Null AND TestTree[ListHead[t], item]] END;
PopKeyList: PROCEDURE [nItems: CARDINAL] RETURNS [t: Tree.Link] =
BEGIN
t ← MakeList[nItems];
IF t = Tree.Null AND nItems # 0 THEN
BEGIN PushTree[t]; PushProperList[1]; t ← PopTree[] END;
RETURN
END;
CheckLength: PROCEDURE [t: Tree.Link, length: INTEGER] =
BEGIN
n: INTEGER = ListLength[t];
SELECT n FROM
= length => NULL;
> length => Log.ErrorN[listLong, n-length];
< length => Log.ErrorN[listShort, length-n];
ENDCASE;
END;
ContextComplete: PROCEDURE [ctx: CTXIndex] RETURNS [BOOLEAN] =
BEGIN
RETURN [WITH ctxb[ctx] SELECT FROM
simple => TRUE,
included => complete,
ENDCASE => FALSE]
END;
Safen: PROCEDURE [t: Tree.Link, type: CSEIndex] RETURNS [Tree.Link] =
BEGIN
PushTree[t];
WITH t SELECT FROM
subtree =>
SELECT tb[index].name FROM
construct, union, rowcons => NULL;
ENDCASE => BEGIN PushNode[safen, 1]; SetInfo[type] END;
ENDCASE => BEGIN PushNode[safen, 1]; SetInfo[type] END;
RETURN [PopTree[]]
END;
Defaultable: PROCEDURE [type: SEIndex] RETURNS [BOOLEAN] =
BEGIN
s, next: SEIndex;
FOR s ← type, next
DO
WITH seb[s] SELECT FROM
id =>
BEGIN
sei: ISEIndex = LOOPHOLE[s];
IF seb[sei].extended THEN RETURN [TRUE];
next ← seb[sei].idInfo;
END;
ENDCASE => RETURN [FALSE];
ENDLOOP;
END;
PadList: PROCEDURE [expList: Tree.Link, ctx: CTXIndex] RETURNS [Tree.Link] =
BEGIN
sei: ISEIndex;
added: BOOLEAN;
nFields: CARDINAL;
PushField: Tree.Map =
BEGIN
PushTree[t]; nFields ← nFields + 1; sei ← NextSe[sei];
RETURN [Tree.Null]
END;
sei ← FirstVisibleSe[ctx]; added ← FALSE; nFields ← 0;
[] ← FreeTree[UpdateList[expList, PushField]];
UNTIL sei = SENull
DO
IF ~(seb[sei].extended OR Defaultable[seb[sei].idType]) THEN EXIT;
PushTree[Tree.Null]; added ← TRUE; nFields ← nFields + 1;
sei ← NextSe[sei];
ENDLOOP;
IF added THEN PushProperList[nFields] ELSE PushList[nFields];
RETURN [PopTree[]]
END;
FieldDefault: PROCEDURE [sei: ISEIndex] RETURNS [v: Tree.Link] =
BEGIN
CheckOption: Tree.Scan =
BEGIN IF ~TestTree[t, void] THEN v ← IdentityMap[t] END;
v ← Tree.Null; ScanList[FindExtension[sei].tree, CheckOption]; RETURN
END;
MatchFields: PUBLIC PROCEDURE [record: RecordSEIndex, expList: Tree.Link, elisions: BOOLEAN]
RETURNS [val: Tree.Link] =
BEGIN
nFields: CARDINAL;
ctx: CTXIndex;
sei: ISEIndex;
attr: Attr;
first: BOOLEAN;
exitNP: NPUse;
EvaluateField: Tree.Map =
BEGIN
subAttr: Attr;
type: CSEIndex;
SELECT TRUE FROM
(t = Tree.Null) =>
BEGIN
IF ~elisions THEN Log.ErrorSei[elision, sei];
v ← IF seb[sei].extended THEN FieldDefault[sei]
ELSE DefaultInit[seb[sei].idType];
IF v = Tree.Null
THEN BEGIN subAttr ← VoidAttr; phraseNP ← none; type ← typeANY END
ELSE BEGIN subAttr ← UpdateTreeAttr[v]; type ← OperandType[v] END;
END;
TestTree[t, void] =>
BEGIN
IF ~elisions THEN Log.ErrorSei[elision, sei];
v ← Tree.Null; subAttr ← VoidAttr; phraseNP ← none; type ← typeANY;
[] ← FreeTree[t];
END;
ENDCASE =>
BEGIN
v ← Rhs[t, IF sei = SENull
THEN typeANY
ELSE TargetType[UnderType[seb[sei].idType]]];
subAttr ← RAttr[]; type ← RType[]; RPop[];
END;
IF v = Tree.Null AND elisions AND
~(IF seb[sei].extended
THEN VoidItem[FindExtension[sei].tree]
ELSE Voidable[seb[sei].idType])
THEN Log.ErrorSei[elision, sei];
IF ~subAttr.noXfer AND (~first OR ~seb[record].argument)
THEN v ← Safen[v, type];
attr ← And[attr, subAttr]; first ← FALSE;
exitNP ← MergeNP[exitNP][phraseNP];
IF sei # SENull THEN sei ← NextSe[sei];
RETURN
END;
KeyFillCheck: PROCEDURE [sei: ISEIndex] RETURNS [t: Tree.Link] =
BEGIN
IF elisions AND (seb[sei].extended OR Defaultable[seb[sei].idType])
THEN t ← Tree.Null
ELSE
BEGIN
Log.ErrorHti[omittedKey, seb[sei].hash];
t ← [symbol[index: dataPtr.seAnon]];
END;
RETURN
END;
IF record = SENull
THEN BEGIN CheckLength[expList, 0]; sei ← Symbols.ISENull END
ELSE
BEGIN
CompleteRecord[record];
IF ~ContextComplete[seb[record].fieldCtx]
THEN
BEGIN
IF seb[record].hints.privateFields THEN Log.Error[noAccess];
sei ← Symbols.ISENull;
END
ELSE
BEGIN
ctx ← seb[record].fieldCtx;
IF KeyedList[expList]
THEN
BEGIN
nFields ← ArrangeKeys[
expList,
ctx, FirstVisibleSe[ctx], Symbols.ISENull,
KeyFillCheck];
expList ← PopKeyList[nFields];
END
ELSE
BEGIN
nFields ← VisibleCtxEntries[ctx];
IF ListLength[expList] < nFields AND elisions
THEN expList ← PadList[expList, ctx];
CheckLength[expList, nFields];
END;
sei ← FirstVisibleSe[ctx];
END;
END;
attr ← FullAttr; first ← TRUE; exitNP ← none;
val ← UpdateList[expList, EvaluateField];
RPush[record, attr]; phraseNP ← exitNP; RETURN
END;
-- operators
Dot: PUBLIC PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
type, rType, nType: CSEIndex;
sei: ISEIndex;
fieldHti: Symbols.HTIndex;
op: Tree.NodeName;
matched, long: BOOLEAN;
attr: Attr;
nHits: CARDINAL;
nDerefs: CARDINAL;
son[1] ← Exp[son[1], typeANY]; type ← RType[]; attr ← RAttr[]; RPop[];
WITH son[2] SELECT FROM hash => fieldHti ← index; ENDCASE => ERROR;
op ← dollar; nDerefs ← 0; long ← LongPath[son[1]];
-- N.B. failure is avoided only by EXITing the following loop
DO
nType ← NormalType[type];
WITH seb[nType] SELECT FROM
record =>
BEGIN
[nHits, sei] ← FieldId[fieldHti, LOOPHOLE[nType, RecordSEIndex]];
SELECT nHits FROM
0 => IF Bundling[nType] = 0 THEN GO TO nomatch;
1 =>
BEGIN
son[2] ← [symbol[sei]];
rType ← UnderType[seb[sei].idType];
IF ~attr.const AND ConstantId[sei]
THEN BEGIN op ← cdot; attr.const ← TRUE END;
EXIT
END;
ENDCASE => GO TO ambiguous;
type ← Unbundle[LOOPHOLE[nType, RecordSEIndex]];
son[1] ← IF op = dot
THEN Dereference[son[1], type, long]
ELSE ForceType[son[1], type];
op ← dollar;
END;
pointer =>
BEGIN
IF (nDerefs ← nDerefs+1) > 255 THEN GO TO nomatch;
IF op = dot THEN son[1] ← Dereference[son[1], type, long];
long ← seb[type].typeTag = long; attr.const ← FALSE;
op ← dot; dereferenced ← TRUE; type ← UnderType[refType];
END;
definition =>
BEGIN
[matched, sei] ← DefinedId[fieldHti, nType];
IF matched THEN
BEGIN
op ← cdot;
son[2] ← Tree.Link[symbol[sei]];
rType ← type ← UnderType[seb[sei].idType];
attr.const ← ConstantId[sei]; long ← FALSE;
IF ctxb[seb[sei].idCtx].ctxType = imported THEN
WITH seb[type] SELECT FROM
pointer =>
BEGIN
rType ← UnderType[refType];
son[2] ← Dereference[son[2], rType, FALSE];
END;
ENDCASE;
EXIT
END;
GO TO nomatch;
END;
ENDCASE => GO TO nomatch;
REPEAT
nomatch =>
BEGIN
son[2] ← [symbol[dataPtr.seAnon]];
IF son[1] # son[2] AND fieldHti # Symbols.HTNull
THEN Log.ErrorHti[unknownField, fieldHti];
rType ← typeANY; attr ← EmptyAttr;
END;
ambiguous =>
BEGIN
Log.ErrorHti[ambiguousId, fieldHti];
son[2] ← [symbol[dataPtr.seAnon]];
rType ← typeANY; attr ← EmptyAttr;
END;
ENDLOOP;
name ← op; attr2 ← long; RPush[rType, attr];
END;
Dereference: PROCEDURE [t: Tree.Link, type: CSEIndex, long: BOOLEAN] RETURNS [Tree.Link] =
BEGIN
PushTree[t]; PushNode[uparrow, 1]; SetInfo[type]; SetAttr[2, long];
RETURN[PopTree[]]
END;
UpArrow: PUBLIC PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
type, nType: CSEIndex;
attr: Attr;
son[1] ← Exp[son[1], typeANY];
type ← RType[]; attr ← RAttr[]; RPop[]; attr.const ← FALSE;
DO
nType ← NormalType[type];
WITH seb[nType] SELECT FROM
pointer =>
BEGIN
dereferenced ← TRUE; RPush[UnderType[refType], attr];
attr2 ← seb[type].typeTag = long; EXIT
END;
record =>
BEGIN
IF Bundling[nType] = 0 THEN GO TO fail;
type ← Unbundle[LOOPHOLE[nType, RecordSEIndex]];
END;
ENDCASE => GO TO fail;
REPEAT
fail =>
BEGIN
IF type # typeANY THEN Log.ErrorTree[typeClash, son[1]];
RPush[type, attr];
END;
ENDLOOP;
END;
Apply: PUBLIC PROCEDURE [node: Tree.Index, target: CSEIndex, mustXfer: BOOLEAN] =
BEGIN OPEN tb[node];
opType, type, nType, subType: CSEIndex;
nDerefs: CARDINAL;
attr: Attr;
leftNP: NPUse;
desc, long: BOOLEAN;
ApplyError: PROCEDURE [warn: BOOLEAN] =
BEGIN
IF warn THEN Log.ErrorTree[noApplication, son[1]];
son[2] ← UpdateList[son[2], VoidExp];
RPush[typeANY, EmptyAttr];
END;
UniOperand: PROCEDURE RETURNS [valid: BOOLEAN] =
BEGIN
IF ~(valid ← ListLength[son[2]] = 1)
THEN
BEGIN
CheckLength[son[2], 1];
son[2] ← UpdateList[son[2], VoidExp]; RPush[typeANY, EmptyAttr];
END
ELSE IF KeyedList[son[2]] THEN Log.Error[keys];
RETURN
END;
IF son[1] # Tree.Null
THEN
BEGIN
WITH seb[target] SELECT FROM
union =>
BEGIN PushCtx[caseCtx];
son[1] ← Exp[son[1], typeANY]; PopCtx[];
END;
ENDCASE => son[1] ← Exp[son[1], typeANY];
opType ← RType[]; attr ← RAttr[]; leftNP ← phraseNP; RPop[];
IF opType = Symbols.typeTYPE
THEN type ← UnderType[TypeForTree[son[1]]];
END
ELSE
BEGIN
opType ← Symbols.typeTYPE;
SELECT seb[target].typeTag FROM
record => type ← TypeRoot[target];
array => type ← target;
ENDCASE =>
BEGIN type ← Symbols.CSENull; Log.ErrorNode[noTarget, node] END;
END;
nDerefs ← 0; desc ← FALSE; long ← LongPath[son[1]];
-- dereferencing/deproceduring loop
DO
nType ← NormalType[opType];
WITH seb[nType] SELECT FROM
mode =>
BEGIN
SELECT seb[type].typeTag FROM
record => Construct[node, LOOPHOLE[type, RecordSEIndex]];
array => RowCons[node, LOOPHOLE[type, Symbols.ArraySEIndex]];
enumerated, subrange, basic =>
IF UniOperand[]
THEN
BEGIN
son[1] ← FreeTree[son[1]];
son[1] ← Rhs[son[2], TargetType[type]];
son[2] ← Tree.Null; name ← check;
attr ← RAttr[]; RPop[]; RPush[type, attr];
END;
ENDCASE => ApplyError[type # Symbols.CSENull];
EXIT
END;
transfer =>
BEGIN
SELECT mode FROM
procedure =>
IF ~passPtr.lockHeld AND OperandInternal[son[1]]
THEN Log.ErrorTree[internalCall, son[1]];
program =>
IF BodyForTree[son[1]] # Symbols.CBTNull
THEN Log.ErrorTree[typeClash, son[1]];
ENDCASE;
son[2] ← MatchFields[inRecord, son[2], TRUE];
name ← SELECT mode FROM
procedure => callx,
port => portcallx,
process => joinx,
signal => signalx,
error => errorx,
program => startx,
ENDCASE => apply;
attr ← And[RAttr[], attr]; phraseNP ← MergeNP[leftNP][phraseNP];
RPop[];
IF mode = procedure THEN CheckInline[node, attr];
attr.noXfer ← attr.const ← FALSE; RPush[outRecord, attr];
phraseNP ← SetNP[phraseNP];
EXIT
END;
array =>
BEGIN
IF UniOperand[]
THEN
BEGIN
IF KeyedList[son[2]] THEN Log.Error[keys];
son[2] ← Rhs[son[2], TargetType[UnderType[indexType]]];
END;
attr ← And[RAttr[], attr]; phraseNP ← MergeNP[leftNP][phraseNP];
RPop[];
RPush[UnderType[componentType], attr];
IF mustXfer
THEN
BEGIN
opType ← RType[]; RPop[];
PushTree[son[1]]; PushTree[son[2]];
PushNode[IF desc THEN dindex ELSE index, 2];
SetInfo[opType]; SetAttr[2, long];
son[1] ← PopTree[]; son[2] ← Tree.Null;
IF nSons > 2 THEN Log.Error[misplacedCatch];
mustXfer ← FALSE; -- to avoid looping
END
ELSE
BEGIN
name ← IF desc THEN dindex ELSE index; attr2 ← long; EXIT
END;
END;
arraydesc =>
BEGIN
long ← seb[opType].typeTag = long;
opType ← UnderType[describedType]; attr.const ← FALSE; desc ← TRUE;
END;
pointer =>
SELECT TRUE FROM
basing =>
BEGIN
IF UniOperand[]
THEN
BEGIN
son[2] ← Rhs[son[2], typeANY];
subType ← CanonicalType[RType[]];
attr ← And[RAttr[], attr]; RPop[];
phraseNP ← MergeNP[leftNP][phraseNP];
WITH seb[subType] SELECT FROM
relative =>
BEGIN
IF ~Types.Assignable[
[own, UnderType[baseType]],
[own, opType]]
THEN Log.ErrorTree[typeClash, son[1]];
type ← UnderType[resultType];
END;
ENDCASE =>
BEGIN type ← typeANY;
IF subType # typeANY
THEN Log.ErrorTree[typeClash, son[2]];
END;
subType ← NormalType[type];
attr1 ← seb[subType].typeTag = arraydesc;
attr2 ← seb[opType].typeTag = long
OR seb[type].typeTag = long;
WITH seb[subType] SELECT FROM
pointer =>
BEGIN
dereferenced ← TRUE; type ← UnderType[refType];
END;
arraydesc => type ← UnderType[describedType];
ENDCASE;
attr.const ← FALSE; RPush[type, attr]; name ← reloc;
END;
EXIT
END;
(subType ← UnderType[refType]) = dataPtr.typeStringBody =>
BEGIN
IF UniOperand[]
THEN
BEGIN dereferenced ← TRUE;
son[2] ← Rhs[son[2], dataPtr.typeINTEGER];
attr ← And[RAttr[], attr]; RPop[];
phraseNP ← MergeNP[leftNP][phraseNP];
attr.const ← FALSE; RPush[dataPtr.typeCHARACTER, attr];
name ← seqindex; attr2 ← seb[opType].typeTag = long;
END;
EXIT
END;
ENDCASE =>
BEGIN
attr.const ← FALSE; dereferenced ← TRUE;
WITH seb[subType] SELECT FROM
record =>
IF ctxb[fieldCtx].level = Symbols.lG
THEN
BEGIN opType ← XferForFrame[fieldCtx];
son[1] ← ForceType[son[1], opType];
END
ELSE GO TO deRef;
ENDCASE => GO TO deRef;
EXITS
deRef =>
BEGIN
IF (nDerefs ← nDerefs+1) > 255 THEN GO TO fail;
long ← seb[opType].typeTag = long;
son[1] ← Dereference[son[1], subType, long];
opType ← subType;
END;
END;
record =>
BEGIN
IF nType = dataPtr.typeCONDITION
THEN
BEGIN
IF son[2] # Tree.Null
THEN Log.ErrorN[listLong, ListLength[son[2]]];
RPush[Symbols.CSENull, attr];
name ← wait; phraseNP ← SetNP[phraseNP];
EXIT
END;
IF Bundling[opType] = 0 THEN GO TO fail;
opType ← Unbundle[LOOPHOLE[opType, RecordSEIndex]];
son[1] ← ForceType[son[1], opType];
END;
ENDCASE => GO TO fail;
REPEAT
fail => ApplyError[opType#typeANY OR nDerefs#0];
ENDLOOP;
IF nSons > 2 THEN
BEGIN
saveNP: NPUse = phraseNP;
SELECT name FROM
callx, portcallx, signalx, errorx, startx, fork, joinx, wait, apply =>
NULL;
ENDCASE => Log.Error[misplacedCatch];
[] ← CatchPhrase[son[3]]; phraseNP ← MergeNP[saveNP][phraseNP];
END;
IF RType[] = Symbols.CSENull THEN
name ← SELECT name FROM
callx => call,
portcallx => portcall,
signalx => signal,
errorx => error,
startx => start,
joinx => join,
ENDCASE => name;
END;
Construct: PROCEDURE [node: Tree.Index, type: RecordSEIndex] =
BEGIN OPEN tb[node];
cType: CSEIndex ← type;
attr: Attr;
t: Tree.Link;
son[2] ← MatchFields[type, son[2], TRUE]; attr ← RAttr[]; RPop[];
WITH seb[type] SELECT FROM
linked =>
BEGIN name ← union; cType ← VariantUnionType[linkType] END;
ENDCASE =>
BEGIN
name ← construct;
IF hints.variant AND (t←ListTail[son[2]]) # Tree.Null
THEN cType ← DiscriminatedType[type, t];
END;
info ← cType; RPush[cType, attr];
END;
RowCons: PROCEDURE [node: Tree.Index, aType: Symbols.ArraySEIndex] =
BEGIN OPEN tb[node];
attr: Attr;
componentType: SEIndex = seb[aType].componentType;
iType: CSEIndex = UnderType[seb[aType].indexType];
cType: CSEIndex = TargetType[UnderType[componentType]];
exitNP: NPUse;
MapValue: Tree.Map =
BEGIN
type: CSEIndex;
subAttr: Attr;
SELECT TRUE FROM
(t = Tree.Null) =>
BEGIN
v ← DefaultInit[componentType];
IF v = Tree.Null
THEN BEGIN subAttr ← VoidAttr; phraseNP ← none; type ← typeANY END
ELSE BEGIN subAttr ← UpdateTreeAttr[v]; type ← OperandType[v] END;
END;
TestTree[t, void] =>
BEGIN
v ← Tree.Null; [] ← FreeTree[t];
subAttr ← VoidAttr; phraseNP ← none; type ← typeANY;
END;
ENDCASE =>
BEGIN
v ← Rhs[t, cType]; subAttr ← RAttr[]; type ← RType[]; RPop[];
END;
IF v = Tree.Null AND ~Voidable[componentType]
THEN Log.ErrorSei[elision, IF seb[componentType].seTag=id
THEN LOOPHOLE[componentType] ELSE dataPtr.seAnon];
IF ~subAttr.noXfer THEN v ← Safen[v, type];
exitNP ← MergeNP[exitNP][phraseNP]; attr ← And[attr, subAttr]; RETURN
END;
IF KeyedList[son[2]] OR
(son[2] = Tree.Null AND seb[TargetType[iType]].typeTag = enumerated)
THEN
BEGIN
keyType: CSEIndex = TargetType[iType];
vCtx: CTXIndex;
first, last: ISEIndex;
KeyFillCheck: PROCEDURE [sei: ISEIndex] RETURNS [t: Tree.Link] =
BEGIN
IF Defaultable[componentType]
THEN t ← Tree.Null
ELSE
BEGIN
Log.ErrorHti[omittedKey, seb[sei].hash];
t ← [symbol[index: dataPtr.seAnon]];
END;
RETURN
END;
WITH seb[keyType] SELECT FROM
enumerated =>
BEGIN
vCtx ← valueCtx;
IF ctxb[vCtx].ctxType = included
THEN Copier.CompleteContext[LOOPHOLE[vCtx], FALSE];
IF ~ContextComplete[vCtx]
THEN Log.Error[keys]
ELSE
BEGIN
[first, last] ← Span[iType];
IF first # Symbols.ISENull AND last # Symbols.ISENull
AND seb[first].idValue <= seb[last].idValue
THEN
son[2] ← PopKeyList[ArrangeKeys[
son[2],
valueCtx, first, NextSe[last],
KeyFillCheck]]
ELSE Log.Error[keys];
END;
END;
ENDCASE => Log.Error[keys];
END;
attr ← FullAttr; exitNP ← none;
son[2] ← UpdateList[son[2], MapValue];
name ← rowcons; info ← aType; RPush[aType, attr]; phraseNP ← exitNP;
END;
All: PUBLIC PROCEDURE [node: Tree.Index, target: CSEIndex] =
BEGIN OPEN tb[node];
t: Tree.Link = son[1];
l: CARDINAL = ListLength[t];
attr: Attr;
SELECT l FROM
0, 1 =>
BEGIN
WITH seb[target] SELECT FROM
array =>
BEGIN
cType: CSEIndex = TargetType[UnderType[componentType]];
SELECT TRUE FROM
(t = Tree.Null) =>
IF (son[1] ← DefaultInit[componentType]) = Tree.Null
THEN BEGIN attr ← VoidAttr; phraseNP ← none END
ELSE attr ← UpdateTreeAttr[son[1]];
TestTree[t, void] =>
BEGIN
son[1] ← Tree.Null; [] ← FreeTree[t];
attr ← VoidAttr; phraseNP ← none;
END;
ENDCASE =>
BEGIN son[1] ← Rhs[t, cType]; attr ← RAttr[]; RPop[] END;
IF son[1] = Tree.Null AND ~Voidable[componentType]
THEN Log.ErrorSei[elision, IF seb[componentType].seTag=id
THEN LOOPHOLE[componentType] ELSE dataPtr.seAnon];
attr.const ← FALSE;
END;
ENDCASE =>
BEGIN
Log.ErrorNode[noTarget, node];
son[1] ← VoidExp[son[1]]; attr ← EmptyAttr;
END;
END;
ENDCASE =>
BEGIN
Log.ErrorN[listLong, l-1];
son[1] ← UpdateList[son[1], VoidExp]; attr ← EmptyAttr;
END;
RPush[target, attr];
END;
CheckInline: PROCEDURE [node: Tree.Index, attr: Attr] =
BEGIN
bti: Symbols.CBTIndex = BodyForTree[tb[node].son[1]];
IF bti # Symbols.CBTNull AND bb[bti].inline THEN
WITH body: bb[bti].info SELECT FROM
Internal =>
BEGIN
PushTree[tb[node].son[1]];
PushTree[[subtree[index: body.thread]]];
PushNode[thread, 2]; SetInfo[passPtr.enclosingBody];
tb[node].son[1] ← PopTree[]; body.thread ← node;
tb[node].attr3 ← attr.noXfer AND attr.noAssign;
END;
ENDCASE => ERROR;
END;
BodyForTree: PROCEDURE [t: Tree.Link] RETURNS [Symbols.CBTIndex] =
BEGIN
sei: ISEIndex;
node, subNode: Tree.Index;
WITH t SELECT FROM
symbol =>
BEGIN sei ← index;
SELECT TRUE FROM
seb[sei].mark4 =>
RETURN [
IF seb[sei].constant THEN seb[sei].idInfo ELSE Symbols.CBTNull];
seb[sei].immutable =>
BEGIN
node ← seb[sei].idValue;
WITH tb[node].son[3] SELECT FROM
subtree =>
BEGIN subNode ← index;
IF tb[subNode].name = body THEN RETURN [tb[subNode].info];
END;
ENDCASE;
END;
ENDCASE;
END;
subtree =>
BEGIN node ← index;
SELECT tb[node].name FROM
cdot => RETURN [BodyForTree[tb[node].son[2]]];
ENDCASE;
END;
ENDCASE;
RETURN [Symbols.CBTNull]
END;
Assignment: PUBLIC PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
lhsType, rhsType: CSEIndex;
attr: Attr;
saveNP: NPUse;
son[1] ← Exp[son[1], typeANY]; saveNP ← phraseNP;
lhsType ← RType[]; attr ← RAttr[]; RPop[];
son[2] ← Rhs[son[2], TargetType[lhsType]];
IF seb[lhsType].typeTag = union
THEN
IF ~Types.Assignable[
[own, DiscriminatedType[typeANY, son[1]]],
[own, DiscriminatedType[typeANY, son[2]]]]
THEN Log.ErrorTree[typeClash, son[2]];
rhsType ← RType[]; attr ← And[RAttr[], attr]; RPop[];
attr.noAssign ← FALSE; phraseNP ← MergeNP[phraseNP][saveNP];
RPush[rhsType, attr];
IF ~OperandLhs[son[1]] THEN Log.ErrorTree[nonLHS, son[1]];
END;
Extract: PUBLIC PROCEDURE [node: Tree.Index] =
BEGIN OPEN tb[node];
type: CSEIndex;
ctx: CTXIndex;
sei: ISEIndex;
nL, nR: CARDINAL;
saveRecord: RecordSEIndex = passPtr.implicitRecord;
saveAttr: Attr = passPtr.implicitAttr;
saveNP: NPUse;
FillNull: PROCEDURE [ISEIndex] RETURNS [Tree.Link] =
BEGIN RETURN [Tree.Null] END;
PushItem: Tree.Map = BEGIN PushTree[t]; RETURN [Tree.Null] END;
Extractor: PROCEDURE [t: Tree.Link] RETURNS [BOOLEAN] = INLINE
BEGIN
RETURN [TestTree[t, apply] AND tb[GetNode[t]].son[1] = Tree.Null]
END;
AssignItem: Tree.Map =
BEGIN
saveType: CSEIndex = passPtr.implicitType;
IF t = Tree.Null
THEN v ← Tree.Null
ELSE
BEGIN
passPtr.implicitType ← IF sei = SENull
THEN typeANY
ELSE UnderType[seb[sei].idType];
IF Extractor[t]
THEN
BEGIN
subNode: Tree.Index = GetNode[t];
PushTree[tb[subNode].son[2]];
tb[subNode].son[2] ← Tree.Null; FreeNode[subNode];
PushTree[Tree.Null]; v ← MakeNode[extract, 2];
Extract[GetNode[v]];
END
ELSE
BEGIN
PushTree[t]; PushTree[Tree.Null]; v ← MakeNode[assign, 2];
Assignment[GetNode[v]]; RPop[];
END;
saveNP ← MergeNP[saveNP][phraseNP];
END;
IF sei # SENull THEN sei ← NextSe[sei];
passPtr.implicitType ← saveType; RETURN
END;
son[2] ← Exp[son[2], typeANY];
type ← RType[]; passPtr.implicitAttr ← RAttr[]; RPop[];
saveNP ← phraseNP;
IF type = SENull
THEN
BEGIN Log.ErrorTree[typeClash, son[2]];
type ← typeANY; nR ← 0; sei ← Symbols.ISENull;
END
ELSE
BEGIN
type ← TypeRoot[type];
WITH seb[type] SELECT FROM
record =>
BEGIN
CompleteRecord[LOOPHOLE[type, RecordSEIndex]];
IF ContextComplete[fieldCtx]
THEN
BEGIN
passPtr.implicitRecord ← LOOPHOLE[type, RecordSEIndex];
ctx ← fieldCtx; sei ← FirstVisibleSe[ctx];
nR ← VisibleCtxEntries[ctx];
END
ELSE
BEGIN Log.Error[noAccess];
type ← typeANY; nR ← 0; sei ← Symbols.ISENull;
END;
END;
ENDCASE =>
BEGIN
IF type # typeANY THEN Log.ErrorTree[typeClash, son[2]];
type ← typeANY; nR ← 0; sei ← Symbols.ISENull;
END;
END;
IF KeyedList[son[1]] AND type # typeANY
THEN
nL ← ArrangeKeys[
son[1],
ctx, FirstVisibleSe[ctx], Symbols.ISENull,
FillNull]
ELSE
BEGIN
nL ← ListLength[son[1]];
son[1] ← FreeTree[UpdateList[son[1], PushItem]];
IF nL > nR AND type # typeANY
THEN Log.ErrorN[listLong, nL-nR];
THROUGH (nL .. nR] DO PushTree[Tree.Null] ENDLOOP;
nL ← MAX[nL, nR];
END;
PushTree[UpdateList[MakeList[nR], AssignItem]];
PushNode[exlist, 1]; SetInfo[type]; son[1] ← PopTree[];
phraseNP ← saveNP;
passPtr.implicitRecord ← saveRecord; passPtr.implicitAttr ← saveAttr;
END;
END.