CedarBaseTypeImpl.Mesa
Copyright Ó 1987 by Xerox Corporation. All rights reserved.
Shoup, August 8, 1986 5:38:29 pm PDT
Bill Jackson (bj) April 16, 1987 1:09:07 am PDT
DIRECTORY
CedarBaseContext USING [LocalContext, RibContext],
CedarBaseMisc USING [Assert],
IO USING [STREAM, PutF, rope, int],
Rope USING [ROPE],
RefTab,
SaffronATDef USING [DeclarationNode, InitializationNode],
SaffronGenericDef USING [idNode],
SymTab,
CedarBaseType,
CedarBaseTypeAux;
CedarBaseTypeImpl: CEDAR PROGRAM
IMPORTS CedarBaseMisc, IO, RefTab, SymTab
EXPORTS CedarBaseType, CedarBaseTypeAux ~ {
OPEN CedarBaseType;
ROPE: TYPE ~ Rope.ROPE;
EltList
EltList: TYPE ~ REF EltListRep;
EltListRep: PUBLIC TYPE ~ RECORD [
nameToOrd: SymTab.Ref,  -- name => OrdinalValue
ordToName: RefTab.Ref  -- OrdinalValue => name
];
BuildEmptyEltList: PUBLIC PROC [] RETURNS [EltList] ~ {
nameToOrd: SymTab.Ref ~ SymTab.Create[];
ordToName: RefTab.Ref ~ RefTab.Create[equal: OrdinalValueEqual, hash: OrdinalValueHash];
RETURN [NEW[EltListRep ← [nameToOrd, ordToName] ]];
};
EltListInsert: PUBLIC PROC [eltList: EltList, id: SaffronGenericDef.idNode]
RETURNS [EltList, BOOL] ~ {
ordinalValue: OrdinalValue ~ BuildOrdinalValue[SymTab.GetSize[eltList.nameToOrd]];
ok: BOOL ~ SymTab.Insert[eltList.nameToOrd, id.text, ordinalValue];
IF ( NOT ok ) THEN RETURN [eltList, ok];
IF ( NOT RefTab.Insert[eltList.ordToName, ordinalValue, id.text] ) THEN ERROR;
RETURN [eltList, ok];
};
EltListLookup: PUBLIC PROC [eltList: EltList, id: SaffronGenericDef.idNode]
RETURNS [OrdinalValue] ~ {
found: BOOL; val: SymTab.Val;
[found, val] ← SymTab.Fetch[eltList.nameToOrd, id.text];
IF ( NOT found )
THEN RETURN [BuildUndefinedOrdinalValue[]]
ELSE RETURN [NARROW[val]];
};
PrintEltList: PROC [eltList: EltList, s: IO.STREAM] ~ {
FOR i: INT IN [0..RefTab.GetSize[eltList.ordToName]) DO
found: BOOL; val: RefTab.Val;
name: ROPE;
[found, val] ← RefTab.Fetch[eltList.ordToName, BuildOrdinalValue[i]];
IF ( NOT found ) THEN ERROR;
name ← NARROW[val];
IF ( i > 0 ) THEN IO.PutF[s, ", "];
IO.PutF[s, "%g", IO.rope[name]];
ENDLOOP;
};
FieldDescriptor
FieldDescriptor: TYPE ~ REF FieldDescriptorRep;
FieldDescriptorRep: PUBLIC TYPE ~ RECORD [
typeIndex: TypeIndex
];
BuildFieldDescriptor: PUBLIC PROC [typeIndex: TypeIndex] RETURNS [FieldDescriptor] ~ {
RETURN [NEW[FieldDescriptorRep ← [typeIndex] ]];
};
GetFieldType: PUBLIC PROC [fieldDescriptor: FieldDescriptor] RETURNS [TypeIndex] ~ {
RETURN [fieldDescriptor.typeIndex];
};
PrintFieldDescriptor: PROC [fieldDescriptor: FieldDescriptor, s: IO.STREAM] ~ {
[] ← PrintTypeIndex[fieldDescriptor.typeIndex, s];
};
FieldList
FieldList: TYPE ~ REF FieldListRep;
FieldListRep: PUBLIC TYPE ~ RECORD [
SELECT kind: * FROM
null => [],
named => [namedFieldList: NamedFieldList],
unnamed => [unnamedFieldList: UnnamedFieldList]
ENDCASE
];
BuildNamedFieldList: PUBLIC PROC [namedFieldList: NamedFieldList]
RETURNS [FieldList] ~ {
RETURN [NEW[FieldListRep ← [named[namedFieldList]] ]];
};
BuildNullFieldList: PUBLIC PROC [] RETURNS [FieldList] ~ {
RETURN [NEW[FieldListRep ← [null[]] ]];
};
BuildUnnamedFieldList: PUBLIC PROC [unnamedFieldList: UnnamedFieldList]
RETURNS [FieldList] ~ {
RETURN [NEW[FieldListRep ← [unnamed[unnamedFieldList]] ]];
};
EvalFieldListSize: PROC [fieldList: FieldList, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext, typeGraph: TypeGraph] RETURNS [Size, CedarBaseContext.LocalContext, TypeGraph] ~ {
size: Size;
WITH fieldList SELECT FROM
fieldList: REF null FieldListRep => {
size ← BuildKnownSize[0];
};
fieldList: REF named FieldListRep => {
[size, localContext, typeGraph] ← EvalNamedFieldListSize[
fieldList.namedFieldList, localContext, ribContext, typeGraph];
};
fieldList: REF unnamed FieldListRep => {
[size, localContext, typeGraph] ← EvalUnnamedFieldListSize[ fieldList.unnamedFieldList, localContext, ribContext, typeGraph];
};
ENDCASE => ERROR;
RETURN [size, localContext, typeGraph];
};
PrintFieldList: PROC [fieldList: FieldList, s: IO.STREAM] ~ {
WITH fieldList SELECT FROM
fieldList: REF null FieldListRep => {
IO.PutF[s, "null"];
};
fieldList: REF named FieldListRep => {
PrintNamedFieldList[fieldList.namedFieldList, s];
};
fieldList: REF unnamed FieldListRep => {
PrintUnnamedFieldList[fieldList.unnamedFieldList, s];
};
ENDCASE => ERROR;
};
FieldTriple
FieldTriple: TYPE ~ REF FieldTripleRep;
FieldTripleRep: TYPE ~ RECORD [
pos: Pos,
rope: ROPE,
fieldDescriptor: FieldDescriptor
];
BuildFieldTriple: PROC [pos: Pos, rope: ROPE, fieldDescriptor: FieldDescriptor]
RETURNS [FieldTriple] ~ {
RETURN [NEW[FieldTripleRep ← [pos, rope, fieldDescriptor] ]];
};
FieldTripleGetFieldDescriptor: PROC [fieldTriple: FieldTriple]
RETURNS [FieldDescriptor] ~ {
RETURN [fieldTriple.fieldDescriptor];
};
FieldTripleGetPos: PROC [fieldTriple: FieldTriple] RETURNS [Pos] ~ {
RETURN [fieldTriple.pos];
};
FieldTripleGetRope: PROC [fieldTriple: FieldTriple] RETURNS [ROPE] ~ {
RETURN [fieldTriple.rope];
};
NamedFieldList
NamedFieldList: TYPE ~ REF NamedFieldListRep;
NamedFieldListRep: PUBLIC TYPE ~ RECORD [
nameToTriple: SymTab.Ref, -- name => FieldTriple
posToTriple: RefTab.Ref  -- Pos => FieldTriple
];
AddNamedField: PUBLIC PROC [namedFieldList: NamedFieldList, id: SaffronGenericDef.idNode, fieldDescriptor: FieldDescriptor] RETURNS [NamedFieldList, BOOL] ~ {
pos: Pos ~ BuildPos[RefTab.GetSize[namedFieldList.posToTriple]];
fieldTriple: FieldTriple ~ BuildFieldTriple[pos, id.text, fieldDescriptor];
ok: BOOL ~ SymTab.Insert[namedFieldList.nameToTriple, id.text, fieldTriple];
IF ( NOT ok ) THEN RETURN [namedFieldList, ok];
IF ( NOT RefTab.Insert[namedFieldList.posToTriple, pos, fieldTriple] ) THEN ERROR;
RETURN [namedFieldList, ok];
};
CreateNamedFieldList: PUBLIC PROC [] RETURNS [NamedFieldList] ~ {
nameToTriple: SymTab.Ref ~ SymTab.Create[];
posToTriple: RefTab.Ref ~ RefTab.Create[equal: PosEqual, hash: PosHash];
namedFieldList: NamedFieldList ~ NEW[NamedFieldListRep ←
[posToTriple: posToTriple, nameToTriple: nameToTriple] ];
RETURN [namedFieldList];
};
EvalNamedFieldListSize: PROC [namedFieldList: NamedFieldList, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext, typeGraph: TypeGraph] RETURNS [Size, CedarBaseContext.LocalContext, TypeGraph] ~ {
size: Size;
EachPair: RefTab.EachPairAction ~ {
fieldTriple: FieldTriple ~ NARROW[val];
typeIndex: TypeIndex ~ GetFieldType[FieldTripleGetFieldDescriptor[fieldTriple]];
deltaSize: Size;
[deltaSize, localContext, typeGraph] ← FetchSize[typeGraph, typeIndex, localContext, ribContext];
size ← AddSize[size, deltaSize];
};
size ← BuildKnownSize[0];
[] ← RefTab.Pairs[namedFieldList.posToTriple, EachPair];
RETURN [size, localContext, typeGraph];
};
PrintNamedFieldList: PROC [namedFieldList: NamedFieldList, s: IO.STREAM] ~ {
IO.PutF[s, "named["];
FOR i: INT IN [0..RefTab.GetSize[namedFieldList.posToTriple]) DO
found: BOOL; val: RefTab.Val;
fieldTriple: FieldTriple;
name: ROPE;
fieldDescriptor: FieldDescriptor;
[found, val] ← RefTab.Fetch[namedFieldList.posToTriple, BuildPos[i]];
IF ( NOT found ) THEN ERROR;
fieldTriple ← NARROW[val];
IF ( i > 0 ) THEN IO.PutF[s, ", "];
name ← FieldTripleGetRope[fieldTriple];
fieldDescriptor ← FieldTripleGetFieldDescriptor[fieldTriple];
IO.PutF[s, "[%g, ", IO.rope[name]];
PrintFieldDescriptor[fieldDescriptor, s];
IO.PutF[s, "]"];
ENDLOOP;
IO.PutF[s, "]"];
};
OrdinalValue
OrdinalValue: TYPE ~ REF OrdinalValueRep;
OrdinalValueRep: PUBLIC TYPE ~ RECORD [
val: INT
];
BuildOrdinalValue: PUBLIC PROC [n: INT] RETURNS [OrdinalValue] ~ {
RETURN [NEW[OrdinalValueRep ← [n] ]];
};
BuildUndefinedOrdinalValue: PUBLIC PROC [] RETURNS [OrdinalValue] ~ {
RETURN [NIL];
};
IsUndefinedOrdinalValue: PUBLIC PROC [ordinalValue: OrdinalValue]
RETURNS [BOOL] ~ {
RETURN [( ordinalValue = NIL )];
};
OrdinalValueAdd1: PROC [ordinalValue: OrdinalValue] RETURNS [OrdinalValue] ~ {
RETURN [BuildOrdinalValue[ordinalValue.val + 1]];
};
OrdinalValueEqual: RefTab.EqualProc ~ {
a: OrdinalValue ~ NARROW[key1];
b: OrdinalValue ~ NARROW[key2];
RETURN [( a^ = b^ )];
};
OrdinalValueHash: RefTab.HashProc ~ {
a: OrdinalValue ~ NARROW[key];
RETURN [a^];
};
OrdinalValueSub1: PROC [ordinalValue: OrdinalValue] RETURNS [OrdinalValue] ~ {
RETURN [BuildOrdinalValue[ordinalValue.val - 1]];
};
PrintOrdinalValue: PUBLIC PROC [ordinalValue: OrdinalValue, s: IO.STREAM]
RETURNS [BOOL] ~ {
IF ( IsUndefinedOrdinalValue[ordinalValue] )
THEN IO.PutF[s, "-"]
ELSE IO.PutF[s, "%g", IO.int[ordinalValue.val]];
RETURN [TRUE];
};
Paint
BuildUndefinedPaint: PUBLIC PROC [] RETURNS [Paint] ~ {
RETURN [Paint[-1]];
};
IsUndefinedPaint: PUBLIC PROC [paint: Paint] RETURNS [BOOL] ~ {
RETURN [( paint = Paint[-1] )]
};
PaintEqual: PUBLIC PROC [p1, p2: Paint] RETURNS [BOOL] ~ {
IF ( IsUndefinedPaint[p1] OR IsUndefinedPaint[p2] ) THEN ERROR;
RETURN [( p1 = p2 )];
};
PrintPaint: PROC [paint: Paint, s: IO.STREAM] ~ {
IF ( IsUndefinedPaint[paint] )
THEN IO.PutF[s, "-"]
ELSE IO.PutF[s, "%g", IO.int[paint.val]];
};
Pos
Pos: TYPE ~ REF INT;
BuildPos: PROC [a: INT] RETURNS [Pos] ~ {
RETURN [NEW[INT ← a]];
};
PosEqual: RefTab.EqualProc ~ {
a: Pos ~ NARROW[key1];
b: Pos ~ NARROW[key2];
RETURN [( a^ = b^ )];
};
PosHash: RefTab.HashProc ~ {
a: Pos ~ NARROW[key];
RETURN [a^];
};
Size
Size: TYPE ~ REF SizeRep;
SizeRep: PUBLIC TYPE ~ RECORD [
SELECT kind: * FROM
unknown => [],
inaccessible => [],
known => [val: INT]
ENDCASE
];
UnknownSize: TYPE ~ REF unknown SizeRep;
InaccessibleSize: TYPE ~ REF inaccessible SizeRep;
KnownSize: TYPE ~ REF known SizeRep;
AddSize: PROC [size1: Size, size2: Size] RETURNS [Size] ~ {
s1: KnownSize ~ NARROW[size1];
s2: KnownSize ~ NARROW[size2];
RETURN [NEW[SizeRep ← [known[s1.val + s2.val]] ]];
};
BuildInaccessibleSize: PUBLIC PROC [] RETURNS [Size] ~ {
RETURN [NEW[SizeRep ← [inaccessible[]] ]];
};
BuildKnownSize: PUBLIC PROC [val: INT] RETURNS [Size] ~ {
RETURN [NEW[SizeRep ← [known[val]] ]];
};
BuildUnknownSize: PUBLIC PROC [] RETURNS [Size] ~ {
RETURN [NEW[SizeRep ← [unknown[]] ]];
};
IsInaccessibleSize: PUBLIC PROC [size: Size] RETURNS [BOOL] ~ {
RETURN [( size.kind = inaccessible )];
};
IsKnownSize: PUBLIC PROC [size: Size] RETURNS [BOOL] ~ {
RETURN [( size.kind = known )];
};
IsUnknownSize: PUBLIC PROC [size: Size] RETURNS [BOOL] ~ {
RETURN [( size.kind = unknown )];
};
PrintSize: PROC [size: Size, s: IO.STREAM] ~ {
WITH size SELECT FROM
size: UnknownSize => IO.PutF[s, "unknown"];
size: InaccessibleSize => IO.PutF[s, "inaccessible"];
size: KnownSize => IO.PutF[s, "%g", IO.int[size.val]];
ENDCASE => ERROR;
};
TypeBounds
TypeBounds: TYPE ~ REF TypeBoundsRep;
TypeBoundsRep: PUBLIC TYPE ~ RECORD [
lowerBound: OrdinalValue,
upperBound: OrdinalValue
];
BuildTypeBounds: PUBLIC PROC [lowerBound: OrdinalValue, upperBound: OrdinalValue, leftClosed: BOOL, rightClosed: BOOL] RETURNS [TypeBounds] ~ {
IF ( NOT leftClosed ) THEN lowerBound ← OrdinalValueAdd1[lowerBound];
IF ( NOT rightClosed ) THEN upperBound ← OrdinalValueSub1[upperBound];
RETURN [NEW [TypeBoundsRep ← [lowerBound, upperBound]]];
};
BuildUndefinedTypeBounds: PUBLIC PROC RETURNS [TypeBounds] ~ {
RETURN [NIL];
};
IsUndefinedTypeBounds: PUBLIC PROC [bounds: TypeBounds] RETURNS [BOOL] ~ {
RETURN [( bounds = NIL )];
};
PrintTypeBounds: PROC [bounds: TypeBounds, s: IO.STREAM] ~ {
IF ( IsUndefinedTypeBounds[bounds] )
THEN IO.PutF[s, "-"]
ELSE {
IO.PutF[s, "["];
[] ← PrintOrdinalValue[bounds.lowerBound, s];
IO.PutF[s, ".."];
[] ← PrintOrdinalValue[bounds.upperBound, s];
IO.PutF[s, "]"];
};
};
TypeGraph
TypeGraph: TYPE ~ REF TypeGraphRep;
TypeGraphRep: PUBLIC TYPE ~ RECORD [
paintCount: INT,
sizeCount: INT,  -- number of known sizes
nodeMap: RefTab.Ref,  -- TypeIndex => TypeNode
sizeMap: RefTab.Ref  -- TypeIndex => Size
];
AddOrSetType: PUBLIC PROC [typeGraph: TypeGraph, typeNode: TypeNode, optTypeIndex: TypeIndex] RETURNS [TypeGraph, TypeIndex] ~ {
IF ( IsUndefinedTypeIndex[optTypeIndex] )
THEN {
typeIndex: TypeIndex;
[typeGraph, typeIndex] ← AddType[typeGraph, typeNode];
RETURN [typeGraph, typeIndex];
}
ELSE {
typeGraph ← SetType[typeGraph, typeNode, optTypeIndex];
RETURN [typeGraph, optTypeIndex];
};
};
AddType: PUBLIC PROC [typeGraph: TypeGraph, typeNode: TypeNode]
RETURNS [TypeGraph, TypeIndex] ~ {
typeIndex: TypeIndex ← BuildTypeIndex[RefTab.GetSize[typeGraph.nodeMap]];
IF ( NOT RefTab.Insert[typeGraph.nodeMap, typeIndex, typeNode] ) THEN ERROR;
IF ( NOT RefTab.Insert[typeGraph.sizeMap, typeIndex, BuildUnknownSize[]] )
THEN ERROR;
RETURN [typeGraph, typeIndex];
};
CreateTypeGraph: PUBLIC PROC [] RETURNS [TypeGraph] ~ {
sizeMap: RefTab.Ref ~ RefTab.Create[equal: TypeIndexEqual, hash: TypeIndexHash];
nodeMap: RefTab.Ref ~ RefTab.Create[equal: TypeIndexEqual, hash: TypeIndexHash];
RETURN [NEW[TypeGraphRep ← [paintCount: 0, nodeMap: nodeMap, sizeMap: sizeMap, sizeCount: 0] ]];
};
FetchAllSizes: PUBLIC PROC [typeGraph: TypeGraph, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext] RETURNS [CedarBaseContext.LocalContext, TypeGraph] ~ {
WHILE ( typeGraph.sizeCount < RefTab.GetSize[typeGraph.sizeMap] ) DO
size: Size;
[size, localContext, typeGraph] ← FetchSize[typeGraph, BuildTypeIndex[typeGraph.sizeCount], localContext, ribContext];
typeGraph.sizeCount ← typeGraph.sizeCount.SUCC;
ENDLOOP;
RETURN [localContext, typeGraph];
};
FetchSize: PROC [typeGraph: TypeGraph, typeIndex: TypeIndex, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext] RETURNS [Size, CedarBaseContext.LocalContext, TypeGraph] ~ {
size: Size ← RawFetchSize[typeGraph, typeIndex];
[] ← CedarBaseMisc.Assert[( NOT IsInaccessibleSize[size] ), "ill-defined type size", quit];
IF ( IsUnknownSize[size] ) THEN {
typeNode: TypeNode;
typeGraph ← SetSize[typeGraph, BuildInaccessibleSize[], typeIndex];
[typeNode, localContext, typeGraph] ← FetchType[typeGraph, typeIndex, localContext, ribContext];
[size, localContext, typeGraph] ← EvalSize[typeNode, localContext, ribContext, typeGraph];
typeGraph ← SetSize[typeGraph, size, typeIndex];
};
RETURN [size, localContext, typeGraph];
};
FetchType: PUBLIC PROC [typeGraph: TypeGraph, typeIndex: TypeIndex, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext] RETURNS [TypeNode, CedarBaseContext.LocalContext, TypeGraph] ~ {
typeNode: TypeNode ← RawFetchType[typeGraph, typeIndex];
[] ← CedarBaseMisc.Assert[( NOT IsInaccessibleType[typeNode] ), "illegal circular type", quit];
IF ( IsSuspendedType[typeNode] ) THEN {
decl: SaffronATDef.DeclarationNode ~ NARROW[GetTypeDecl[typeNode]];
[localContext, typeGraph] ← decl.procs.ProcessOneDecl[decl, typeIndex, localContext, ribContext, typeGraph];
typeNode ← RawFetchType[typeGraph, typeIndex];
};
RETURN [typeNode, localContext, typeGraph];
};
NewPaint: PUBLIC PROC [typeGraph: TypeGraph] RETURNS [TypeGraph, Paint] ~ {
typeGraph.paintCount ← typeGraph.paintCount + 1;
RETURN [typeGraph, Paint[typeGraph.paintCount]];
};
PrintTypeGraph: PUBLIC PROC [typeGraph: TypeGraph, s: IO.STREAM]
RETURNS [BOOL] ~ {
IO.PutF[s, "\nTYPE GRAPH\n\n"];
FOR i: INT IN [0..RefTab.GetSize[typeGraph.nodeMap]) DO
typeIndex: TypeIndex ~ BuildTypeIndex[i];
typeNode: TypeNode ~ RawFetchType[typeGraph, typeIndex];
size: Size ~ RawFetchSize[typeGraph, typeIndex];
IO.PutF[s, "%g: ", IO.int[i]];
IO.PutF[s, "size: "];
PrintSize[size, s];
IO.PutF[s, " node: "];
[] ← PrintTypeNode[typeNode, s];
IO.PutF[s, "\n"];
ENDLOOP;
IO.PutF[s, "\n"];
RETURN [TRUE];
};
RawFetchSize: PROC [typeGraph: TypeGraph, typeIndex: TypeIndex] RETURNS [Size] ~ {
found: BOOL; val: RefTab.Val;
size: Size;
IF ( IsUndefinedTypeIndex[typeIndex] ) THEN ERROR;
[found, val] ← RefTab.Fetch[typeGraph.sizeMap, typeIndex];
IF ( NOT found ) THEN ERROR;
size ← NARROW[val];
RETURN [size];
};
RawFetchType: PUBLIC PROC [typeGraph: TypeGraph, typeIndex: TypeIndex]
RETURNS [TypeNode] ~ {
found: BOOL; val: RefTab.Val;
typeNode: TypeNode;
IF ( IsUndefinedTypeIndex[typeIndex] ) THEN ERROR;
[found, val] ← RefTab.Fetch[typeGraph.nodeMap, typeIndex];
IF ( NOT found ) THEN ERROR;
typeNode ← NARROW[val];
RETURN [typeNode];
};
SetSize: PROC [typeGraph: TypeGraph, size: Size, typeIndex: TypeIndex]
RETURNS [TypeGraph] ~ {
IF ( IsUndefinedTypeIndex[typeIndex] ) THEN ERROR;
IF ( NOT RefTab.Replace[typeGraph.sizeMap, typeIndex, size] ) THEN ERROR;
RETURN [typeGraph];
};
SetType: PUBLIC PROC [typeGraph: TypeGraph, typeNode: TypeNode, typeIndex: TypeIndex]
RETURNS [TypeGraph] ~ {
IF ( IsUndefinedTypeIndex[typeIndex] ) THEN ERROR;
IF ( NOT RefTab.Replace[typeGraph.nodeMap, typeIndex, typeNode] ) THEN ERROR;
RETURN [typeGraph];
};
XTypeGraph: PUBLIC PROC [typeGraph: TypeGraph] RETURNS [TypeGraph] ~ {
RETURN [typeGraph];
};
TypeIndex
TypeIndex: TYPE ~ REF TypeIndexRep;
TypeIndexRep: PUBLIC TYPE ~ RECORD [
location: INT
];
BuildTypeIndex: PROC [location: INT] RETURNS [TypeIndex] ~ {
RETURN [NEW[TypeIndexRep ← [location] ]];
};
IsUndefinedTypeIndex: PUBLIC PROC [typeIndex: TypeIndex] RETURNS [BOOL] ~ {
RETURN [( typeIndex = NIL )];
};
PrintTypeIndex: PUBLIC PROC [typeIndex: TypeIndex, s: IO.STREAM] RETURNS [BOOL] ~ {
IF ( IsUndefinedTypeIndex[typeIndex] )
THEN IO.PutF[s, "-"]
ELSE IO.PutF[s, "%g", IO.int[typeIndex.location]];
RETURN [TRUE];
};
TypeIndexEqual: RefTab.EqualProc ~ {
a: TypeIndex ~ NARROW[key1];
b: TypeIndex ~ NARROW[key2];
RETURN [( a.location = b.location )];
};
TypeIndexHash: RefTab.HashProc ~ {
a: TypeIndex ~ NARROW[key];
RETURN [a.location];
};
UndefinedTypeIndex: PUBLIC PROC [] RETURNS [TypeIndex] ~ {
RETURN [NIL];
};
XTypeIndex: PUBLIC PROC [typeIndex: TypeIndex] RETURNS [TypeIndex] ~ {
RETURN [typeIndex];
};
TypeNode
TypeNode: TYPE ~ REF TypeNodeRep;
TypeNodeRep: PUBLIC TYPE ~ RECORD [
paint: Paint,
bounds: TypeBounds,
initialization: REF,
typeCons: TypeCons
];
TypeCons: TYPE = REF TypeConsRep;
TypeConsRep: TYPE ~ RECORD [
SELECT kind: * FROM
suspended => [typeDecl: REF ANY],
inaccessible => [],
record => [fieldList: FieldList],
enum => [eltList: EltList],
ref => [referentType: TypeIndex]
ENDCASE
];
EnumTypeCons:  TYPE ~ REF enum TypeConsRep;
InaccessibleTypeCons: TYPE ~ REF inaccessible TypeConsRep;
RecordTypeCons:  TYPE ~ REF record TypeConsRep;
RefTypeCons:  TYPE ~ REF ref TypeConsRep;
SuspendedTypeCons: TYPE ~ REF suspended TypeConsRep;
BuildEnumType: PUBLIC PROC [paint: Paint, eltList: EltList] RETURNS [TypeNode] ~ {
RETURN [NEW[TypeNodeRep ← [
bounds: BuildUndefinedTypeBounds[],
initialization: NIL,
paint: paint,
typeCons: NEW[TypeConsRep ← [enum[eltList]]]
]]];
};
BuildInaccessibleType: PUBLIC PROC [] RETURNS [TypeNode] ~ {
RETURN [NEW[TypeNodeRep ← [
bounds: BuildUndefinedTypeBounds[],
initialization: NIL,
paint: BuildUndefinedPaint[],
typeCons: NEW[TypeConsRep ← [inaccessible[]]]
]]];
};
BuildRecordType: PUBLIC PROC [fieldList: FieldList] RETURNS [TypeNode] ~ {
RETURN [NEW[TypeNodeRep ← [
bounds: BuildUndefinedTypeBounds[],
initialization: NIL,
paint: BuildUndefinedPaint[],
typeCons: NEW[TypeConsRep ← [record[fieldList]]]
]]];
};
BuildRefType: PUBLIC PROC [referentType: TypeIndex] RETURNS [TypeNode] ~ {
RETURN [NEW[TypeNodeRep ← [
bounds: BuildUndefinedTypeBounds[],
initialization: NIL,
paint: BuildUndefinedPaint[],
typeCons: NEW[TypeConsRep ← [ref[referentType]]]
]]];
};
BuildSubrangeType: PUBLIC PROC [typeNode: TypeNode, bounds: TypeBounds]
RETURNS [TypeNode] ~ {
newTypeNode: TypeNode ~ NEW[TypeNodeRep ← typeNode^];
newTypeNode.bounds ← bounds;
RETURN [newTypeNode];
};
BuildSuspendedType: PUBLIC PROC [typeDecl: REF] RETURNS [TypeNode] ~ {
RETURN [NEW [TypeNodeRep ← [
bounds: BuildUndefinedTypeBounds[],
initialization: NIL,
paint: BuildUndefinedPaint[],
typeCons: NEW[TypeConsRep ← [suspended[typeDecl]]]
]]];
};
EnumTypeEltList: PUBLIC PROC [typeNode: TypeNode] RETURNS [EltList] ~ {
WITH typeNode.typeCons SELECT FROM
typeCons: EnumTypeCons => RETURN [typeCons.eltList];
ENDCASE => ERROR;
};
EvalSize: PROC [typeNode: TypeNode, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext, typeGraph: TypeGraph] RETURNS [Size, CedarBaseContext.LocalContext, TypeGraph] ~ { 
size: Size;
WITH typeNode.typeCons SELECT FROM
typeCons: EnumTypeCons => {
size ← BuildKnownSize[1];
};
typeCons: InaccessibleTypeCons => {
ERROR;
};
typeCons: RecordTypeCons => {
[size, localContext, typeGraph] ← EvalFieldListSize[typeCons.fieldList, localContext, ribContext, typeGraph];
};
typeCons: RefTypeCons => {
size ← BuildKnownSize[1];
};
typeCons: SuspendedTypeCons => {
ERROR;
};
ENDCASE => ERROR;
RETURN [size, localContext, typeGraph];
};
GetPaint: PUBLIC PROC [typeNode: TypeNode] RETURNS [Paint] ~ {
RETURN [typeNode.paint];
};
GetReferentType: PUBLIC PROC [typeNode: TypeNode] RETURNS [TypeIndex] ~ {
WITH typeNode.typeCons SELECT FROM
typeCons: RefTypeCons => RETURN [typeCons.referentType];
ENDCASE => ERROR;
};
GetTypeBounds: PUBLIC PROC [typeNode: TypeNode] RETURNS [TypeBounds] ~ {
RETURN [typeNode.bounds];
};
GetTypeDecl: PUBLIC PROC [typeNode: TypeNode] RETURNS [REF ANY] ~ {
WITH typeNode.typeCons SELECT FROM
typeCons: SuspendedTypeCons => RETURN [typeCons.typeDecl];
ENDCASE => ERROR;
};
IsEnumType: PUBLIC PROC [typeNode: TypeNode] RETURNS [BOOL] ~ {
RETURN [( typeNode.typeCons.kind = enum )];
};
IsInaccessibleType: PUBLIC PROC [typeNode: TypeNode] RETURNS [BOOL] ~ {
RETURN [( typeNode.typeCons.kind = inaccessible )];
};
IsRefType: PUBLIC PROC [typeNode: TypeNode] RETURNS [BOOL] ~ {
RETURN [( typeNode.typeCons.kind = ref )];
};
IsSuspendedType: PUBLIC PROC [typeNode: TypeNode] RETURNS [BOOL] ~ {
RETURN [( typeNode.typeCons.kind = suspended )];
};
PrintEnumTypeCons: PROC [enumTypeCons: EnumTypeCons, s: IO.STREAM] ~ {
IO.PutF[s, "enum["];
PrintEltList[enumTypeCons.eltList, s];
IO.PutF[s, "]"];
};
PrintInaccessibleTypeCons: PROC [inaccessibleTypeCons: InaccessibleTypeCons, s: IO.STREAM] ~ {
IO.PutF[s, "inaccessible"];
};
PrintInitialization: PROC [ref: REF, s: IO.STREAM] ~ {
IF ( ref = NIL )
THEN IO.PutF[s, "-"]
ELSE {
code: SaffronATDef.InitializationNode ~ NARROW[ref];
IO.PutF[s, "[%g..%g]", IO.int[code.position], IO.int[code.position+code.length-1]];
};
};
PrintRecordTypeCons: PROC [recordTypeCons: RecordTypeCons, s: IO.STREAM] ~ {
IO.PutF[s, "record["];
PrintFieldList[recordTypeCons.fieldList, s];
IO.PutF[s, "]"];
};
PrintRefTypeCons: PROC [refTypeCons: RefTypeCons, s: IO.STREAM] ~ {
IO.PutF[s, "ref["];
[]←PrintTypeIndex[refTypeCons.referentType, s];
IO.PutF[s, "]"];
};
PrintSuspendedTypeCons: PROC [suspendedTypeCons: SuspendedTypeCons, s: IO.STREAM] ~ {
typeDecl: SaffronATDef.DeclarationNode ~ NARROW[suspendedTypeCons.typeDecl];
IO.PutF[s, "suspended[%g..%g]",
IO.int[typeDecl.position],
IO.int[typeDecl.position+typeDecl.length-1]
];
};
PrintTypeCons: PROC [typeCons: TypeCons, s: IO.STREAM] ~ {
WITH typeCons SELECT FROM
typeCons: EnumTypeCons => PrintEnumTypeCons[typeCons, s];
typeCons: InaccessibleTypeCons => PrintInaccessibleTypeCons[typeCons, s];
typeCons: RecordTypeCons => PrintRecordTypeCons[typeCons, s];
typeCons: RefTypeCons => PrintRefTypeCons[typeCons, s];
typeCons: SuspendedTypeCons => PrintSuspendedTypeCons[typeCons, s];
ENDCASE => ERROR;
};
PrintTypeNode: PUBLIC PROC [typeNode: TypeNode, s: IO.STREAM] RETURNS [BOOL] ~ {
IO.PutF[s, "["];
IO.PutF[s, "paint: "];
PrintPaint[typeNode.paint, s];
IO.PutF[s, " bounds: "];
PrintTypeBounds[typeNode.bounds, s];
IO.PutF[s, " init: "];
PrintInitialization[typeNode.initialization, s];
IO.PutF[s, " struct: "];
PrintTypeCons[typeNode.typeCons, s];
IO.PutF[s, "]"];
RETURN [TRUE];
};
UnnamedFieldList
UnnamedFieldList: TYPE ~ REF UnnamedFieldListRep;
UnnamedFieldListRep: PUBLIC TYPE ~ RECORD [
posToDescriptor: RefTab.Ref -- Pos => FieldDescriptor
];
AddUnnamedField: PUBLIC PROC [unnamedFieldList: UnnamedFieldList, fieldDescriptor: FieldDescriptor] RETURNS [UnnamedFieldList] ~ {
pos: Pos ← BuildPos[RefTab.GetSize[unnamedFieldList.posToDescriptor]];
IF ( NOT RefTab.Insert[unnamedFieldList.posToDescriptor, pos, fieldDescriptor] )
THEN ERROR;
RETURN [unnamedFieldList];
};
CreateUnnamedFieldList: PUBLIC PROC [] RETURNS [UnnamedFieldList] ~ {
posToDescriptor: RefTab.Ref ← RefTab.Create[equal: PosEqual, hash: PosHash];
RETURN [NEW[UnnamedFieldListRep ← [posToDescriptor]]];
};
EvalUnnamedFieldListSize: PROC [unnamedFieldList: UnnamedFieldList, localContext: CedarBaseContext.LocalContext, ribContext: CedarBaseContext.RibContext, typeGraph: TypeGraph] RETURNS [Size, CedarBaseContext.LocalContext, TypeGraph] ~ {
size: Size;
EachPair: RefTab.EachPairAction ~ {
fieldDescriptor: FieldDescriptor ~ NARROW[val];
typeIndex: TypeIndex ~ GetFieldType[fieldDescriptor];
deltaSize: Size;
[deltaSize, localContext, typeGraph] ← FetchSize[typeGraph, typeIndex, localContext, ribContext];
size ← AddSize[size, deltaSize];
};
size ← BuildKnownSize[0];
[] ← RefTab.Pairs[unnamedFieldList.posToDescriptor, EachPair];
RETURN [size, localContext, typeGraph];
};
PrintUnnamedFieldList: PROC [unnamedFieldList: UnnamedFieldList, s: IO.STREAM] ~ {
IO.PutF[s, "unnamed["];
FOR i: INT IN [0..RefTab.GetSize[unnamedFieldList.posToDescriptor]) DO
found: BOOL; val: RefTab.Val;
fieldDescriptor: FieldDescriptor;
[found, val] ← RefTab.Fetch[unnamedFieldList.posToDescriptor, BuildPos[i]];
IF ( NOT found ) THEN ERROR;
fieldDescriptor ← NARROW[val];
IF ( i > 0 ) THEN IO.PutF[s, ", "];
PrintFieldDescriptor[fieldDescriptor, s];
ENDLOOP;
IO.PutF[s, "]"];
};
}...