<> <> <> <> 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: 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: 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: 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: 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: 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: 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]; }; <> 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: 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: 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: 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: 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: 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: 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: 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, "]"]; }; }...