SaffronContextCreateCTImpl.Mesa
Copyright Ó 1987 by Xerox Corporation. All rights reserved.
Sturgis, July 15, 1987 12:56:40 pm PDT
Bill Jackson (bj) August 12, 1987 4:53:31 pm PDT
Lucy Hederman August 17, 1987 6:32:17 pm PDT
James Rauen, June 27, 1988 1:04:12 pm PDT
Last edited by: James Rauen August 25, 1988 4:29:38 pm PDT
This module contains the code to create context trees and type graphs, but it performs no analysis, nor does it contain any print routines.
DIRECTORY
BigCardinals USING [BigFromSmall, BigSubtract, TwoToTheNth],
BigIntegers USING [BigFromBigCARD, BigFromSmall, BigINT],
FS USING[ComponentPositions, Error, ExpandName, StreamOpen],
IO USING [Close, PutFR, rope, STREAM],
Rope USING [Cat, Equal, ROPE, Substr],
SaffronAG1aDef USING[TopmodulepProdData],
SaffronATDef USING [ DeclarationNode, DefBodyNode, ExpNode, InitializationNode, ModulePNode, ScopeNode, TopNode, TypeExpNode ],
SaffronBaseDef USING [CastIntegerValue, CompilerStateNode, MakeStaticBoolean, MakeStaticCharacter, MakeTrash, ProgramFragmentNode, ProgramGraphNode],
SaffronCentralDef USING[ParseOneStream],
SaffronContext USING [],
SaffronContextPrivateTypes,
SaffronErrorHandling USING [Error, Message, FatalError, InternalError],
SaffronGenericDef USING [IdNode, IdNodeBody],
SaffronPGDef USING [AddNestedCellToPFD, AddVarsCellToPFD, EmptyPFD, MakePGLoadIndirect, MakePGLoadLocal],
SaffronProgramGraphPrivateTypes USING [ParameterizedFieldDescriptorCell, ParameterizedFieldDescriptorCellBody, ParameterizedFieldDescriptorNodeBody],
SaffronTargetArchitecture USING [TargetArchitecture],
ThreeC4Support USING[GetReportStream],
VersionMap USING[MapAndNameList, MapList, ShortNameToNames],
VersionMapDefaults USING[GetMapList];
SaffronContextCreateCTImpl: CEDAR PROGRAM
IMPORTS BigCardinals, BigIntegers, FS, IO, Rope, SaffronBaseDef, SaffronCentralDef, SaffronErrorHandling, SaffronPGDef, ThreeC4Support, VersionMap, VersionMapDefaults
EXPORTS SaffronATDef, SaffronBaseDef, SaffronContext = BEGIN
OPEN
AT: SaffronATDef,
BC: BigCardinals,
BD: SaffronBaseDef,
EH: SaffronErrorHandling,
GEN: SaffronGenericDef,
PG: SaffronProgramGraphPrivateTypes,
PGD: SaffronPGDef,
PT: SaffronContextPrivateTypes,
TA: SaffronTargetArchitecture;
This module contains the code to create the context tree and type graph, but it performs no analysis, nor does it contain any print routines
Module Stuff
The need for delving into the root data structure is a hack. Since the parser returns a TopNode, the recursive function body that calls theis procedure should have been prepared to get a (boxed) TopNode, rather than a (boxed) ModulePNode.
ReadDefFile: PUBLIC PROC [ fname: Rope.ROPE ] RETURNS [ ModulePPTreeNode ] ~ {
actualFileName: Rope.ROPE;
data: IO.STREAM;
root: AT.TopNode;
rootData: SaffronAG1aDef.TopmodulepProdData;
reportStream: IO.STREAM ← ThreeC4Support.GetReportStream[];
[actualFileName, data] ← FindFile[fname];
IF data = NIL THEN
ERROR EH.FatalError[0, Rope.Cat["Failed to find ", actualFileName]];
SIGNAL EH.Message[Rope.Cat["Parsing from ", actualFileName]];
root ← NARROW [SaffronCentralDef.ParseOneStream[data, 0, reportStream]];
IO.Close[data];
rootData ← NARROW[root.data];
RETURN[ModulePPTreeVal[rootData.ModuleP]];
};
tries working directory then release. Adopts some code from Bill Jackson.
If the working directory succeeds, then returns a file name without any directory prefix.
If had to try the release, then returns a file name with directory prefix.
FindFile: PUBLIC PROC[short: Rope.ROPE, extension: Rope.ROPE ← NIL] RETURNS[fullName: Rope.ROPE, s: IO.STREAM ← NIL] =
BEGIN
fileName: Rope.ROPE;
mapList: VersionMap.MapList ~ VersionMapDefaults.GetMapList[$Symbols];
list: VersionMap.MapAndNameList;
IF ( extension = NIL ) THEN extension ← "Mesa";
fileName ← Rope.Cat[short, ".", extension];
IF ( (s ← FS.StreamOpen[fileName ! FS.Error => CONTINUE]) # NIL ) THEN RETURN[fileName, s];
list ← VersionMap.ShortNameToNames[mapList, Rope.Cat[short, ".", "BCD"]];
FOR p: VersionMap.MapAndNameList ← list, p.rest UNTIL p=NIL DO
remoteFileName: Rope.ROPE ~ p.first.name;
cp: FS.ComponentPositions;
package: Rope.ROPE;
src: Rope.ROPE;
fullFName: Rope.ROPE;
[fullFName, cp] ← FS.ExpandName[remoteFileName];
package ← Rope.Substr[fullFName, 0, cp.ext.start];
src ← Rope.Cat[package, extension];
IF ( (s ← FS.StreamOpen[src ! FS.Error => LOOP]) # NIL ) THEN RETURN[src, s];
ENDLOOP;
END;
Environments
EnvironmentNode: TYPE ~ REF EnvironmentNodeBody;
EnvironmentNodeBody: PUBLIC TYPE ~ PT.EnvironmentNodeBody;
IncludedFileCell: TYPE ~ REF IncludedFileCellBody;
IncludedFileCellBody: PUBLIC TYPE ~ PT.IncludedFileCellBody;
CreateEmptyEnvironment: PUBLIC PROC RETURNS [EnvironmentNode] ~ {
env: EnvironmentNode ← NEW[EnvironmentNodeBody ← [NIL, NIL]];
RETURN[env];
};
damages env and ifc
AddCompiledDefinitionsFileToEnvironment: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE, ct: ContextTreeNode] RETURNS [EnvironmentNode] ~ {
includedFileCell: IncludedFileCell ← NEW[IncludedFileCellBody ←
[fileName, NIL, ct, definitions[]]];
IF env.firstIncludedFile = NIL
THEN env.firstIncludedFile ← includedFileCell
ELSE env.lastIncludedFile.next ← includedFileCell;
env.lastIncludedFile ← includedFileCell;
RETURN[env];
};
AddCompiledImplementationFileToEnvironment: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE, ct: ContextTreeNode, pg: BD.ProgramGraphNode] RETURNS [EnvironmentNode] ~ {
includedFileCell: IncludedFileCell ← NEW[IncludedFileCellBody ←
[fileName, NIL, ct, implementation[pg]]];
IF env.firstIncludedFile = NIL
THEN env.firstIncludedFile ← includedFileCell
ELSE env.lastIncludedFile.next ← includedFileCell;
env.lastIncludedFile ← includedFileCell;
RETURN[env];
};
LookupCompiledFileInEnv: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE]
RETURNS [ContextTreeNode] ~ {
includedFileCell: IncludedFileCell ← env.firstIncludedFile;
WHILE includedFileCell # NIL DO
IF Rope.Equal[includedFileCell.fileName, fileName]
THEN RETURN [includedFileCell.contextTree]
ELSE includedFileCell ← includedFileCell.next;
ENDLOOP;
RETURN[NIL];
};
LookupInterfaceInEnv: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE, interfaceName: GEN.IdNode] RETURNS [TypeGraphNodeNode] = BEGIN
contextTree: ContextTreeNode ← LookupCompiledFileInEnv[env, fileName];
IF contextTree = NIL THEN ERROR EH.InternalError["Interface not found in environment"];
... look up in context ...
RETURN[FieldType[LookupNameInContextRib[interfaceName, contextTree.rib]]];
END;
LookupInterfaceInEnv: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE, interfaceName: Rope.ROPE] RETURNS [res: TypeGraphNodeNode] = BEGIN
contextTree: ContextTreeNode ← LookupCompiledFileInEnv[env, fileName];
IF contextTree = NIL THEN RETURN [NIL];
res ← LookupLocalName[contextTree.rib.lc, IdNodeFromRope[interfaceName]];
END;
IsCompiledFileInEnv: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE] RETURNS [BOOLEAN] ~ {
RETURN[LookupCompiledFileInEnv[env, fileName] # NIL];
};
declare as damaging env
FakeDamageEnvironment: PUBLIC PROC [env: EnvironmentNode] RETURNS [EnvironmentNode] = {RETURN[env]};
Interfaces
InterfaceTGN: TYPE = REF InterfaceTGNBody;
InterfaceTGNBody: PUBLIC TYPE = PT.InterfaceTGNBody;
this procedure must be called after forming the context tree that contains the body of the definitions file. i.e., the names occurring in the locally visible names must be the names one expects to see in the interface
It is a little bit of a crock at the moment, because I do not have the data structures quite like I would like them.
Note: Context trees have no modifiable data structures. Hence, this does not have to damage the context tree, nor share with the result.
CreateInterfaceFromContextTree: PUBLIC PROC [ct: ContextTreeNode, ns: NameSequenceNode]
RETURNS [in: InterfaceValNode] ~ {
entries: VisibleNames ← CreateEmptyVisibleNames[];
typeNames: VisibleNames ← ct.rib.lc.localNames; -- herein lies the crock
EnterOneName: PROC [name: GEN.IdNode, access: AccessValNode, value: REF ANY] ~ {
tgn: TypeGraphNodeNode ← NARROW[value]; -- check
RecordVisibleTypeName[entries, name, access, tgn];
};
GenVisibleNames[typeNames, EnterOneName];
RETURN[NEW [InterfaceValNodeBody ← [ns, entries, ct]]];
};
used to create an interfaceTGN whole hog
GenInterfaceEntries: PROC [in: InterfaceValNode,
for: PROC [GEN.IdNode, AccessValNode, TypeGraphNodeNode] ] ~ {
SeeOne: PROC [name: GEN.IdNode, access: AccessValNode, value: REF ANY] ~ {
for[name, access, NARROW[value]];
};
GenVisibleNames[in.entries, SeeOne];
};
LookupInterfaceEntry: PUBLIC PROC [in: InterfaceValNode, name: GEN.IdNode]
RETURNS [access: AccessValNode, tgn: TypeGraphNodeNode] ~ {
value: REF ANY;
[access, value] ← LookupVisibleTypeName[in.entries, name];
RETURN[access, NARROW[value]];
};
Context Trees
ContextTreeNode: TYPE ~ REF ContextTreeNodeBody;
ContextTreeNodeBody: PUBLIC TYPE ~ PT.ContextTreeNodeBody;
CTCell: TYPE = REF CTCellBody;
CTCellBody: PUBLIC TYPE = PT.CTCellBody;
ERROR: There needs to be a form of frozen context tree. In any case, the comment on CreateInterfaceFromContextTree is wrong. Either there is a way of freezing context trees, and it will be used on the way to forming an interface, so as to avoid the declaration of sharing, or we build up a list of context trees, and then form then at one blow. I prefer the latter. So, we need a new concept: ContextTreeSeq, the following ops: EmptyContextTree, FakeDamageContextTree, AddContextTree, and finally, FormContextTree which takes a ContextTreeSeq.
EmptyContextTree: PUBLIC PROC [ rib: ContextRibNode ] RETURNS [ ContextTreeNode ] ~ { RETURN[NEW [ContextTreeNodeBody ← [NIL, NIL, rib]]] };
(declared as damages ctn)
FakeDamageContextTree: PUBLIC PROC [ ctn: ContextTreeNode ] RETURNS [ ctnp: ContextTreeNode ] ~ { RETURN[ctn] };
(damages ctn)
AddSubContextTree: PUBLIC PROC [ ctn: ContextTreeNode, subCtn: ContextTreeNode ] RETURNS [ ctnp: ContextTreeNode ] ~ {
cell: CTCell ← NEW [CTCellBody←[subCtn, NIL]];
IF subCtn.rib.lc.parentRib # ctn.rib THEN
ERROR EH.InternalError["Parent rib of child context tree is not rib of parent context tree."];
IF ctn.firstSubTree = NIL THEN ctn.firstSubTree ← cell ELSE ctn.lastSubTree.next ← cell;
ctn.lastSubTree ← cell;
RETURN[ctn];
};
Rib: PUBLIC PROC [ctn: ContextTreeNode] RETURNS [ContextRibNode] = {
RETURN [ctn.rib];
};
Context Ribs
ContextRibNode: TYPE ~ REF ContextRibNodeBody;
ContextRibNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ContextRibNodeBody;
CompilerStateNode: TYPE ~ BD.CompilerStateNode;
FreezeLocalContext: PUBLIC PROC [ lc: LocalContextNode, contents: TypeGraphNodeNode ] RETURNS [ rib: ContextRibNode ] ~ {
lc.contents ← NEW[PT.LocalContextContentsBody ← [frozen[contents]]];
RETURN[NEW [ContextRibNodeBody ← [lc]]];
};
Local Contexts
LocalContextNode: TYPE ~ REF LocalContextNodeBody;
LocalContextNodeBody: PUBLIC TYPE ~ PT.LocalContextNodeBody;
LocalContextContents: TYPE = REF LocalContextContentsBody;
LocalContextContentsBody: TYPE = PT.LocalContextContentsBody;
CreateEmptyContext: PUBLIC PROC [parentRib: ContextRibNode, newFrame: BOOLEAN]
RETURNS [ LocalContextNode ] ~ {
lc: LocalContextNode ← NEW [LocalContextNodeBody ← [
parentRib: parentRib,
nestingDepthInFrame:
IF (parentRib = NIL) OR newFrame
THEN 0
ELSE parentRib.lc.nestingDepthInFrame + 1,
contents: NEW[PT.LocalContextContentsBody ← [unfrozen[]]]
]];
lc.unpaintedPaint ← IF parentRib = NIL
THEN CreateUnpaintedPaint[lc]
ELSE parentRib.lc.unpaintedPaint;
RETURN[lc];
};
ParentRib: PUBLIC PROC [lc: LocalContextNode] RETURNS [ContextRibNode] = BEGIN
RETURN [lc.parentRib];
END;
FakeDamageContext: PUBLIC PROC [lc: LocalContextNode] RETURNS [lcp: LocalContextNode] ~ {lcp ← lc};
CreateRootContextRib: PUBLIC PROC [ta: TA.TargetArchitecture] RETURNS [rootContextRib: ContextRibNode, top, bottom: TypeGraphNodeNode] = BEGIN
ws: BYTE ← ta.wordSize;
is: BYTE ← ta.integerSize;
lis: BYTE ← ta.longIntegerSize;
lc: LocalContextNode ← CreateEmptyContext[NIL, TRUE];
fl: FieldListNode ← CreateEmptyFieldList[];
AddBaseType[lc,fl, "ATOM",  NEW[PT.AtomTGNBody]];
AddBaseType[lc,fl, "BOOL",  NEW[PT.ElementTGNBody ← [base[boolean[]]]]];
AddBaseType[lc,fl, "BOOLEAN", NEW[PT.ElementTGNBody ← [base[boolean[]]]]];
AddBaseType[lc,fl, "CHAR",  NEW[PT.ElementTGNBody ← [base[character[]]]]];
AddBaseType[lc,fl, "CHARACTER", NEW[PT.ElementTGNBody ← [base[character[]]]]];
AddBaseType[lc,fl, "CONDITION",  NEW[PT.ConditionTGNBody]];
AddBaseType[lc,fl, "MONITORLOCK",  NEW[PT.MonitorlockTGNBody]];
AddBaseType[lc,fl, "STRING",  NEW[PT.StringTGNBody]];
AddBaseType[lc,fl, "REAL", NEW[PT.RealTGNBody ← [5, 8, 20]]];
   Name  Signed? nBits nUnusedBits 
AddIntegerBaseType[lc, fl, "CARDINAL", FALSE, lis, 0];
AddIntegerBaseType[lc, fl, "CARD16",  FALSE, 16, 0];
AddIntegerBaseType[lc, fl, "CARD32",  FALSE, 32, 0];
AddIntegerBaseType[lc, fl, "CARD64",  FALSE, 64, 0];
AddIntegerBaseType[lc, fl, "CARD",  ? ? ?];
AddIntegerBaseType[lc, fl, "DCARD",  ? ? ?];
AddIntegerBaseType[lc, fl, "NAT",  FALSE, is-1, 1];
AddIntegerBaseType[lc, fl, "NATURAL", FALSE, is-1, 1];
AddIntegerBaseType[lc, fl, "NAT15",  FALSE, 15, 1];
AddIntegerBaseType[lc, fl, "NAT31",  FALSE, 31, 1];
AddIntegerBaseType[lc, fl, "NAT63",  FALSE, 63, 1];
AddIntegerBaseType[lc, fl, "INT",  TRUE, lis-1, 0];
AddIntegerBaseType[lc, fl, "INTEGER", TRUE, is-1, 0];
AddIntegerBaseType[lc, fl, "INT16",  TRUE, 15, 0];
AddIntegerBaseType[lc, fl, "INT32",  TRUE, 31, 0];
AddIntegerBaseType[lc, fl, "INT64",  TRUE, 63, 0];
AddIntegerBaseType[lc, fl, "DINT",  ? ? ?];
AddIntegerBaseType[lc, fl, "BIT",  FALSE, 1, 0];
AddIntegerBaseType[lc, fl, "BYTE",  FALSE, 8, 0];
AddIntegerBaseType[lc, fl, "WORD",  FALSE, ws, 0];
BEGIN
ffl: FrozenFieldListNode ← FreezeFieldList[fl];
block: TypeGraphNodeNode ← CreateBlockTGN[lc, ffl].tgn;
[lc, top] ← CreateTopTGN[lc];
[lc, bottom] ← CreateBottomTGN[lc];
rootContextRib ← FreezeLocalContext[lc, block];
END;
END;
AddBaseType: PROC [lc: LocalContextNode, fl: FieldListNode, name: Rope.ROPE, body: REF ANY] = BEGIN
nameAsIdNode: GEN.IdNode ← NEW [GEN.IdNodeBody ← [name, 0, 0]];
position: PositionValNode ← NIL;
access: AccessValNode ← AccessValConst["public"];
tgn: TypeGraphNodeNode ← CreateTGN[lc, body];
namedTGN: TypeGraphNodeNode ← CreateTGN[lc, NEW[PT.NamedTGNBody ← [
name: nameAsIdNode,
access: AccessValConst["public"],
type: tgn,
default: NIL   -- is this right?
]]];
field: FieldNode ← CreateNamedTypeField[nameAsIdNode, position, access, namedTGN, NIL];
[] ← AppendFieldToFieldList[fl, field];
END;
AddIntegerBaseType: PROC [lc: LocalContextNode, fl: FieldListNode, name: Rope.ROPE, signed: BOOLEAN, nBits: CARDINAL, nUnusedBits: CARDINAL] = BEGIN
body: PT.ElementTGN ← NEW[PT.ElementTGNBody ←
[base[integer[[signed, nBits, nUnusedBits]]]]];
AddBaseType[lc, fl, name, body];
END;
Type Graph Nodes
TypeGraphNodeListNode: TYPE ~ REF TypeGraphNodeListNodeBody;
TypeGraphNodeListNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.TypeGraphNodeListNodeBody;
TypeGraphNodeNode: TYPE ~ REF TypeGraphNodeNodeBody;
TypeGraphNodeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.TypeGraphNodeNodeBody;
CreateTGN: PROC [ lc: LocalContextNode, body: REF ANY ]
RETURNS [ tgn: TypeGraphNodeNode ] ~ {
tgn ← NEW [TypeGraphNodeNodeBody ← [
shown: FALSE,
index: lc.maxTGNodeIndex + 1,
localContext: lc,
body: body,
next: lc.tgNodes]];
lc.maxTGNodeIndex ← tgn.index;
lc.tgNodes ← tgn;
};
FakeDamageTypeGraphNode: PUBLIC PROC [tgn: TypeGraphNodeNode] RETURNS [TypeGraphNodeNode] = BEGIN
RETURN [tgn];
END;
( FIX: This should be a procedure to be applied to a RIB,
we will change as soon as we get ribs )
FindBottomTGN: PUBLIC PROC [ lc: LocalContextNode ]
RETURNS [ tgn: TypeGraphNodeNode ] ~ {
RETURN[lc.bottom];
};
( FIX: This should be a procedure to be applied to a RIB,
we will change as soon as we get ribs )
FindTopTGN: PUBLIC PROC [ lc: LocalContextNode ]
RETURNS [ tgn: TypeGraphNodeNode ] ~ {
RETURN[lc.top];
};
( Upon reaching top level context,
then looks up names of frames and interfaces, then root context.
Must add this later. )
FindLocallyVisibleTGN: PUBLIC PROC [ lc: LocalContextNode, name: GEN.IdNode ]
RETURNS [ TypeGraphNodeNode ] ~ {
FOR lcx: LocalContextNode ← lc, lcx.rib.lc WHILE ( lcx # NIL ) DO
tgn: TypeGraphNodeNode ← NARROW[LookupVisibleTypeName[lcx.localNames, name].value];
IF tgn # NIL THEN RETURN[tgn];
IF lcx.rib = NIL THEN EXIT;
ENDLOOP;
ERROR EH.InternalError["Nothing found in SaffronContextCreateCTImpl.FindLocallyVisibleTGN"];
};
Locally Visible Names
Very simple for now, just a chained list of IdNodes
Values
ValueNode: TYPE = REF ValueNodeBody;
ValueNodeBody: PUBLIC TYPE = PT.ValueNodeBody;
MakeUnparsedValue: PUBLIC PROC [ node: AT.ExpNode ] RETURNS [ ValueNode ] ~ {
RETURN[NEW [ValueNodeBody ← [unparsed[node]]]];
};
MakeUnparsedNullValue: PUBLIC PROC RETURNS [ ValueNode ] = BEGIN
RETURN [NEW[ValueNodeBody ← [unparsed[NIL]]]];
END;
MakeDummy: PUBLIC PROC [r: Rope.ROPE] RETURNS [ValueNode] = BEGIN
RETURN [NEW[ValueNodeBody ← [dummy[r]]]];
END;
Specific Types and Values
Array
CreateArrayTGN: PUBLIC PROC [ lc: LocalContextNode, packed: BOOLEAN, indexType: TypeGraphNodeNode, itemType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.ArrayTGN ← NEW [PT.ArrayTGNBody ← [packed, indexType, itemType]];
RETURN[lc, CreateTGN[lc, body]];
};
Atom
Block
CreateBlockTGN: PUBLIC PROC [ lc: LocalContextNode, contents: FrozenFieldListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.BlockTGN ← NEW [PT.BlockTGNBody ← [contents]];
RETURN[lc, CreateTGN[lc, body]];
};
Bottom
CreateBottomTGN: PRIVATE PROC [lc: LocalContextNode] RETURNS [lcp: LocalContextNode, tgn: TypeGraphNodeNode] ~ {
This is only created once per compilation, by CreateRootContextRib.
body: PT.BottomTGN ← NEW [PT.BottomTGNBody];
RETURN[lc, CreateTGN[lc, body]];
};
Condition **
Descriptor **
CreateDescriptorTGN: PUBLIC PROC [ lc: LocalContextNode, readonly: BOOLEAN, itemType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.DescriptorTGN ← NEW [PT.DescriptorTGNBody ← [readonly, itemType]];
RETURN[lc, CreateTGN[lc, body]];
};
Element
CreateSubrangeTGN: PUBLIC PROC [ lc: LocalContextNode, subrangeOf: TypeGraphNodeNode, bounds: BoundsValNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] = BEGIN
body: PT.ElementTGN ← NEW [PT.ElementTGNBody ← [subrange[[subrangeOf, bounds.first, bounds.last]]]];
...fix the bounds!! -- right now, nothing distinguishes () from [], etc....
RETURN[lc, CreateTGN[lc, body]];
END;
CreateEmptyEnumTypeTGN: PUBLIC PROC [ lc: LocalContextNode, machineDependent: BOOLEAN ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.ElementTGN ← NEW [PT.ElementTGNBody ←
[base[enumerated[[machineDependent, GetUniquePaint[lc].p, NIL, NIL]]]]];
RETURN[lc, CreateTGN[lc, body]];
};
one of elementName or rep can be NIL
AppendElementToEnumTypeTGN: PUBLIC PROC [ lc: LocalContextNode, tgn: TypeGraphNodeNode, elementName: GEN.IdNode, rep: ValueNode ] RETURNS [ lcp: LocalContextNode ] ~ {
body: REF enumerated base PT.ElementTGNBody ← NARROW[tgn.body];
cell: PT.EnumElementCell ← NEW [PT.EnumElementCellBody ← [elementName, rep, NIL]];
IF body.body.lastElement = NIL
THEN body.body.firstElement ← cell
ELSE body.body.lastElement.next ← cell;
body.body.lastElement ← cell;
RETURN[lc];
};
First: PUBLIC PROC [tgn: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
WHILE ISTYPE[tgn.body, PT.NamedTGN] DO
tgn ← NARROW[tgn.body, PT.NamedTGN].type;
ENDLOOP;
WITH tgn.body SELECT FROM
e: REF subrange PT.ElementTGNBody =>
RETURN [e.body.firstElement];
e: REF boolean base PT.ElementTGNBody =>
RETURN [BD.MakeStaticBoolean[FALSE, tgn]];
e: REF character base PT.ElementTGNBody =>
RETURN [BD.MakeStaticCharacter[0C, tgn]];
e: REF enumerated base PT.ElementTGNBody =>
ERROR EH.InternalError["FIRST[enumerated type] not implemented"];
e: REF integer base PT.ElementTGNBody => {
typeList: TypeGraphNodeListNode ← NEW[TypeGraphNodeListNodeBody ← LIST[tgn]];
val: BigIntegers.BigINT ← IF e.body.signed
THEN BigIntegers.BigFromBigCARD[BC.TwoToTheNth[e.body.nBits], minus]
ELSE BigIntegers.BigFromSmall[0];
RETURN[BD.CastIntegerValue[val, typeList]];
};
ENDCASE => {
SIGNAL EH.Error[0, "Bad type passed to FIRST"];
RETURN [BD.MakeTrash[tgn]];
};
END;
Last: PUBLIC PROC [tgn: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
WHILE ISTYPE[tgn.body, PT.NamedTGN] DO
tgn ← NARROW[tgn.body, PT.NamedTGN].type;
ENDLOOP;
WITH tgn.body SELECT FROM
e: REF subrange PT.ElementTGNBody =>
RETURN [e.body.lastElement];
e: REF boolean base PT.ElementTGNBody =>
RETURN [BD.MakeStaticBoolean[TRUE, tgn]];
e: REF character base PT.ElementTGNBody =>
RETURN [BD.MakeStaticCharacter[377C, tgn]];
e: REF enumerated base PT.ElementTGNBody =>
ERROR EH.InternalError["LAST[enumerated type] not implemented"];
e: REF integer base PT.ElementTGNBody => {
typeList: TypeGraphNodeListNode ← NEW[TypeGraphNodeListNodeBody ← LIST[tgn]];
val: BigIntegers.BigINT ← BigIntegers.BigFromBigCARD[
BC.BigSubtract[
BC.TwoToTheNth[e.body.nBits],
BC.BigFromSmall[1]],
plus];
RETURN[BD.CastIntegerValue[val, typeList]];
};
ENDCASE => {
SIGNAL EH.Error[0, "Bad type passed to LAST"];
RETURN [BD.MakeTrash[tgn]];
};
END;
"Frame"
FindFrameTGN: PUBLIC PROC [ lc: LocalContextNode, id: GEN.IdNode ]
RETURNS [ tgn: TypeGraphNodeNode ] = BEGIN
ERROR EH.InternalError ["FindFrameTGN not implemented"];
END;
FindFrameTGN: PUBLIC PROC [ lc: LocalContextNode, id: GEN.IdNode ]
RETURNS [ tgn: TypeGraphNodeNode ] ~ {
tgn ← FindLocallyVisibleTGN[lc, id];
WITH tgn.body SELECT FROM
ftgn: FrameTGN => RETURN[tgn];
ENDCASE => ERROR;
};
Identifier
CreateIdentifierTGN: PUBLIC PROC [ lc: LocalContextNode, id: GEN.IdNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.IdentifierTGN ← NEW [PT.IdentifierTGNBody ← [id]];
RETURN[lc, CreateTGN[lc, body]];
};
Implementation
CreateImplementationTGN: PUBLIC PROC [ lc: LocalContextNode, cedar: BOOLEAN, transferType: TypeGraphNodeNode, locks, imports, exports, shares: Rope.ROPE ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.ImplementationTGN ← NEW [PT.ImplementationTGNBody ←
[cedar, program, locks, imports, exports, shares, transferType]];
RETURN[lc, CreateTGN[lc, body]];
};
Interface
CreateInterfaceTGN: PUBLIC PROC [ lc: LocalContextNode, cedar: BOOLEAN, locks, imports, shares: Rope.ROPE ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.InterfaceTGN ← NEW [PT.InterfaceTGNBody ←
[cedar, locks, imports, shares]];
RETURN[lc, CreateTGN[lc, body]];
};
InterfaceContents
CreateInterfaceContentsTGN: PUBLIC PROC [ lc: LocalContextNode, contents: FrozenFieldListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.InterfaceContentsTGN ← NEW [PT.InterfaceContentsTGNBody ← [contents]];
RETURN[lc, CreateTGN[lc, body]];
};
Link
List
CreateListTGN: PUBLIC PROC [ lc: LocalContextNode, readOnly: BOOLEAN, itemType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.ListTGN ← NEW [PT.ListTGNBody ← [readOnly, itemType]];
RETURN[lc, CreateTGN[lc, body]];
};
Long
CreateLongTGN: PUBLIC PROC [ lc: LocalContextNode,
underlyingType: TypeGraphNodeNode ]
RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.LongTGN ← NEW [PT.LongTGNBody ← [underlyingType]];
RETURN[lc, CreateTGN[lc, body]];
};
Monitorlock
Module
CreateModuleTGN: PUBLIC PROC [lc: LocalContextNode, contents: FrozenFieldListNode] RETURNS [LocalContextNode, TypeGraphNodeNode] = BEGIN
body: PT.ModuleTGN ← NEW [PT.ModuleTGNBody ← [contents]];
RETURN[lc, CreateTGN[lc, body]];
END;
SetModuleLocalContextContents: PUBLIC PROC [lc: LocalContextNode, tgn: TypeGraphNodeNode, ffl: FrozenFieldListNode] RETURNS [LocalContextNode] = BEGIN
two things: stuff fl into tgn, stuff tgn into lc.
moduleTGN: PT.ModuleTGN ← NARROW[tgn.body];
moduleTGN.ffl ← ffl;
lc.contents ← NEW[PT.LocalContextContentsBody ← [frozen[tgn]]];
RETURN [lc];
END;
Named
CreateNamedTGN: PUBLIC PROC [lc: LocalContextNode, name: GEN.IdNode, position: PositionValNode, access: AccessValNode, type: TypeGraphNodeNode, default: DefaultExpNode] RETURNS [LocalContextNode, TypeGraphNodeNode] = BEGIN
Creates a named type graph node AND adds a field to lc's field list.
body: PT.NamedTGN ← NEW[PT.NamedTGNBody ← [name, access, type, default]];
tgn: TypeGraphNodeNode ← CreateTGN[lc, body];
Right now, I'm using the same arguments for the field's position/access and the namedtgn's position/access. This should be fixed. No, I don't know how.
RETURN[lc, tgn];
END;
CreateNamedTGN: PUBLIC PROC [lc: LocalContextNode, name: GEN.IdNode, position: PositionValNode, access: AccessValNode, type: TypeGraphNodeNode, default: DefaultExpNode] RETURNS [LocalContextNode, TypeGraphNodeNode] = BEGIN
Creates a named type graph node AND adds a field to lc's field list.
body: PT.NamedTGN ← NEW[PT.NamedTGNBody ← [name, access, type, default]];
tgn: TypeGraphNodeNode ← CreateTGN[lc, body];
Right now, I'm using the same arguments for the field's position/access and the namedtgn's position/access. This should be fixed. No, I don't know how.
field: FieldNode ← CreateNamedTypeField[name, position, access, tgn];
[] ← AppendFieldToFieldList[LocalContextFields[lc], field];
SIGNAL EH.Message[Rope.Cat["Creating locally visible TGN named ", BD.RopeFromId[name]]];
RETURN[lc, tgn];
END;
CreateLocallyVisibleTGN: PUBLIC PROC [ lc: LocalContextNode, name: GEN.IdNode, access: AccessValNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: NamedTGN ← NEW [NamedTGNBody ← [name: name]];
SIGNAL EH.Message[Rope.Cat["Creating locally visible TGN named ", BD.RopeFromId[name]]];
tgn ← CreateTGN[lc, body];
RecordVisibleTypeName[lc.localNames, name, access, tgn];
RETURN[lc, tgn];
};
AddIdToRestrictionList: PUBLIC PROC [id: GEN.IdNode, tgn: TypeGraphNodeNode] RETURNS [TypeGraphNodeNode] = BEGIN
namedTGN: PT.NamedTGN ← NARROW[tgn.body];
namedTGN.restriction ← CONS [id, namedTGN.restriction];
RETURN [tgn];
END;
AddAllIdsToRestrictionList: PUBLIC PROC [tgn: TypeGraphNodeNode] RETURNS [TypeGraphNodeNode] = BEGIN
Requires: tgn is named tgn, tgn.body.type is interface tgn.
interface: PT.InterfaceTGN ← NARROW[NARROW[tgn.body, PT.NamedTGN].type.body];
write me!! --
RETURN[tgn];
END;
Opaque
BogusTypeExpPTree: PUBLIC PROC RETURNS [TypeExpPTreeNode] = BEGIN
There is no parse tree for opaque types, but we need something to stuff into an opaque type's FieldNode.parseTree slot.
RETURN [NIL];
END;
Pointer
CreatePointerTGN: PUBLIC PROC [ lc: LocalContextNode, ordered, base: BOOLEAN, bounds: BoundsValNode, readOnly: BOOLEAN, targetTgn: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.PointerTGN ← NEW [PT.PointerTGNBody ← [ordered, base, readOnly, bounds, targetTgn]];
RETURN[lc, CreateTGN[lc, body]];
};
Real
Record
CreateRecordTGN: PUBLIC PROC [ lc: LocalContextNode, paint: PaintNode, machineDependent, monitoredRecord: BOOLEAN, ffl: FrozenFieldListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.RecordTGN ← NEW [PT.RecordTGNBody ← [
paint, machineDependent, monitoredRecord, ffl]];
RETURN[lc, CreateTGN[lc, body]];
};
Ref
CreateRefTGN: PUBLIC PROC [ lc: LocalContextNode, machineDependent: BOOLEAN, contentsTgn: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
referent: PT.ReferentTGN ← NEW [PT.ReferentTGNBody ← [contentsTgn]];
body: PT.RefTGN ← NEW [PT.RefTGNBody ← [machineDependent, CreateTGN[lc, referent]]];
RETURN[lc, CreateTGN[lc, body]];
};
Referent
Relative
CreateRelativeTGN: PUBLIC PROC [ lc: LocalContextNode, base, pointer: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.RelativeTGN ← NEW [PT.RelativeTGNBody ← [base, pointer]];
RETURN[lc, CreateTGN[lc, body]];
};
Sequence
Specianated TGN
(we are either : 1) specializing a sequence or array of length 0, 2) discriminating a variant, 3) selecting an interface type.) There is one syntactic case in which we can't tell which until the data structures are completely built. ("foo[red]"), so we use this more general term for now.)
(Dan Swinehart selected the word Specianated, if you can't figure out what this word means, try another field.)
(underlying type must be a variant style record type, a sequence style record type, an array type with empty index domain, or an interface TGN.)
(In the case of a def file TGN we do the appropriate look up, as this case can be distinguished during this construction pass.)
(only one of expParameter and idParam will be non nil)
(This one might be the selection of a type from an interface)
CreateSpecianatedTGNUsingId: PUBLIC PROC [ lc: LocalContextNode, underlyingType: TypeGraphNodeNode, id: GEN.IdNode ] RETURNS [ lcp: LocalContextNode,
tgn: TypeGraphNodeNode ] ~ {
WITH underlyingType.body SELECT FROM
iftgn: InterfaceTGN => {
RETURN[lc, LookupTypeNameInInterfaceTGN[lc, id, underlyingType].tgn];
probably should be doing an access check here
};
ENDCASE => {
body: PT.SpecianatedTGN ← NEW [PT.SpecianatedTGNBody ← [NIL, id, underlyingType]];
RETURN[lc, CreateTGN[lc, body]];
};
body: PT.SpecianatedTGN ← NEW [PT.SpecianatedTGNBody ← [NIL, id, underlyingType]];
RETURN[lc, CreateTGN[lc, body]];
};
(this one can not be the selection of a type from an interface)
CreateSpecianatedTGNUsingExp: PUBLIC PROC [ lc: LocalContextNode, underlyingType: TypeGraphNodeNode, parameter: ValueNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.SpecianatedTGN ← NEW [PT.SpecianatedTGNBody ← [parameter, NIL, underlyingType]];
RETURN[lc, CreateTGN[lc, body]];
};
String
Transfer
CreateTransferTGN: PUBLIC PROC [ lc: LocalContextNode, safe: BOOLEAN, modeName: Rope.ROPE, arguments, results: FrozenFieldListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
mode: PT.TransferMode ← SELECT TRUE FROM
Rope.Equal["proc", modeName] => proc,
Rope.Equal["port", modeName] => port,
Rope.Equal["signal", modeName] => signal,
Rope.Equal["error", modeName] => error,
Rope.Equal["process", modeName] => process,
Rope.Equal["program", modeName] => program,
ENDCASE => ERROR;
body: PT.TransferTGN ← NEW [PT.TransferTGNBody ← [safe, mode, arguments, results]];
RETURN[lc, CreateTGN[lc, body]];
};
Top
CreateTopTGN: PRIVATE PROC [lc: LocalContextNode] RETURNS [lcp: LocalContextNode, tgn: TypeGraphNodeNode] ~ {
This is only created once per compilation, by CreateRootContextRib.
body: PT.TopTGN ← NEW [PT.TopTGNBody];
RETURN[lc, CreateTGN[lc, body]];
};
Unspecified
Var
CreateVarTGN: PUBLIC PROC [ lc: LocalContextNode, targetTgn: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.VarTGN ← NEW [PT.VarTGNBody ← [targetTgn]];
RETURN[lc, CreateTGN[lc, body]];
};
Variant Part and Union List
UnionListNode: TYPE ~ REF UnionListNodeBody;
UnionListNodeBody: PUBLIC TYPE ~ PT.UnionListNodeBody;
CreateVariantPartTGN: PUBLIC PROC [ lc: LocalContextNode, flavor: VariantFlavorNode, tagType: TypeGraphNodeNode, types: UnionListNode ]
RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.VariantPartTGN ← NEW [PT.VariantPartTGNBody ← [
flavor,
tagType,
FreezeUnionList[types]]];
RETURN[lc, CreateTGN[lc, body]];
};
IsVariantPartTGN: PROC [ tgn: TypeGraphNodeNode ] RETURNS [ BOOLEAN ] ~ {
WITH tgn.body SELECT FROM
vptgn: PT.VariantPartTGN => RETURN[TRUE];
ENDCASE => RETURN[FALSE];
};
GetVariantPartUnionList: PROC [ tgn: TypeGraphNodeNode ]
RETURNS [PT.FrozenUnionList] ~ {
WITH tgn.body SELECT FROM
vptgn: PT.VariantPartTGN => RETURN[vptgn.types];
ENDCASE => ERROR;
};
CreateEmptyUnionList: PUBLIC PROC RETURNS [ UnionListNode ] ~ {
RETURN[NEW [UnionListNodeBody ← [0, NIL, NIL]]];
};
damages ul
AppendToUnionList: PUBLIC PROC [ ul: UnionListNode, id: GEN.IdNode,
ffl: FrozenFieldListNode ] RETURNS [ ulnp: UnionListNode ] ~ {
newCell: PT.UnionListCell ← NEW [PT.UnionListCellBody ← [id, ffl, NIL]];
IF ( ul.first = NIL ) THEN ul.first ← newCell ELSE ul.last.next ← newCell;
ul.last ← newCell;
ul.nCells ← ul.nCells+1;
RETURN[ul];
};
damages ul, used internally
FreezeUnionList: PROC[ ul: UnionListNode ] RETURNS [PT.FrozenUnionList] ~ {
ful: PT.FrozenUnionList ← NEW [PT.FrozenUnionListBody[ul.nCells]];
cell: PT.UnionListCell ← ul.first;
FOR i: CARDINAL IN [0..ful.nTypes) DO
ful[i] ← [cell.id, cell.fields];
cell ← cell.next;
ENDLOOP;
RETURN[ful]
};
Zone
CreateZoneTGN: PUBLIC PROC [ lc: LocalContextNode, uncounted: BOOLEAN ]
RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: PT.ZoneTGN ← NEW [PT.ZoneTGNBody ← [uncounted]];
RETURN[lc, CreateTGN[lc, body]];
};
Top and Bottom
CreateTopAndBottom: PROC [ lc: LocalContextNode ] RETURNS [ top, bottom: TypeGraphNodeNode ] ~ {
topBody: SpecialTGN ← NEW [SpecialTGNBody ← [top]];
bottomBody: SpecialTGN ← NEW [SpecialTGNBody ← [bottom]];
top ← CreateTGN[lc, topBody];
bottom ← CreateTGN[lc, bottomBody];
};
Named nodes (i.e., locally visible)
AddVariableName: PUBLIC PROC [ lc: LocalContextNode, name: GEN.IdNode, access: AccessValNode, constant: BOOLEAN ] RETURNS [ lcp: LocalContextNode ] ~ {
Adds a variable name to the local context.
body: NamedTGN ← NEW [NamedTGNBody ← [name: name]];
SIGNAL EH.Message[Rope.Cat["Adding variable named ", BD.RopeFromId[name]]];
RecordVisibleVariableName[lc.localNames, name, access, constant];
RETURN[lc];
};
AddArcFromLVTGNToTGN: PUBLIC PROC [ lc: LocalContextNode, lvTgn: TypeGraphNodeNode, access: AccessValNode, tgn: TypeGraphNodeNode, default: DefaultExpNode ] RETURNS [ lcp: LocalContextNode ] ~ {
namedNode: NamedTGN ← NARROW[lvTgn.body];
namedNode.access ← access;
namedNode.type ← tgn;
namedNode.default ← default;
RETURN[lc];
};
AddArcFromLocalNameToInstance: PUBLIC PROC [ lc: LocalContextNode, id: GEN.IdNode, access: AccessValNode, instance: BD.InstanceNode ] RETURNS [ lcp: LocalContextNode ] ~ {
cell: VNCell ← LookupLocalName[lc.localNames, id];
WITH cell SELECT FROM
c: REF type VNCellBody  => ERROR;
c: REF constant VNCellBody => c.value ← instance;
c: REF variable VNCellBody => c.value ← instance;
ENDCASE;
RETURN[lc];
};
This routine should be checking access as it spins deeper
ResolveNamedNodes: PROC[tgn: TypeGraphNodeNode] RETURNS[TypeGraphNodeNode] =
BEGIN
x: TypeGraphNodeNode ← tgn;
WHILE TRUE DO
WITH x.body SELECT FROM
namedNode: PT.NamedTGN => x ← namedNode.type;
ENDCASE => RETURN[x];
ENDLOOP;
ERROR;
END;
pointer type nodes
base and pointer must both be pointerTGNs, base must have base = true
refs point to encapsulated types
List nodes
perhaps I could use record type constructors, except they are not set up for making cyclic types directly, and perhaps there are some special semantics associated with list types
EnumeratedType Nodes
CreateEmptyEnumTypeTGN: PUBLIC PROC [ lc: LocalContextNode, machineDependent: BOOLEAN ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: EnumTGN ← NEW [EnumTGNBody ← [machineDependent, GetUniquePaint[lc].p, NIL, NIL]];
RETURN[lc, CreateTGN[lc, body]];
};
one of elementName or rep can be NIL
AppendElementToEnumTypeTGN: PUBLIC PROC [ lc: LocalContextNode, tgn: TypeGraphNodeNode, elementName: GEN.IdNode, rep: ExpPTreeNode ] RETURNS [ lcp: LocalContextNode ] ~ {
body: EnumTGN ← NARROW[tgn.body];
cell: EnumElementCell ← NEW [EnumElementCellBody ← [elementName, rep, NIL]];
IF body.lastElement = NIL
THEN body.firstElement ← cell
ELSE body.lastElement.next ← cell;
body.lastElement ← cell;
RETURN[lc];
};
Field lists and frozen field lists
FieldNode: TYPE ~ REF FieldNodeBody;
FieldNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.FieldNodeBody;
FieldListNode: TYPE ~ REF FieldListNodeBody;
FieldListNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.FieldListNodeBody;
FrozenFieldListNode: TYPE ~ REF FrozenFieldListNodeBody;
FrozenFieldListNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.FrozenFieldListNodeBody;
FieldListCell: TYPE ~ SaffronContextPrivateTypes.FieldListCell;
CreateNamedField: PUBLIC PROC [ n: GEN.IdNode, pvn: PositionValNode, avn: AccessValNode, tgn: TypeGraphNodeNode, default: DefaultExpNode ] RETURNS [ f: FieldNode ] ~ { RETURN[NEW [FieldNodeBody ← [n, pvn, avn, tgn, default]]] };
CreateUnnamedField: PUBLIC PROC [ tgn: TypeGraphNodeNode, default: DefaultExpNode ] RETURNS [ f: FieldNode ] ~ { RETURN[NEW [FieldNodeBody ← [NIL, NIL, NIL, tgn, default]]] };
CreateEmptyFieldList: PUBLIC PROC RETURNS [ fl: FieldListNode ] ~ { RETURN[NEW [FieldListNodeBody ← [FALSE, 0, 0, NIL, NIL]]] };
AnyFieldList: PUBLIC PROC RETURNS [ fl: FieldListNode ] ~ { RETURN[NEW [FieldListNodeBody ← [TRUE, 0, 0, NIL, NIL]]] };
PrependCellToFieldList: PROC [ nFields: INT, cell: FieldListCell, fl: FieldListNode ] RETURNS [ flp: FieldListNode ] ~ {
IF fl.any THEN ERROR;
cell.next ← fl.firstCell;
fl.firstCell ← cell;
IF fl.lastCell = NIL THEN fl.lastCell ← cell;
fl.nFields ← fl.nFields + nFields;
fl.nCells ← fl.nCells + 1;
RETURN[fl];
};
AppendCellToFieldList: PROC [ fl: FieldListNode, nFields: INT, cell: FieldListCell ] RETURNS [ flp: FieldListNode ] ~ {
IF fl.any THEN ERROR;
IF fl.lastCell = NIL THEN fl.firstCell ← cell ELSE fl.lastCell.next ← cell;
fl.lastCell ← cell;
fl.nFields ← fl.nFields + nFields;
fl.nCells ← fl.nCells + 1;
RETURN[fl];
};
PrependFieldToFieldList: PUBLIC PROC [ f: FieldNode, fl: FieldListNode ] RETURNS [ flp: FieldListNode ] ~ {
cell: FieldListCell ← NEW [FieldListCellBody ← [f, NIL]];
RETURN[PrependCellToFieldList[1, cell, fl]];
};
AppendFieldToFieldList: PUBLIC PROC [ fl: FieldListNode, f: FieldNode ] RETURNS [ flp: FieldListNode ] ~ {
cell: FieldListCell ← NEW [FieldListCellBody ← [f, NIL]];
RETURN[AppendCellToFieldList[fl, 1, cell]];
};
PrependFFLToFieldList: PUBLIC PROC [ ffl: FrozenFieldListNode, fl: FieldListNode ] RETURNS [ flp: FieldListNode ] ~ {
cell: FieldListCell ← NEW [FieldListCellBody ← [ffl, NIL]];
RETURN[PrependCellToFieldList[ffl.nFields, cell, fl]];
};
AppendFFLToFieldList: PUBLIC PROC [ fl: FieldListNode, ffl: FrozenFieldListNode ] RETURNS [ flp: FieldListNode ] ~ {
cell: FieldListCell ← NEW [FieldListCellBody ← [ffl, NIL]];
RETURN[AppendCellToFieldList[fl, ffl.nFields, cell]];
};
ConcatFieldLists: PUBLIC PROC [ fl1, fl2: FieldListNode ] RETURNS [ fl: FieldListNode ] ~ {
IF fl1.any OR fl2.any THEN ERROR;
IF fl1.firstCell = NIL THEN RETURN[fl2];
IF fl2.firstCell = NIL THEN RETURN[fl1];
fl1.lastCell.next ← fl2.firstCell;
fl1.lastCell ← fl2.lastCell;
fl1.nFields ← fl1.nFields + fl2.nFields;
fl1.nCells ← fl1.nCells + fl2.nCells;
RETURN[fl1];
};
FreezeFieldList: PUBLIC PROC [ lc: LocalContextNode, fl: FieldListNode ] RETURNS [ lcp: LocalContextNode, ffl: FrozenFieldListNode ] ~ {
cell: FieldListCell ← fl.firstCell;
ffl ← NEW [FrozenFieldListNodeBody[fl.nCells]];
ffl.any ← fl.any;
ffl.nFields ← fl.nFields;
ffl.next ← lc.fieldLists;
lc.fieldLists ← ffl;
FOR I: CARDINAL IN [0..CARDINAL[fl.nCells]) DO
ffl[I] ← WITH cell.item SELECT FROM
f: FieldNode => [field, f.name, f.pvn, f.avn, f.tgn, f.default, NIL],
fflist: FrozenFieldListNode => [ffl, NIL, NIL, NIL, NIL, NIL, fflist],
ENDCASE => ERROR;
cell ← cell.next;
ENDLOOP;
FOR I: CARDINAL IN [0..ffl.nFields) DO
SELECT ffl[I].case FROM
field => IF IsVariantPartTGN[ffl[I].tgn] THEN {
IF I = (CARDINAL[ffl.nFields]-1) THEN ffl.variant ← TRUE
ELSE ERROR; -- variation allowed only in last field
};
ffl => IF ffl[I].ffl.variant THEN {
IF I = (CARDINAL[ffl.nFields]-1) THEN ffl.variant ← TRUE
ELSE ERROR; -- variation allowed only in last field
};
ENDCASE => ERROR;
ENDLOOP;
RETURN[lc, ffl];
};
Variant Flavors
VariantFlavorNode: TYPE ~ REF VariantFlavorNodeBody;
VariantFlavorNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.VariantFlavorNodeBody;
OverlaidVariantFlavorConst: PUBLIC PROC RETURNS [ VariantFlavorNode ] ~ { RETURN[NEW [overlaid VariantFlavorNodeBody ← [overlaid[]]]] };
ComputedVariantFlavorConst: PUBLIC PROC RETURNS [ VariantFlavorNode ] ~ { RETURN[NEW [computed VariantFlavorNodeBody ← [computed[]]]] };
VanillaVariantFlavorVal: PUBLIC PROC [ id: GEN.IdNode, position: PositionValNode, access: AccessValNode ] RETURNS [ VariantFlavorNode ] ~ { RETURN[NEW [vanilla VariantFlavorNodeBody ← [vanilla[id, position, access]]]] };
Sequence TGNs
SequenceTGN: TYPE ~ REF SequenceTGNBody;
SequenceTGNBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.SequenceTGNBody;
CreateSequenceTGN: PUBLIC PROC [ lc: LocalContextNode, packed: BOOLEAN, id: GEN.IdNode, position: PositionValNode, access: AccessValNode, tagType: TypeGraphNodeNode,
type: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode,
tgn: TypeGraphNodeNode ] ~ {
body: SequenceTGN ← NEW [SequenceTGNBody ← [packed, id, position, access, tagType, type]];
RETURN[lc, CreateTGN[lc, body]];
};
Descriptor TGN
Transfer TGN
Long TGN
Interface TGN
There are several ways to create interfaceTGNs. One is directly from an interface, using all the entries. (Corresponds to directory line without out a Using clause). Another is by putting the names in one at a time. (Used to implement a directory line with a Using clause.), The third is by a "renaming" Open clause entry.
When creating the first interfaceTGN within one module tot points to a particular second module, be sure to use the Link tgns inbetween. For a directory line without a Using clause, this is done by CreateInterfaceTGNFromInterface, but when a Using clause is involved, the recursive function is responsible.
CreateEmptyInterfaceTGN: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ {
body: InterfaceTGN ← NEW [InterfaceTGNBody ← [FALSE, CreateEmptyVisibleNames[]]];
RETURN[lc, CreateTGN[lc, body]];
};
damages lc
AddTGNToInterfaceTGN: PUBLIC PROC [lc: LocalContextNode, if: TypeGraphNodeNode, name: GEN.IdNode, access: AccessValNode, entryTgn: TypeGraphNodeNode]
RETURNS [lcp: LocalContextNode] ~ {
iftgn: InterfaceTGN ← NARROW[if.body];
IF entryTgn # NIL THEN RecordVisibleTypeName[iftgn.typeNames, name, access, entryTgn];
if entryTgn = NIL then we are in a Using clause and processing an entry point name rather than a type name, we should do nothing here, and later this case will go away when we correctly handle entry points.
RETURN[lc];
};
CreateInterfaceTGNFromInterface: PUBLIC PROC [lc: LocalContextNode, if: InterfaceValNode] RETURNS [lcp: LocalContextNode, ifTgn: TypeGraphNodeNode] ~ {
AddOne: PROC [name: GEN.IdNode, access: AccessValNode, entryTGN: TypeGraphNodeNode] ~ {
[] ← AddTGNToInterfaceTGN[lc, ifTgn, name, access, CreateLinkTGN[lc, entryTGN, if, name].ltgn];
};
ifTgn ← CreateEmptyInterfaceTGN[lc].tgn;
GenInterfaceEntries[if, AddOne];
RETURN[lc, ifTgn];
};
ExportLocallyVisibleTGN: PUBLIC PROC[lc: LocalContextNode, name: GEN.IdNode] RETURNS[AccessValNode, TypeGraphNodeNode] =
BEGIN
ratgn: REF ANY;
access: AccessValNode;
[access, ratgn] ← LookupVisibleName[lc.lvtn, name];
IF ratgn # NIL THEN RETURN[access, NARROW[ratgn]];
ErrorSignal[];
END;
LookupTypeNameInInterfaceTGN: PUBLIC PROC [ lc: LocalContextNode, id: GEN.IdNode, if: TypeGraphNodeNode ] RETURNS [ tgn: TypeGraphNodeNode ] ~ {
iftgn: InterfaceTGN ← NARROW[if.body];
refAnyTgn: REF ANY;
access: AccessValNode;
[access, refAnyTgn] ← LookupVisibleTypeName[iftgn.typeNames, id];
IF access^ = public OR (access^ = private AND iftgn.sharedAccess) THEN RETURN[NARROW[refAnyTgn]];
ERROR EH.InternalError[ "SaffronContextCreateCTImpl.LookupTypeNameInInterfaceTGN"];
};
GenPublicTypeNamesFromInterfaceTGN: PROC [ if: TypeGraphNodeNode,
for: PROC [ GEN.IdNode, TypeGraphNodeNode ] ] ~ {
iftgn: InterfaceTGN ← NARROW[if.body];
localFor: PROC [name: GEN.IdNode, access: AccessValNode, value: REF ANY] ~
BEGIN
IF access^ = public OR (access^ = private AND iftgn.sharedAccess) THEN for[name, NARROW[value]]
END;
GenVisibleNames[iftgn.typeNames, localFor];
};
(following two operations correspond to entries in an OPEN clause)
(OPEN name: interface)
RenameInterface: PUBLIC PROC [lc: LocalContextNode, name: GEN.IdNode, interface: TypeGraphNodeNode] RETURNS [lcp: LocalContextNode] ~ {RETURN[lc]};
RenameInterface: PUBLIC PROC [lc: LocalContextNode, name: GEN.IdNode, interface: TypeGraphNodeNode] RETURNS [lcp: LocalContextNode] ~ {
newTGN: TypeGraphNodeNode ← CreateLocallyVisibleTGN[lc, name, AccessValConst["private"]].tgn;
WITH interface.body SELECT FROM
itgn: InterfaceTGN => NULL;
ENDCASE => ERROR;
[] ← AddArcFromLVTGNToTGN[lc, newTGN, AccessValConst["private"], interface, DefaultExpVal["", SaffronInstance.MakeDummy["hi there"]]];
RETURN[lc];
};
(OPEN interface)
OpenInterface: PUBLIC PROC [ lc: LocalContextNode, interfaceTGN: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode ] ~ {RETURN[lc]};
OpenInterface: PUBLIC PROC [ lc: LocalContextNode, interfaceTGN: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode ] ~ {
OpenOneInterfaceTypeName: PROC [ name: GEN.IdNode, tgn: TypeGraphNodeNode ] ~ {
newTGN: TypeGraphNodeNode ← CreateLocallyVisibleTGN[lc, name, NEW[AccessValNodeBody←NotSureWhatItShouldBe]].tgn;
[] ← AddArcFromLVTGNToTGN[lc, newTGN, NEW[AccessValNodeBody←NotSureWhatItShouldBe], tgn, DefaultExpVal["", SaffronInstance.MakeDummy["hello"]]];
};
GenPublicTypeNamesFromInterfaceTGN[ResolveNamedNodes[interfaceTGN], OpenOneInterfaceTypeName];
RETURN[lc];
};
LinkTGN
damages lc
(currently might be called with NIL tgn, when in a Using clause and refering to a entry point, rather than a type)
CreateLinkTGN: PUBLIC PROC[lc: LocalContextNode, tgn: TypeGraphNodeNode, if: InterfaceValNode, itemName: GEN.IdNode] RETURNS[lcp: LocalContextNode, ltgn: TypeGraphNodeNode] =
BEGIN
IF tgn = NIL THEN RETURN[lc, NIL]; -- was a standin for an entry point
RETURN[lc, CreateTGN[lc, NEW[LinkTGNBody←[tgn, if, itemName]]]];
END;
Opaque TGNs
OpaqueTGN: TYPE = REF OpaqueTGNBody;
OpaqueTGNBody: PUBLIC TYPE = SaffronContextPrivateTypes.OpaqueTGNBody;
CreateOpaqueTGN: PUBLIC PROC[lc: LocalContextNode, paint: PaintNode, optSize: ValueNode] RETURNS[lcp: LocalContextNode, tgn: TypeGraphNodeNode ] =
BEGIN
body: OpaqueTGN ← NEW[OpaqueTGNBody←[paint, optSize]];
RETURN[lc, CreateTGN[lc, body]];
END;
Paint nodes
PaintNode: TYPE ~ REF PaintNodeBody;
PaintNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.PaintNodeBody;
CreateUnpaintedPaint: PROC [ lc: LocalContextNode ] RETURNS [ PaintNode ] ~ { RETURN[NEW [PaintNodeBody ← [lc, 0]]] };
GetUnpaintedPaint: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ lcp: LocalContextNode, p: PaintNode ] ~ { RETURN[lc, lc.unpaintedPaint] };
GetUniquePaint: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ lcp: LocalContextNode, p: PaintNode ] ~ {
lc.paintIndex ← lc.paintIndex + 1;
RETURN[lc, NEW [PaintNodeBody ← [lc, lc.paintIndex]]];
};
Locally Visible Names
VisibleNames: TYPE = SaffronContextPrivateTypes.VisibleNames;
CreateEmptyVisibleNames: PROC RETURNS [ vn: VisibleNames ] ~ {
vn ← NEW [VisibleNamesBody ← [NIL]];
RETURN[vn];
};
RecordVisibleTypeName: PROC [ vn: VisibleNames, name: GEN.IdNode, access: AccessValNode,
value: TypeGraphNodeNode ] ~ {
edited by jrr June 21, 1988 3:22:46 pm PDT
newCell: VNCell;
IF IsNameAlreadyUsed[vn, name] THEN
EH.ErrorFatalError[222, IO.PutFR["%g is multiply defined", IO.rope[BD.RopeFromId[name]]]];
newCell ← NEW[VNCellBody ← [name, access, vn.first, type[value]]];
vn.first ← newCell;
};
RecordVisibleVariableName: PROC [ vn: VisibleNames, name: GEN.IdNode, access: AccessValNode, constant: BOOLEAN ] ~ {
newCell: VNCell;
IF IsNameAlreadyUsed[vn, name] THEN
EH.ErrorFatalError[222, IO.PutFR["%g is multiply defined", IO.rope[BD.RopeFromId[name]]]];
IF constant
THEN newCell ← NEW[VNCellBody ← [name, access, vn.first, variable[NIL]]]
ELSE newCell ← NEW[VNCellBody ← [name, access, vn.first, constant[NIL]]];
vn.first ← newCell;
};
IsNameAlreadyUsed: PROC [vn: VisibleNames, name: GEN.IdNode] RETURNS [BOOLEAN] ~ BEGIN
Return TRUE if name is already used in vn, FALSE otherwise.
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
IF Rope.Equal[BD.RopeFromId[cell.id], BD.RopeFromId[name]] THEN RETURN[TRUE];
cell ← cell.next;
ENDLOOP;
RETURN[FALSE];
END;
LookupVisibleTypeName: PROC [vn: VisibleNames, name: GEN.IdNode] RETURNS [access: AccessValNode, value: TypeGraphNodeNode] ~ BEGIN
Look up name in vn. If name names a type, return its AccessValNode and type graph node. If name names a variable, raise a fatal error. If name does not appear in vn, return [NIL, NIL].
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
IF Rope.Equal[BD.RopeFromId[cell.id], BD.RopeFromId[name]] THEN
WITH cell SELECT FROM
foo: REF type VNCellBody =>
RETURN[cell.access, foo.type];
foo: REF variable VNCellBody =>
EH.ErrorFatalError[0, IO.PutFR["%g does not name a type", IO.rope[BD.RopeFromId[name]]]];
ENDCASE;
cell ← cell.next;
ENDLOOP;
RETURN[NIL, NIL];
END;
LookupVisibleVariableName: PROC [vn: VisibleNames, name: GEN.IdNode] RETURNS [access: AccessValNode, value: TypeGraphNodeNode] ~ BEGIN
Look up name in vn. If name names a type, return its AccessValNode and type graph node. If name names a variable, raise a fatal error. If name does not appear in vn, return [NIL, NIL].
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
IF Rope.Equal[BD.RopeFromId[cell.id], BD.RopeFromId[name]] THEN
WITH cell SELECT FROM
foo: REF type VNCellBody =>
RETURN[cell.access, foo.type];
foo: REF variable VNCellBody =>
EH.ErrorFatalError[0, IO.PutFR["%g does not name a type", IO.rope[BD.RopeFromId[name]]]];
ENDCASE;
cell ← cell.next;
ENDLOOP;
RETURN[NIL, NIL];
END;
LookupLocalName: PROC [vn: VisibleNames, name: GEN.IdNode] RETURNS [VNCell] ~ {
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
IF Rope.Equal[BD.RopeFromId[cell.id], BD.RopeFromId[name]] THEN RETURN[cell];
cell ← cell.next;
ENDLOOP;
ERROR EH.InternalError[IO.PutFR["Could not find locally visible name %g", IO.rope[BD.RopeFromId[name]]]];
};
GenVisibleNames: PUBLIC PROC [vn: VisibleNames,
for: PROC [name: GEN.IdNode, access: AccessValNode, value: REF ANY] ] ~ {
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
WITH cell SELECT FROM
foo: REF type VNCellBody => for[cell.id, cell.access, foo.type];
foo: REF variable VNCellBody => NULL;
ENDCASE;
cell ← cell.next;
ENDLOOP;
};
MapOntoLocalNames: PUBLIC PROC [vn: VisibleNames, typeProc: TypeProc, constantProc: ConstantProc, varProc: VarProc] ~ BEGIN
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
WITH cell SELECT FROM
foo: REF type VNCellBody => typeProc[cell.id, cell.access, foo.type];
foo: REF constant VNCellBody => constantProc[cell.id, cell.access, foo.value];
foo: REF variable VNCellBody => varProc[cell.id, cell.access, foo.value];
ENDCASE;
cell ← cell.next;
ENDLOOP;
END;
MapOntoAllVisibleNames: PUBLIC PROC [vn: VisibleNames, typeProc: TypeProc, constantProc: ConstantProc, varProc: VarProc] ~ BEGIN
cell: VNCell ← vn.first;
WHILE ( cell # NIL ) DO
WITH cell SELECT FROM
foo: REF type VNCellBody => typeProc[cell.id, cell.access, foo.type];
foo: REF constant VNCellBody => constantProc[cell.id, cell.access, foo.value];
foo: REF variable VNCellBody => varProc[cell.id, cell.access, foo.value];
ENDCASE;
cell ← cell.next;
ENDLOOP;
END;
Default Exp Nodes
DefaultExpNode: TYPE ~ REF DefaultExpNodeBody;
DefaultExpNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.DefaultExpNodeBody;
DefaultExpVal: PUBLIC PROC [ case: Rope.ROPE, exp: ExpPTreeNode ]
RETURNS [ DefaultExpNode ] ~ {
RETURN[NEW [DefaultExpNodeBody ← [
SELECT TRUE FROM
Rope.Equal[case, ""] => c1,
Rope.Equal[case, "←"] => c2,
Rope.Equal[case, "𡤎"] => c3,
Rope.Equal[case, "←TRASH"] => c4,
Rope.Equal[case, "𡤎|TRASH"] => c5,
ENDCASE => ERROR,
exp]]];
};
DefaultExpVal: PUBLIC PROC [case: Rope.ROPE, exp: ValueNode]
RETURNS [ DefaultExpNode ] ~ {
RETURN[NEW [DefaultExpNodeBody ← [
SELECT TRUE FROM
Rope.Equal[case, ""] => c1,
Rope.Equal[case, "←"] => c2,
Rope.Equal[case, "𡤎"] => c3,
Rope.Equal[case, "←TRASH"] => c4,
Rope.Equal[case, "𡤎|TRASH"] => c5,
ENDCASE => ERROR,
exp]]];
};
NullDefaultVal: PUBLIC PROC RETURNS [ DefaultExpNode ] ~ {
RETURN[NIL];
};
position val nodes
PositionValNode: TYPE ~ REF PositionValNodeBody;
PositionValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.PositionValNodeBody;
PositionValFun: PUBLIC PROC [ index: ValueNode, bounds: BoundsValNode ]
RETURNS [ PositionValNode ] ~ {
RETURN[NEW[PositionValNodeBody ← [index, bounds]]];
};
NullPosition: PUBLIC PROC RETURNS [ PositionValNode ] ~ {
RETURN[NIL];
};
bounds val nodes
BoundsValNode: TYPE ~ REF BoundsValNodeBody;
BoundsValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.BoundsValNodeBody;
BoundsValFun: PUBLIC PROC [ leftBracket: Rope.ROPE, first: ValueNode, last: ValueNode, rightBracket: Rope.ROPE ] RETURNS [ BoundsValNode ] ~ {
bvn: BoundsValNode ← NEW [BoundsValNodeBody ← [open, first, last, open]];
bvn.left ← SELECT TRUE FROM
Rope.Equal["[", leftBracket] => closed,
Rope.Equal["(", leftBracket] => open,
ENDCASE => ERROR;
bvn.right ← SELECT TRUE FROM
Rope.Equal["]", rightBracket] => closed,
Rope.Equal[")", rightBracket] => open,
ENDCASE => ERROR;
RETURN[bvn];
};
NullBounds: PUBLIC PROC RETURNS [ BoundsValNode ] ~ { RETURN[NIL] };
access val nodes
AccessValNode: TYPE ~ REF AccessValNodeBody;
AccessValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.AccessValNodeBody;
AccessValConst: PUBLIC PROC [ r: Rope.ROPE ] RETURNS [ AccessValNode ] ~ {
SELECT TRUE FROM
Rope.Equal[r, "empty"] => RETURN[NEW [AccessValNodeBody ← empty]];
Rope.Equal[r, "private"] => RETURN[NEW [AccessValNodeBody ← private]];
Rope.Equal[r, "public"] => RETURN[NEW [AccessValNodeBody ← public]];
ENDCASE => ERROR EH.InternalError[Rope.Cat["Bad argument (", r, ") to SaffronContextCreateCTImpl.AccessValConst"]];
};
NullAccessVal: PUBLIC PROC [ ] RETURNS [ AccessValNode ] ~ {
RETURN[NIL];
};
FakeCopyAccessVal: PUBLIC PROC [avn: AccessValNode] RETURNS [AccessValNode] ~ {
RETURN[avn];
};
ExpPTree
ExpPTreeNode: TYPE ~ REF ExpPTreeNodeBody;
ExpPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ExpPTreeNodeBody;
I can't remember why these boxes are needed (ExpPTree, ScopePTree, ...). Perhaps it is a flaw in the current version of ThreeCasabaFour.
exported to SaffronATDef??
ExpPTreeVal: PUBLIC PROC [ node: AT.ExpNode ] RETURNS [ ValueNode ] ~ {
RETURN[NEW [ValueNodeBody ← [unparsed[node]]]];
replaced by MakeUnparsedValue
};
NullExpPTree: PUBLIC PROC RETURNS [ ExpPTreeNode ] ~ { RETURN[NIL] };
replaced by MakeUnparsedNullValue
ScopePTree
ScopePTreeNode: TYPE ~ REF ScopePTreeNodeBody;
ScopePTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ScopePTreeNodeBody;
exported to SaffronATDef??
ScopePTreeVal: PUBLIC PROC [ node: AT.ScopeNode ] RETURNS [ ScopePTreeNode ] ~ { RETURN[NEW [ScopePTreeNodeBody ← [node]]] };
ScopeVal: PUBLIC PROC [ box: ScopePTreeNode ] RETURNS [ AT.ScopeNode ] ~ { RETURN[box.node] };
ModulePPTreeNode
ModulePPTreeNode: TYPE ~ REF ModulePPTreeNodeBody;
ModulePPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ModulePPTreeNodeBody;
ModulePPTreeVal: PUBLIC PROC [ node: AT.ModulePNode ]
RETURNS [ ModulePPTreeNode ] ~
{RETURN[NEW[ModulePPTreeNodeBody←[node]]]};
ModulePVal: PUBLIC PROC [ node: ModulePPTreeNode ] RETURNS [ AT.ModulePNode ] ~
{RETURN[node.node]};
DefBodyPTreeNode
DefBodyPTreeNode: TYPE ~ REF DefBodyPTreeNodeBody;
DefBodyPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.DefBodyPTreeNodeBody;
DefBodyPTreeVal: PUBLIC PROC [ node: AT.DefBodyNode ]
RETURNS [ DefBodyPTreeNode ] ~
{RETURN[NEW[DefBodyPTreeNodeBody←[node]]]};
DefBodyVal: PUBLIC PROC [ node: DefBodyPTreeNode ]
RETURNS [ AT.DefBodyNode ] ~
{RETURN[node.node]};
TypeExpPTreeNode
TypeExpPTreeNode: TYPE = REF TypeExpPTreeNodeBody;
TypeExpPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.TypeExpPTreeNodeBody;
TypeExpPTreeVal: PUBLIC PROC [ node: AT.TypeExpNode ]
RETURNS [ TypeExpPTreeNode ] ~
{RETURN[NEW[TypeExpPTreeNodeBody←[node]]]};
TypeExpVal: PUBLIC PROC [ node: TypeExpPTreeNode ]
RETURNS [ AT.TypeExpNode ] ~
{RETURN[node.node]};
InitializationPTreeNode
InitializationPTreeNode: TYPE = REF InitializationPTreeNodeBody;
InitializationPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.InitializationPTreeNodeBody;
InitializationPTreeVal: PUBLIC PROC [ node: AT.InitializationNode ]
RETURNS [ InitializationPTreeNode ] ~
{RETURN[NEW[InitializationPTreeNodeBody←[node]]]};
InitializationVal: PUBLIC PROC [ node: InitializationPTreeNode ]
RETURNS [ AT.InitializationNode ] ~
{RETURN[node.node]};
DeclarationPTreeNode
DeclarationPTreeNode: TYPE = REF DeclarationPTreeNodeBody;
DeclarationPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.DeclarationPTreeNodeBody;
DeclarationPTreeVal: PUBLIC PROC [ node: AT.DeclarationNode ]
RETURNS [ DeclarationPTreeNode ] ~
{RETURN[NEW[DeclarationPTreeNodeBody←[node]]]};
DeclarationVal: PUBLIC PROC [ node: DeclarationPTreeNode ]
RETURNS [ AT.DeclarationNode ] ~
{RETURN[node.node]};
NameSequence
NameSequenceNode: TYPE = REF NameSequenceNodeBody;
NameSequenceNodeBody: PUBLIC TYPE = SaffronContextPrivateTypes.NameSequenceNodeBody;
EmptyNameSequence: PUBLIC PROC RETURNS[NameSequenceNode] =
{RETURN[NEW[NameSequenceNodeBody ← NIL]]};
InsertNameOnNameSequence: PUBLIC PROC[name: GEN.IdNode, ns: NameSequenceNode] RETURNS[NameSequenceNode] =
{RETURN[NEW[NameSequenceNodeBody ← CONS[name, ns^]]]};
RopeNames
RopeNames: TYPE = REF RopeNamesBody;
RopeNamesBody: TYPE = SaffronContextPrivateTypes.RopeNamesBody;
RNCell: TYPE = REF RNCellBody; RNCellBody: TYPE = SaffronContextPrivateTypes.RNCellBody;
CreateEmptyRopeNames: PROC RETURNS[rns: RopeNames] =
BEGIN
rns ← NEW[RopeNamesBody ← [NIL]];
RETURN[rns];
END;
RecordRopeName: PROC[rns: RopeNames, name: Rope.ROPE, val: REF ANY] =
BEGIN
newCell: RNCell ← NEW[RNCellBody←[name, val, rns.first]];
IF (LookupRopeName[rns, name] # NIL) THEN ERROR EH.InternalError["SaffronContextCreateCTImpl.RecordRopeName"];
rns.first ← newCell;
END;
LookupRopeName: PROC[rns: RopeNames, name: Rope.ROPE] RETURNS[REF ANY] =
BEGIN
cell: RNCell ← rns.first;
WHILE cell # NIL DO
IF Rope.Equal[cell.name, name] THEN RETURN[cell.value];
cell ← cell.next;
ENDLOOP;
RETURN[NIL];
END;
GenRopeNames: PUBLIC PROC[rns: RopeNames, for: PROC[Rope.ROPE, REF ANY]] =
BEGIN
cell: RNCell ← rns.first;
WHILE cell # NIL DO
for[cell.name, cell.value];
cell ← cell.next;
ENDLOOP;
END;
following are exported to SaffronContext
ErrorSignal: PUBLIC ERROR ~ CODE;
Field Lists
Useful Types
FrozenFieldListNode: TYPE = REF FrozenFieldListNodeBody;
FrozenFieldListNodeBody: PUBLIC TYPE = PT.FrozenFieldListNodeBody;
FieldListNode: TYPE = REF FieldListNodeBody;
FieldListNodeBody: PUBLIC TYPE = PT.FieldListNodeBody;
FieldListCell: TYPE = REF FieldListCellBody;
FieldListCellBody: PUBLIC TYPE = PT.FieldListCellBody;
FieldNode: TYPE = REF FieldNodeBody;
FieldNodeBody: PUBLIC TYPE = PT.FieldNodeBody;
Field List Constructors
CreateEmptyFieldList: PUBLIC PROC RETURNS [FieldListNode] ~ {
RETURN[NEW [FieldListNodeBody ← [FALSE, FALSE, NIL, NIL]]] };
FakeDamageFieldList: PUBLIC PROC [fl: FieldListNode] RETURNS [FieldListNode] ~ {
RETURN[fl] };
AnyFieldList: PUBLIC PROC RETURNS [ fl: FieldListNode ] ~ { RETURN[NEW [FieldListNodeBody ← [FALSE, TRUE, NIL, NIL]]] };
AppendFieldToFieldList: PUBLIC PROC [fl: FieldListNode, f: FieldNode] RETURNS [flp: FieldListNode] = BEGIN
newCell: FieldListCell ← NEW [FieldListCellBody ← [f, NIL]];
IF (f.name # NIL) THEN FOR cell: FieldListCell ← fl.first, cell.next WHILE (cell # NIL) DO
IF Rope.Equal[cell.node.name.text, newCell.node.name.text] THEN {
SIGNAL EH.Error[newCell.node.name.position, IO.PutFR["%g is multiply defined", IO.rope[newCell.node.name.text]]];
RETURN [fl];
};
ENDLOOP;
IF fl.last = NIL
THEN fl.first ← newCell
ELSE fl.last.next ← newCell;
fl.last ← newCell;
RETURN [fl];
END;
FreezeFieldList: PUBLIC PROC [fl: FieldListNode] RETURNS [ffl: FrozenFieldListNode] = BEGIN
n: INT ← 0;
FOR cell: FieldListCell ← fl.first, cell.next WHILE (cell # NIL) DO n ← n + 1; ENDLOOP;
ffl ← NEW[FrozenFieldListNodeBody ← [FALSE, n, fl]];
END;
Field Constructors
Here are the different kinds of fields which can occur within a field list:
(1) Named types. For example, "Foo: TYPE = INT ← 3". These can only appear in the field lists of block tgn's.
(2) Constants. For example, "x: INT = 4". These can only appear in the field lists of block tgn's.
(3) Named fields. For example, "y: INT" or "z: INT ← 5". These can appear in the field lists of block tgn's or record tgn's.
(4) Unnamed fields. For example, "INT" or "INT ← 4". These can only appear in the field lists of record tgn's.
CreateNamedTypeField: PUBLIC PROC [name: GEN.IdNode, position: PositionValNode, access: AccessValNode, namedType: TypeGraphNodeNode, parseTree: TypeExpPTreeNode] RETURNS [FieldNode] = BEGIN
pt: AT.TypeExpNode ← IF parseTree = NIL THEN NIL ELSE parseTree.node;
RETURN[NEW[FieldNodeBody ← [name, position, typeDecl[access, namedType, pt]]]];
END;
CreateModuleField: PUBLIC PROC [name: GEN.IdNode, position: PositionValNode, tgn: TypeGraphNodeNode] RETURNS [FieldNode] = BEGIN
RETURN[NEW[FieldNodeBody ← [name, position, module[tgn]]]];
END;
CreateConstantField: PUBLIC PROC [name: GEN.IdNode, position: PositionValNode, declaration: DeclarationPTreeNode, access: AccessValNode, tgn: TypeGraphNodeNode, initialization: InitializationPTreeNode] RETURNS [FieldNode] = BEGIN
value: ValueNode ← initialization.procs.GetInitialValue[initialization.node];
RETURN[NEW[FieldNodeBody ← [name, position, constant[access, tgn, initialization, value, declaration]]]];
END;
CreateVariableField: PUBLIC PROC [name: GEN.IdNode, position: PositionValNode, declaration: DeclarationPTreeNode, access: AccessValNode, tgn: TypeGraphNodeNode, initialization: InitializationPTreeNode] RETURNS [FieldNode] = BEGIN
RETURN[NEW[FieldNodeBody ← [name, position, variable[access, tgn, initialization, declaration]]]];
END;
CreateNamedField: PUBLIC PROC [name: GEN.IdNode, position: PositionValNode, access: AccessValNode, tgn: TypeGraphNodeNode, default: DefaultExpNode] RETURNS [FieldNode] = BEGIN
RETURN[NEW[FieldNodeBody ← [name, position, recordField[access, tgn, default]]]];
END;
CreateUnnamedField: PUBLIC PROC [tgn: TypeGraphNodeNode, default: DefaultExpNode] RETURNS [FieldNode] = BEGIN
RETURN[NEW[FieldNodeBody ← [NIL, NIL, recordField[NIL, tgn, default]]]];
should have an access!!!!!!!!!!!!!!
END;
Operations on Fields
DemandTypeDeclarationField: PUBLIC PROC [f: FieldNode] RETURNS [AccessValNode, TypeGraphNodeNode] = BEGIN
WITH f SELECT FROM
ff: REF typeDecl FieldNodeBody => RETURN[ff.access, ff.type];
ENDCASE => ERROR EH.FatalError[f.name.position, IO.PutFR["%g does not name a type", IO.rope[f.name.text]]];
END;
DemandConstantField: PUBLIC PROC [f: FieldNode] RETURNS [AccessValNode, TypeGraphNodeNode, InitializationPTreeNode, ValueNode] = BEGIN
WITH f SELECT FROM
ff: REF constant FieldNodeBody => RETURN[ff.access, ff.type, ff.initialization, ff.value];
ENDCASE => ERROR EH.FatalError[f.name.position, IO.PutFR["%g does not name a constant", IO.rope[f.name.text]]];
END;
DemandConstantOrVariableField: PUBLIC PROC [f: FieldNode] RETURNS [AccessValNode, TypeGraphNodeNode, InitializationPTreeNode, BOOLEAN] = BEGIN
WITH f SELECT FROM
ff: REF constant FieldNodeBody => RETURN[ff.access, ff.type, ff.initialization, TRUE];
ff: REF variable FieldNodeBody => RETURN[ff.access, ff.type, ff.initialization, FALSE];
ENDCASE => ERROR EH.FatalError[f.name.position, IO.PutFR["%g does not name a constant or variable", IO.rope[f.name.text]]];
END;
FieldExists: PUBLIC PROC [f: FieldNode] RETURNS [BOOLEAN] = BEGIN
RETURN [f # NIL];
END;
FieldType: PUBLIC PROC [field: FieldNode] RETURNS [TypeGraphNodeNode] = BEGIN
RETURN [WITH field SELECT FROM
f: REF typeDecl FieldNodeBody => f.type,
f: REF module FieldNodeBody  => f.type,
f: REF constant FieldNodeBody => f.type,
f: REF variable FieldNodeBody => f.type,
f: REF recordField FieldNodeBody => f.type,
ENDCASE        => ERROR
];
END;
Looking Up Names
LookupNameInFieldList: PUBLIC PROC [fields: FieldListNode, name: GEN.IdNode] RETURNS [FieldNode] = BEGIN
FOR cell: FieldListCell ← fields.first, cell.next WHILE cell # NIL DO
IF Rope.Equal[cell.node.name.text, name.text] THEN RETURN [cell.node];
ENDLOOP;
RETURN [NIL];
END;
LookupNameInContextRib: PUBLIC PROC [name: GEN.IdNode, rib: ContextRibNode] RETURNS [FieldNode] = BEGIN
WHILE (rib # NIL) DO
ffl: FrozenFieldListNode ← ContextRibLocalFrozenFieldList[rib];
field: FieldNode ← LookupNameInFieldList[ffl.cells, name];
IF field # NIL THEN RETURN [field];
rib ← rib.lc.parentRib;
ENDLOOP;
RETURN [NIL];
END;
ContextRibLocalFrozenFieldList: PUBLIC PROC [rib: ContextRibNode] RETURNS [FrozenFieldListNode] = BEGIN
Return the frozen field list for the most deeply nested local context of rib.
RETURN[
WITH rib.lc.contents SELECT FROM
c: REF unfrozen LocalContextContentsBody =>
ERROR EH.InternalError["Rib containing unfrozen local context detected during lookup"],
c: REF frozen LocalContextContentsBody =>
WITH c.block.body SELECT FROM
block: REF PT.BlockTGNBody   => block.ffl,
module: REF PT.ModuleTGNBody  => module.ffl,
ic: REF PT.InterfaceContentsTGNBody => ic.ffl,
ENDCASE         =>
ERROR EH.InternalError["Illegal contents in local context"],
ENDCASE => ERROR
];
END;
Locally
LookupLocalName: PROC [lc: LocalContextNode, name: GEN.IdNode] RETURNS [FieldNode] = BEGIN
RETURN [LookupNameInFieldList[LocalContextFields[lc], name]];
END;
LookupNameInFieldList: PUBLIC PROC [fields: FieldListNode, name: GEN.IdNode] RETURNS [FieldNode] = BEGIN
FOR cell: FieldListCell ← fields.first, cell.next WHILE cell # NIL DO
IF Rope.Equal[cell.node.name.text, name.text] THEN RETURN [cell.node];
ENDLOOP;
RETURN [NIL];
END;
LocalContextFields: PROC [lc: LocalContextNode] RETURNS [FieldListNode] = BEGIN
WITH lc.contents SELECT FROM
c: REF unfrozen PT.LocalContextContentsBody => {
SIGNAL EH.Warning[0, "Tried to look up in an unfrozen l.c."];
RETURN [CreateEmptyFieldList[]];
this is crocked. it should be fixed!!
};
c: REF frozen PT.LocalContextContentsBody =>
WITH c.block.body SELECT FROM
block: REF PT.BlockTGNBody   => RETURN[block.ffl.cells];
module: REF PT.ModuleTGNBody  => RETURN[module.ffl.cells];
ic: REF PT.InterfaceContentsTGNBody => RETURN[ic.ffl.cells];
ENDCASE         => ERROR;
ENDCASE => ERROR;
END;
Anywhere Visible
ParameterizedFieldDescriptorNode: TYPE = REF ParameterizedFieldDescriptorNodeBody;
ParameterizedFieldDescriptorNodeBody: PUBLIC TYPE = PG.ParameterizedFieldDescriptorNodeBody;
LookupName: PROC [lc: LocalContextNode, name: GEN.IdNode] RETURNS [FieldNode] = BEGIN
WHILE TRUE DO
res: FieldNode ← LookupLocalName[lc, name];
IF (res # NIL) OR (lc.parentRib = NIL) THEN RETURN[res];
this needs to also look in "open" lists, not just the field lists
lc ← lc.parentRib.lc;
ENDLOOP;
ERROR; -- just to make the compiler happy; we never get here...
END;
GetPathToName: PUBLIC PROC [ct: ContextTreeNode, name: GEN.IdNode] RETURNS [pfd: ParameterizedFieldDescriptorNode, tgn: TypeGraphNodeNode] = BEGIN
lc: LocalContextNode ← ct.rib.lc; -- look for bugs in this proc!!
field: FieldNode ← LookupNameInContextRib[name, ct.rib];
pfd ← PGD.EmptyPFD[];
tgn ← IF field = NIL
THEN ERROR EH.FatalError[name.position, IO.PutFR["%g is undefined", IO.rope[name.text]]]
ELSE WITH field SELECT FROM
man, this is braindamaged. we really want something to walk the path after we build it!!
f: REF constant FieldNodeBody => f.type,
f: REF variable FieldNodeBody => f.type,
ENDCASE => ERROR;
WHILE TRUE DO
ffl: FrozenFieldListNode ← ContextRibLocalFrozenFieldList[ct.rib];
res: FieldNode ← LookupNameInFieldList[ffl.cells, name];
IF res = NIL
THEN IF lc.parentRib = NIL
THEN ERROR EH.FatalError[name.position, IO.PutFR["%g is undeclared", IO.rope[name.text]]]
ELSE pfd ← PGD.AddNestedCellToPFD[pfd]
ELSE {
pfd ← PGD.AddVarsCellToPFD[pfd, name.text];
EXIT;
};
lc ← lc.parentRib.lc;
ENDLOOP;
END;
LookupTypeNameInLocalContext: PUBLIC PROC [lc: LocalContextNode, id: GEN.IdNode] RETURNS [TypeGraphNodeNode] = BEGIN
f: FieldNode ← LookupName[lc, id];
SELECT TRUE FROM
f = NIL => {
ERROR EH.FatalError[id.position, IO.PutFR["Undeclared type name %g", IO.rope[id.text]]];
maybe dummy something up so we can proceed?
};
NOT ISTYPE[f, REF typeDecl FieldNodeBody] => {
ERROR EH.FatalError[id.position, IO.PutFR["%g does not name a type", IO.rope[id.text]]];
maybe dummy something up so we can proceed?
};
ENDCASE => NULL;
RETURN [NARROW[f, REF typeDecl FieldNodeBody].type];
END;
LookupTypeNameInContextTree: PUBLIC PROC [ct: ContextTreeNode, id: GEN.IdNode] RETURNS [TypeGraphNodeNode] = BEGIN
RETURN [LookupTypeNameInLocalContext[ct.rib.lc, id]];
END;
LookupVariableOrConstantName: PUBLIC PROC [lc: LocalContextNode, id: GEN.IdNode] RETURNS [ValueNode] = BEGIN
This will have to assemble stack lookup code, and use this code to synthesize the returned value. In the meantime, we'll just return trash unless it's a static constant.
Naw, let's bogus up some code for now...
f: FieldNode ← LookupName[lc, id];
IF f = NIL
THEN {
ERROR EH.FatalError[id.position, IO.PutFR["Undeclared variable name %g", IO.rope[id.text]]];
maybe dummy something up so we can proceed?
}
ELSE WITH f SELECT FROM
ff: REF typeDecl FieldNodeBody => {
ERROR EH.FatalError[id.position, IO.PutFR["%g does not name a variable", IO.rope[id.text]]];
maybe dummy something up so we can proceed?
};
ff: REF constant FieldNodeBody => {
IF ff.value.kind = static
THEN RETURN[ff.value]
ELSE {
pfd: ParameterizedFieldDescriptorNode ← GetPathToName[lc, id].pfd;
code: BD.ProgramGraphNode ← IF PGD.PFDIsLocal[pfd]
THEN PGD.MakePGLoadLocal[pfd]
ELSE PGD.MakePGLoadIndirect[pfd];
RETURN[NEW[ValueNodeBody ← [runtime[code, ff.type]]]];
I think we ultimately want an lvalue-used-as-rvalue lookup function. ALso think about assignments to a field of a constant record.
};
};
ff: REF variable FieldNodeBody => {
pfd: ParameterizedFieldDescriptorNode ← GetPathToName[lc, id].pfd;
code: BD.ProgramGraphNode ← IF PGD.PFDIsLocal[pfd]
THEN PGD.MakePGLoadLocal[pfd]
ELSE PGD.MakePGLoadIndirect[pfd];
RETURN[NEW[ValueNodeBody ← [runtime[code, ff.type]]]];
};
ENDCASE => ERROR;
END;
CompileLValueIntoRValue: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode, ct: ContextTreeNode] RETURNS [value: ValueNode] = BEGIN
cell: PG.ParameterizedFieldDescriptorCell ← pfd.firstCell;
local: BOOLEAN ← TRUE;
rib: ContextRibNode ← ct.rib;
WHILE (cell # NIL) AND (cell.kind = nested) DO
rib ← rib.lc.parentRib;
cell ← cell.next;
local ← FALSE;
ENDLOOP;
BEGIN
c: REF vars PG.ParameterizedFieldDescriptorCellBody ← NARROW[cell];
field: FieldNode ← LookupNameInContextRib[IdNodeFromRope[c.name], rib];
IF field = NIL THEN ERROR EH.InternalError["Blat"];
WITH field SELECT FROM
ff: REF constant FieldNodeBody =>
SELECT TRUE FROM
(ff.value.kind = static) => value ← ff.value;
local      => {
code: BD.ProgramFragmentNode ← PGD.MakePGLoadLocal[pfd];
RETURN[NEW[ValueNodeBody ← [runtime[code, ff.type]]]];
};
ENDCASE     => {
code: BD.ProgramFragmentNode ← PGD.MakePGLoadIndirect[pfd];
RETURN[NEW[ValueNodeBody ← [runtime[code, ff.type]]]];
};
ff: REF variable FieldNodeBody =>
SELECT TRUE FROM
local      => {
code: BD.ProgramFragmentNode ← PGD.MakePGLoadLocal[pfd];
RETURN[NEW[ValueNodeBody ← [runtime[code, ff.type]]]];
};
ENDCASE     => {
code: BD.ProgramFragmentNode ← PGD.MakePGLoadIndirect[pfd];
RETURN[NEW[ValueNodeBody ← [runtime[code, ff.type]]]];
};
ENDCASE => ERROR EH.InternalError["Blort"];
loop through fields and indices now. only if everything is static will we return a static value. all other cases we return a runtime value.
END;
END;
FindAFieldCorrespondingToDeclaration: PUBLIC PROC [ct: ContextTreeNode, declaration: DeclarationPTreeNode] RETURNS [FieldNode] = BEGIN
FOR cell: FieldListCell ← ContextRibLocalFrozenFieldList[ct.rib].cells.first, cell.next WHILE (cell # NIL) DO
WITH cell.node SELECT FROM
f: REF typeDecl FieldNodeBody => NULL;
f: REF module FieldNodeBody => ERROR EH.InternalError["69 foo"];
f: REF constant FieldNodeBody => IF f.declaration.node = declaration.node THEN RETURN[cell.node];
f: REF variable FieldNodeBody => IF f.declaration.node = declaration.node THEN RETURN[cell.node];
f: REF recordField FieldNodeBody => ERROR EH.InternalError["69 bar"];
ENDCASE => ERROR;
ENDLOOP;
ERROR EH.InternalError["69 baz"];
END;
IdNodeFromRope: PROC [r: Rope.ROPE] RETURNS [GEN.IdNode] = INLINE BEGIN
RETURN [NEW[GEN.IdNodeBody ← [r, 0, 0]]];
END;
END.