<<>> <> <> <> <> <> <> <> <> DIRECTORY CCTypes USING[BreakObject, CCError, CCErrorCase, CCTypeProcs, CheckConformance, CheckFamilyInclusion, CoerceToType, ConformanceCheck, Conforms, ContainsVariance, CreateCedarType, DoObject, ExtractIdField, GetIndirectType, GetNodeType, GetProcDataFromGroundType, HasIdField, IdFieldCase, GetNVariants, GetRTargetType, LR, SelectIdField, PrintType, sia], CirioSyntacticOperations USING[NameArgPair, ParseTree], CirioTypes USING[CompilerContext, Mem, Node, Type, TypedCode], CedarCode USING[Code, CodeToCoerce, CodeToExtractField, CodeToLoadThroughIndirect, CodeToSelectField, CodeToStoreUnpopped, ConcatCode, CreateCedarNode, ExtractFieldFromNode, ForceNodeIn, GetDataFromNode, GetTypeOfNode, LoadThroughIndirectNode, NullCode, OperationsBody, Operator, SelectFieldFromNode, ShowNode, StoreThroughIndirectNode], CedarOtherPureTypes USING [CreateEnumeratedTypeNodeFromIndex], IO, RefTab USING[Create, Fetch, Key, Ref, Store], Rope, StructuredStreams, VariantRecords USING[IndirectVRNodeProcs, VariantRecordNodeProcs, VariantRecordTypeDetails]; VariantRecordsImpl: CEDAR PROGRAM IMPORTS CCTypes, CedarCode, CedarOtherPureTypes, IO, RefTab, Rope, StructuredStreams EXPORTS VariantRecords = BEGIN OPEN CSO:CirioSyntacticOperations, SS:StructuredStreams; CCE: ERROR[case: CCTypes.CCErrorCase, msg: Rope.ROPE _ NIL] _ CCTypes.CCError; CC: TYPE = CirioTypes.CompilerContext; Code: TYPE = CedarCode.Code; Type: TYPE = CirioTypes.Type; TypedCode: TYPE = CirioTypes.TypedCode; Mem: TYPE = CirioTypes.Mem; Node: TYPE = CirioTypes.Node; VariantRecordTypeDetails: TYPE = VariantRecords.VariantRecordTypeDetails; <> <<>> <> <> <<>> <<>> <. vrStruct is the tree of types created by the variant record type constructor. modList is the list of adjectives (modifiers) to be placed in front of the type constructor.>> <<>> VRStruct: TYPE = REF VRStructBody; VRStructBody: TYPE = RECORD[ preamble: Type, -- to be a field list tailName: Rope.ROPE, tagName: Rope.ROPE, tagType: Type, nTailTypes: INT, controlled: BOOL, details: VariantRecordTypeDetails, procData: REF ANY]; VRInfo: TYPE = REF VRInfoBody; VRInfoBody: TYPE = RECORD[ containsVariance: BOOLEAN, self: Type, indirect: Type, tailType: Type, struct: VRStruct, nMods: INT, mods: LIST OF INT, nVariants: CARDINAL, variants: RefTab.Ref]; <> CreateVariantRecordType: PUBLIC PROC[preamble: Type, tailName: Rope.ROPE, tagName: Rope.ROPE, tagType: Type, nTailTypes: INT, controlled: BOOL, details: VariantRecordTypeDetails, cc: CC, procData: REF ANY] RETURNS[Type] = BEGIN struct: VRStruct _ CreateVRStruct[preamble, tailName, tagName, tagType, nTailTypes, controlled, details, cc, procData]; RETURN[BuildVRType[struct, TRUE, nTailTypes, 0, NIL, cc]]; END; CreateVRStruct: PROC[preamble: Type, tailName: Rope.ROPE, tagName: Rope.ROPE, tagType: Type, nTailTypes: INT, controlled: BOOL, details: VariantRecordTypeDetails, cc: CC, procData: REF ANY] RETURNS[VRStruct] = BEGIN struct: VRStruct _ NEW[VRStructBody _ [ preamble: preamble, tailName: tailName, tagName: tagName, tagType: tagType, nTailTypes: nTailTypes, controlled: controlled, details: details, procData: procData]]; RETURN[struct]; END; DetermineVariance: PROC[struct: VRStruct, mods: LIST OF INT, cc: CC] RETURNS[containsVariance: BOOLEAN, nVariants: INT] = BEGIN containsVariance _ CCTypes.ContainsVariance[struct.preamble, cc]; <> IF mods = NIL THEN BEGIN RETURN [containsVariance, struct.nTailTypes]; END ELSE BEGIN tailType: Type _ struct.details.getTailType[mods.first, struct.procData]; IF mods.rest = NIL THEN RETURN [containsVariance OR CCTypes.ContainsVariance[tailType, cc], CCTypes.GetNVariants[tailType, cc]] ELSE BEGIN tailInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[tailType, cc]]; subVariance: BOOLEAN; [subVariance, nVariants] _ DetermineVariance[tailInfo.struct, mods.rest, cc]; RETURN [containsVariance OR subVariance, nVariants]; END; END; END; <> GetVRVariant: PUBLIC PROC[vrType: Type, index: INT, cc: CC] RETURNS[Type] = BEGIN oldInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[vrType, cc]]; key: REF INT _ NEW [INT _ index]; variantRef: REF Type _ NARROW[RefTab.Fetch[oldInfo.variants, key].val]; IF variantRef = NIL THEN BEGIN newMods: LIST OF INT; containsVariance: BOOLEAN _ FALSE; -- tentative nVariants: INT _ -1; -- will be filled in below variant: Type; <<>> <> IF oldInfo.mods = NIL THEN BEGIN newMods _ LIST[index]; END ELSE BEGIN lastNewMods: LIST OF INT; newMods _ LIST[oldInfo.mods.first]; lastNewMods _ newMods; FOR em: LIST OF INT _ oldInfo.mods.rest, em.rest WHILE em # NIL DO cell: LIST OF INT _ LIST[em.first]; lastNewMods.rest _ cell; lastNewMods _ cell; ENDLOOP; lastNewMods.rest _ LIST[index]; END; [containsVariance, nVariants] _ DetermineVariance[oldInfo.struct, newMods, cc]; variant _ BuildVRType[oldInfo.struct, containsVariance, nVariants, oldInfo.nMods+1, newMods, cc]; variantRef _ NEW [Type _ variant]; IF NOT RefTab.Store[oldInfo.variants, key, variantRef] THEN CCE[cirioError]; -- shouldn't happen END; RETURN[variantRef^]; END; BuildVRType: PROC[struct: VRStruct, containsVariance: BOOLEAN, nVariants: INT, nMods: INT, mods: LIST OF INT, cc: CC] RETURNS[Type] = BEGIN newInfo: VRInfo _ NEW[VRInfoBody]; newType: Type _ CCTypes.CreateCedarType[$variantRecord, VariantRecordCCTypeProcs, IndirectVariantRecordCCTypeProcs, cc, newInfo]; newInfo.containsVariance _ containsVariance; newInfo.struct _ struct; newInfo.nMods _ nMods; newInfo.mods _ mods; newInfo.nVariants _ nVariants; newInfo.variants _ RefTab.Create[equal: EqualIndexTypes, hash: HashIndexTypes]; newInfo.tailType _ CCTypes.CreateCedarType[$variantTail, VariantTailCCTypeProcs, IndirectVariantTailCCTypeProcs, cc, newInfo]; RETURN[newType]; END; EqualIndexTypes: PROC[key1, key2: RefTab.Key] RETURNS[BOOL] = BEGIN type1: REF INT _ NARROW[key1]; type2: REF INT _ NARROW[key2]; RETURN[type1^=type2^]; END; HashIndexTypes: PROC[key: RefTab.Key] RETURNS[CARDINAL] = BEGIN type: REF INT _ NARROW[key]; RETURN[type^]; END; VariantRecordCCTypeProcs: REF CCTypes.CCTypeProcs _ NEW[CCTypes.CCTypeProcs _[ checkConformance: VariantRecordCCTypesCheckConformance, checkFamilyInclusion: VariantRecordCCTypesCheckFamilyInclusion, isASingleton: VariantRecordCCTypesIsASingleton, getFieldsType: VariantRecordCCTypesGetFieldsType, getNVariants: VariantRecordCCTypesGetNVariants, operand: VariantRecordCCTypesOperand, constructor: VariantRecordCCTypesConstructor, pairConstructor: VariantRecordCCTypesPairConstructor, extractIdField: VariantRecordCCTypesExtractIdField, getTypeRepresentation: VariantRecordCCTypesGetTypeRepresentation, printType: VariantRecordCCTypesPrintType]]; <> <> <> <> VariantRecordCCTypesCheckConformance: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.ConformanceCheck] = BEGIN valInfo: VRInfo _ NARROW[procData]; WITH CCTypes.GetProcDataFromGroundType[varType, cc] SELECT FROM varInfo: VRInfo => BEGIN valModTail: LIST OF INT _ valInfo.mods; varModTail: LIST OF INT _ varInfo.mods; conforms1: CCTypes.ConformanceCheck _ VRStructsCheckConformance[valInfo.struct, varInfo.struct, cc]; IF conforms1 = no THEN RETURN[no]; IF varInfo.nMods > valInfo.nMods THEN RETURN[no]; FOR I: INT IN [0..valInfo.nMods-varInfo.nMods) DO valModTail _ valModTail.rest ENDLOOP; WHILE valModTail # NIL DO IF valModTail.first # varModTail.first THEN RETURN[no]; valModTail _ valModTail.rest; varModTail _ varModTail.rest; ENDLOOP; RETURN[conforms1]; -- allows for the dontKnow case END; ENDCASE => RETURN[no]; END; VRStructsCheckConformance: PROC[valStruct, varStruct: VRStruct, cc: CC] RETURNS[CCTypes.ConformanceCheck] = BEGIN conforms1: CCTypes.ConformanceCheck; conforms2: CCTypes.ConformanceCheck; conforms3: CCTypes.ConformanceCheck _ yes; -- tentative conforms1 _ CCTypes.CheckConformance[valStruct.preamble, varStruct.preamble, cc]; IF conforms1 = no THEN RETURN[no]; IF NOT Rope.Equal[valStruct.tailName, varStruct.tailName] THEN RETURN[no]; IF NOT Rope.Equal[valStruct.tagName, varStruct.tagName] THEN RETURN[no]; conforms2 _ CCTypes.CheckConformance[valStruct.tagType, varStruct.tagType, cc]; IF conforms2 = no THEN RETURN[no]; IF NOT valStruct.nTailTypes = varStruct.nTailTypes THEN RETURN[no]; FOR I: INT IN [0..valStruct.nTailTypes) DO valTailType: Type _ valStruct.details.getTailType[I, valStruct.procData]; varTailType: Type _ varStruct.details.getTailType[I, varStruct.procData]; SELECT TRUE FROM valTailType = NIL AND varTailType = NIL => NULL; valTailType = NIL AND varTailType # NIL => RETURN[no]; valTailType # NIL AND varTailType = NIL => RETURN[no]; valTailType # NIL AND varTailType # NIL => BEGIN conforms4: CCTypes.ConformanceCheck _ CCTypes.CheckConformance[valTailType, varTailType, cc]; IF conforms4 = no THEN RETURN[no]; IF conforms4 = dontKnow THEN conforms3 _ dontKnow; END; ENDCASE => ERROR; ENDLOOP; IF conforms1 = yes AND conforms2 = yes AND conforms3 = yes THEN RETURN[yes]; RETURN[dontKnow]; END; VariantRecordCCTypesCheckFamilyInclusion: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] = BEGIN valInfo: VRInfo _ NARROW[procData]; WITH CCTypes.GetProcDataFromGroundType[varType, cc] SELECT FROM varInfo: VRInfo => BEGIN valModTail: LIST OF INT _ valInfo.mods; varModTail: LIST OF INT _ varInfo.mods; IF NOT VRStructCheckFamilyInclusion[valInfo.struct, varInfo.struct, cc] THEN RETURN[FALSE]; IF varInfo.nMods > valInfo.nMods THEN RETURN[FALSE]; FOR I: INT IN [0..valInfo.nMods-varInfo.nMods) DO valModTail _ valModTail.rest ENDLOOP; WHILE valModTail # NIL DO IF valModTail.first # varModTail.first THEN RETURN[FALSE]; valModTail _ valModTail.rest; varModTail _ varModTail.rest; ENDLOOP; RETURN[TRUE]; END; ENDCASE => RETURN[FALSE]; END; <> VRStructCheckFamilyInclusion: PROC[valStruct, varStruct: VRStruct, cc: CC] RETURNS[BOOLEAN] = BEGIN Fail: PROC RETURNS [BOOL] ~ { IF flagFail THEN CCE[cirioError, "VariantRecord family inclusion falseness flag"]; RETURN [FALSE]}; IF NOT CCTypes.CheckFamilyInclusion[valStruct.preamble, varStruct.preamble, cc] THEN RETURN Fail[]; IF NOT Rope.Equal[valStruct.tailName, varStruct.tailName] THEN RETURN Fail[]; IF NOT Rope.Equal[valStruct.tagName, varStruct.tagName] THEN RETURN Fail[]; IF NOT CCTypes.CheckFamilyInclusion[valStruct.tagType, varStruct.tagType, cc] THEN RETURN Fail[]; IF NOT valStruct.nTailTypes = varStruct.nTailTypes THEN RETURN Fail[]; FOR I: INT IN [0..valStruct.nTailTypes) DO valTailType: Type _ valStruct.details.getTailType[I, valStruct.procData]; varTailType: Type _ varStruct.details.getTailType[I, varStruct.procData]; SELECT TRUE FROM valTailType = NIL AND varTailType = NIL => {NULL}; valTailType # NIL AND varTailType = NIL => RETURN Fail[]; valTailType = NIL AND varTailType # NIL => RETURN Fail[]; valTailType # NIL AND varTailType # NIL => IF NOT CCTypes.CheckFamilyInclusion[valTailType, varTailType, cc] THEN RETURN Fail[]; ENDCASE => ERROR; ENDLOOP; RETURN[TRUE]; END; flagFail: BOOL _ FALSE; VariantRecordCCTypesIsASingleton: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] = BEGIN -- only if fully differentiated info: VRInfo _ NARROW[procData]; RETURN[NOT info.containsVariance]; -- This needs to be rethought. Does it return true for embedded variant records, whether in preamble or in some tail? END; <> VariantRecordCCTypesGetFieldsType: PROC[rcdType: Type, cc: CC, procData: REF ANY] RETURNS[Type] = BEGIN info: VRInfo _ NARROW[procData]; RETURN[info.struct.preamble]; END; <> <> <<(At one time this was assumed to be the code for CoerceToType. However, while Cedar does default narrows for numerical types (provoked by Coerce), Cedar does not do default narrows for VariantRecord types. Hence, this code will be used for Narrow, when that is installed.)>> <> <> <> <> VariantRecordCCTypesNarrowToType: PROC[targetType: Type, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN IF NOT CCTypes.Conforms[targetType, tc.type, cc] THEN CCE[typeConformity] -- client type error ELSE BEGIN code: Code _ CedarCode.ConcatCode[ tc.code, CedarCode.CodeToCoerce[tc.type, targetType]]; RETURN[[code, targetType]]; END; END; VariantRecordCCTypesGetNVariants: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[INT] = BEGIN info: VRInfo _ NARROW[procData]; RETURN[info.nVariants]; END; VariantRecordCCTypesOperand: PROC[op: CedarCode.Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN SELECT op FROM $dot, $extractId => RETURN[tc]; ENDCASE => CCE[operation]; -- client error, invalid operation END; VariantRecordCCTypesConstructor: PROC[list: LIST OF CSO.ParseTree, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN CCE[unimplemented]; -- not implemented. When we try to implement it, we must be aware that we should never be attempting to construct a union type, but only fully discriminated types? END; VariantRecordCCTypesPairConstructor: PROC[list: LIST OF CirioSyntacticOperations.NameArgPair, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN CCE[unimplemented]; -- not implemented. When we try to implement it, we must be aware that we should never be attempting to construct a union type, but only fully discriminated types? END; <<>> <> VariantRecordCCTypesExtractIdField: PROC[id: Rope.ROPE, fieldContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN info: VRInfo _ NARROW[procData]; IF CCTypes.HasIdField[id, info.struct.preamble, cc] = yes THEN BEGIN -- note: it should be impossible to return possible code1: Code _ CedarCode.CodeToExtractField["&Preamble", fieldContext]; tc2: TypedCode _ CCTypes.ExtractIdField[id, info.struct.preamble, cc]; code: Code _ CedarCode.ConcatCode[code1, tc2.code]; RETURN[[code, tc2.type]]; END ELSE IF Rope.Equal[id, info.struct.tailName] THEN BEGIN code: Code _ CedarCode.CodeToExtractField["&Tail", fieldContext]; RETURN[[code, info.tailType]]; END ELSE BEGIN case: CCTypes.IdFieldCase _ CCTypes.HasIdField[id, info.tailType, cc]; IF info.nVariants = 0 AND case = yes THEN BEGIN code1: Code _ CedarCode.CodeToExtractField["&Tail", fieldContext]; tc2: TypedCode _ CCTypes.ExtractIdField[id, info.tailType, cc]; code: Code _ CedarCode.ConcatCode[code1, tc2.code]; RETURN[[code, tc2.type]]; END ELSE IF case = possible OR case = yes THEN BEGIN -- must worry about overlaid variants (and computed variants?) code1: Code _ CedarCode.CodeToExtractField["&Tail", fieldContext]; nodetc: TypedCode _ CCTypes.CoerceToType[CCTypes.GetNodeType[cc], [CedarCode.NullCode[], fieldContext], cc]; finaltc: TypedCode _ CCTypes.ExtractIdField[id, nodetc.type, cc]; code: Code _ CedarCode.ConcatCode[ code1, CedarCode.ConcatCode[nodetc.code, finaltc.code]]; RETURN[[code, finaltc.type]]; END ELSE CCE[operation, Rope.Cat["field ", id, " does not exist"]]; -- client error, no such field name END END; VariantRecordCCTypesGetTypeRepresentation: PROC [type: Type, cc: CC, procData: REF ANY] RETURNS[REF ANY] = { info: VRInfo _ NARROW[procData]; RETURN[info.struct.procData]; }; VariantRecordCCTypesPrintType: PROC [to: IO.STREAM, type: Type, printDepth: INT, printWidth: INT, cc: CC, procData: REF ANY] = { info: VRInfo _ NARROW[procData]; PrintNamedVariant: PROC ~ { to.PutRope[info.struct.tailName]; to.PutChar[':]; CCTypes.BreakObject[to, PrintUnnamedVariant, " "]; RETURN}; PrintUnnamedVariant: PROC ~ { to.PutRope["SELECT "]; to.PutRope[info.struct.tagName]; to.PutRope[":"]; CCTypes.PrintType[to, info.struct.tagType, 1, printWidth, cc]; SS.Bp[to, lookLeft, 0, " "]; to.PutRope["FROM"]; FOR i: INT IN [0..info.struct.nTailTypes) DO tailType: Type _ info.struct.details.getTailType[i, info.struct.procData]; PrintArm: PROC ~ { enumType: Node _ CedarOtherPureTypes.CreateEnumeratedTypeNodeFromIndex[info.struct.tagType, i, cc]; CedarCode.ShowNode[to, enumType, 1, printWidth, cc]; to.PutRope[" =>"]; SS.Bp[to, width, CCTypes.sia, " "]; CCTypes.DoObject[to, PrintArmType]; RETURN}; PrintArmType: PROC ~ {CCTypes.PrintType[to, tailType, printDepth-1, printWidth, cc]}; IF i>0 THEN {to.PutChar[',]; SS.Bp[to, united, CCTypes.sia, " "]} ELSE to.PutChar[' ]; IF tailType # NIL THEN CCTypes.DoObject[to, PrintArm] ELSE to.PutRope["??"]; ENDLOOP; SS.Bp[to, united, CCTypes.sia, " "]; to.PutRope["ENDCASE]"]; RETURN}; to.PutChar['[]; CCTypes.PrintType[to, info.struct.preamble, printDepth-1, printWidth, cc]; to.PutChar[',]; SS.Bp[to, lookLeft, CCTypes.sia, " "]; IF Rope.IsEmpty[info.struct.tailName] THEN CCTypes.DoObject[to, PrintUnnamedVariant] ELSE CCTypes.DoObject[to, PrintNamedVariant]; RETURN}; IndirectVariantRecordCCTypeProcs: REF CCTypes.CCTypeProcs _ NEW[CCTypes.CCTypeProcs _[ createIndirectNode: VariantRecordCreateIndirect, getBitSize: VariantRecordBitSize, operand: IndirectVariantRecordCCTypesOperand, store: IndirectVariantRecordCCTypesStore, selectIdField: IndirectVariantRecordCCTypesSelectIdField]]; <> VariantRecordCreateIndirect: PROC [cc: CC, procData: REF ANY, indirectType, targetType: Type, mem: Mem] RETURNS [Node] ~ { info: VRInfo _ NARROW[procData]; RETURN info.struct.details.createIndirectNode[cc, info.struct.procData, indirectType, targetType, mem]}; VariantRecordBitSize: PROC[indirectType, targetType: Type, cc: CC, procData: REF ANY] RETURNS[CARD] ~ { info: VRInfo _ NARROW[procData]; RETURN info.struct.details.getBitSize[indirectType, cc, info.struct.procData]}; IndirectVariantRecordCCTypesOperand: PROC[op: CedarCode.Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN SELECT op FROM $selectId, $address => RETURN[tc]; ENDCASE => CCE[operation]; -- client error; invalid operation END; <<>> IndirectVariantRecordCCTypesStore: PROC[value: TypedCode, indirect: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN info: VRInfo _ NARROW[procData]; IF info.containsVariance THEN CCE[operation, "attempt to store into a variant record field"]; -- client error, attempt to store into a (possibly nested) variant record field. (We shall eventually have to allow this for initialization.) <> BEGIN code: Code _ CedarCode.ConcatCode[ indirect.code, CedarCode.ConcatCode[ value.code, CedarCode.CodeToStoreUnpopped[indirect.type, value.type]]]; RETURN[[code, value.type]]; END; END; IndirectVariantRecordCCTypesSelectIdField: PROC[id: Rope.ROPE, fieldIndirectContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN info: VRInfo _ NARROW[procData]; IF CCTypes.HasIdField[id, info.struct.preamble, cc] = yes THEN BEGIN -- note: it should be impossible to return possible code1: Code _ CedarCode.CodeToSelectField["&Preamble", fieldIndirectContext]; tc2: TypedCode _ CCTypes.SelectIdField[id, CCTypes.GetIndirectType[info.struct.preamble], cc]; code: Code _ CedarCode.ConcatCode[code1, tc2.code]; RETURN[[code, tc2.type]]; END ELSE IF Rope.Equal[id, info.struct.tailName] THEN BEGIN code: Code _ CedarCode.CodeToSelectField["&Tail", fieldIndirectContext]; RETURN[[code, info.tailType]]; END ELSE IF info.nVariants = 0 AND CCTypes.HasIdField[id, info.tailType, cc] = yes THEN BEGIN code1: Code _ CedarCode.CodeToSelectField["&Tail", fieldIndirectContext]; tc2: TypedCode _ CCTypes.SelectIdField[id, CCTypes.GetIndirectType[info.tailType], cc]; code: Code _ CedarCode.ConcatCode[code1, tc2.code]; RETURN[[code, tc2.type]]; END ELSE IF CCTypes.HasIdField[id, info.tailType, cc] = possible THEN BEGIN -- I assume that even if all the variants have the id field, HasIdField will have returned possible (rather than yes). Also, must worry about overlaid variants (and computed variants?) code1: Code _ CedarCode.CodeToSelectField["&Tail", fieldIndirectContext]; nodetc: TypedCode _ CCTypes.CoerceToType[CCTypes.GetNodeType[cc], [CedarCode.NullCode[], info.tailType], cc]; finaltc: TypedCode _ CCTypes.SelectIdField[id, nodetc.type, cc]; code: Code _ CedarCode.ConcatCode[ code1, CedarCode.ConcatCode[nodetc.code, finaltc.code]]; RETURN[[code, finaltc.type]]; END ELSE CCE[operation, Rope.Cat["field ", id, " does not exist"]]; -- client error, no such field name END; <<>> <> <<>> <> GetVTVariant: PROC[vtType: Type, index: INT, cc: CC] RETURNS[Type] = BEGIN vrInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[vtType, cc]]; vrType: Type _ vrInfo.self; vrVariant: Type _ GetVRVariant[vrType, index, cc]; vrVariantInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[vrVariant, cc]]; RETURN[vrVariantInfo.tailType]; END; VariantTailCCTypeProcs: REF CCTypes.CCTypeProcs _ NEW[CCTypes.CCTypeProcs _[ checkConformance: VariantTailCCTypesCheckConformance, getNVariants: VariantTailCCTypesGetNVariants, operand: VariantTailCCTypesOperand, hasIdField: VariantTailCCTypesHasIdField, constructor: VariantTailCCTypesConstructor, pairConstructor: VariantTailCCTypesPairConstructor, extractIdField: VariantTailCCTypesExtractIdField]]; <> <> <<>> <> <<>> VariantTailCCTypesCheckConformance: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.ConformanceCheck] = BEGIN valInfo: VRInfo _ NARROW[procData]; WITH CCTypes.GetProcDataFromGroundType[varType, cc] SELECT FROM varInfo: VRInfo => RETURN[CCTypes.CheckConformance[valInfo.self, varInfo.self, cc]]; ENDCASE => RETURN[no]; END; VariantTailCCTypesGetNVariants: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[INT] = BEGIN vrInfo: VRInfo _ NARROW[procData]; RETURN[vrInfo.nVariants]; END; VariantTailCCTypesOperand: PROC[op: CedarCode.Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN SELECT op FROM $extractId => RETURN[tc]; ENDCASE => CCE[operation]; -- client error, illegal operation END; <<>> <> VariantTailCCTypesNarrowToType: PROC[targetType: Type, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN IF NOT CCTypes.Conforms[targetType, tc.type, cc] THEN CCE[typeConformity] -- client type error ELSE BEGIN code: Code _ CedarCode.ConcatCode[ tc.code, CedarCode.CodeToCoerce[tc.type, targetType]]; RETURN[[code, targetType]]; END; END; VariantTailCCTypesHasIdField: PROC[id: Rope.ROPE, fieldContext: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.IdFieldCase] = BEGIN vrInfo: VRInfo _ NARROW[procData]; struct: VRStruct _ vrInfo.struct; IF Rope.Equal[struct.tagName, id] THEN RETURN[yes]; IF vrInfo.nMods # 0 THEN -- we are discriminated RETURN[CCTypes.HasIdField[id, struct.details.getTailType[vrInfo.mods.first, struct.procData], cc]] ELSE BEGIN -- we are not discriminated FOR I: INT IN [0..struct.nTailTypes) DO tailType: CirioTypes.Type _ struct.details.getTailType[I, struct.procData]; IF tailType # NIL AND CCTypes.HasIdField[id, tailType, cc] # no THEN RETURN[possible]; ENDLOOP; RETURN[no]; END; END; VariantTailCCTypesConstructor: PROC[list: LIST OF CSO.ParseTree, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN CCE[unimplemented]; -- not implemented. When we try to implement it, we must be aware that we should never be attempting to construct a union type, but only fully discriminated types? END; VariantTailCCTypesPairConstructor: PROC[list: LIST OF CirioSyntacticOperations.NameArgPair, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN CCE[unimplemented]; -- not implemented. When we try to implement it, we must be aware that we should never be attempting to construct a union type, but only fully discriminated types? END; <, where tailBody is one of the types obtained by struct.details.getTailType.>> VariantTailCCTypesExtractIdField: PROC[id: Rope.ROPE, fieldContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN vrInfo: VRInfo _ NARROW[procData]; struct: VRStruct _ vrInfo.struct; IF Rope.Equal[id, struct.tagName] THEN BEGIN code: Code _ CedarCode.CodeToExtractField["&Tag", fieldContext]; RETURN[[code, struct.tagType]]; END ELSE IF vrInfo.nMods # 0 THEN -- we are discriminated BEGIN code1: Code _ CedarCode.CodeToExtractField["&TailBody", fieldContext]; tc2: TypedCode _ CCTypes.ExtractIdField[id, struct.details.getTailType[vrInfo.mods.first, struct.procData], cc]; code: Code _ CedarCode.ConcatCode[code1, tc2.code]; RETURN[[code, tc2.type]]; END ELSE -- we are not discriminated, so must investigate each variant to see if the id is possible. If we find one for which it is possible, then we package everything up in a node for run time decisions. (This is non Cedar semantics.) BEGIN possible: BOOLEAN _ FALSE; FOR I: INT IN [0..struct.nTailTypes) DO tailType: Type _ struct.details.getTailType[I, struct.procData]; IF tailType = NIL THEN LOOP ELSE BEGIN case: CCTypes.IdFieldCase _ CCTypes.HasIdField[id, tailType, cc]; IF case = yes OR case = possible THEN {possible _ TRUE; EXIT}; END; ENDLOOP; IF NOT possible THEN CCE[operation, Rope.Cat["field ", id, " does not exist"]] -- client type error, no such field ELSE BEGIN nodetc: TypedCode _ CCTypes.CoerceToType[CCTypes.GetNodeType[cc], [CedarCode.NullCode[], NIL], cc]; finaltc: TypedCode _ CCTypes.ExtractIdField[id, nodetc.type, cc]; code: Code _ CedarCode.ConcatCode[nodetc.code, finaltc.code]; RETURN[[code, finaltc.type]]; END; END; END; IndirectVariantTailCCTypeProcs: REF CCTypes.CCTypeProcs _ NEW[CCTypes.CCTypeProcs _[ store: IndirectVariantTailCCTypesStore, load: IndirectVariantTailCCTypesLoad, selectIdField: IndirectVariantTailCCTypesSelectIdField]]; <> <> <> <> IndirectVariantTailCCTypesStore: PROC[value: TypedCode, indirect: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN IF CCTypes.ContainsVariance[CCTypes.GetRTargetType[indirect.type, cc], cc] THEN CCE[operation, "attempt to store into a variant record field"]; -- client error, attempt to store into a (possibly nested) variant record field. (We shall eventually have to allow this for initialization.) <> BEGIN code: Code _ CedarCode.ConcatCode[ indirect.code, CedarCode.ConcatCode[ value.code, CedarCode.CodeToStoreUnpopped[indirect.type, value.type]]]; RETURN[[code, value.type]]; END; END; IndirectVariantTailCCTypesLoad: PROC[indirect: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN code: Code _ CedarCode.ConcatCode[ indirect.code, CedarCode.CodeToLoadThroughIndirect[indirect.type]]; type: Type _ CCTypes.GetRTargetType[indirect.type, cc]; RETURN[[code, type]]; END; <<>> <<>> <> <> <> <> IndirectVariantTailCCTypesSelectIdField: PROC[id: Rope.ROPE, fieldIndirectContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN vrInfo: VRInfo _ NARROW[procData]; struct: VRStruct _ vrInfo.struct; IF Rope.Equal[id, struct.tagName] THEN BEGIN code: Code _ CedarCode.CodeToSelectField["&Tag", fieldIndirectContext]; RETURN[[code, struct.tagType]]; END ELSE IF vrInfo.nMods # 0 THEN -- we are discriminated BEGIN code1: Code _ CedarCode.CodeToSelectField["&TailBody", fieldIndirectContext]; tc2: TypedCode _ CCTypes.SelectIdField[id, CCTypes.GetIndirectType[struct.details.getTailType[vrInfo.mods.first, struct.procData]], cc]; code: Code _ CedarCode.ConcatCode[code1, tc2.code]; RETURN[[code, tc2.type]]; END ELSE -- we are not discriminated, so must investigate each variant to see if the id is possible. If we find one for which it is possible, then we package everything up in a node for run time decisions. (This is non Cedar semantics.) BEGIN possible: BOOLEAN _ FALSE; FOR I: INT IN [0..struct.nTailTypes) DO tailType: Type _ struct.details.getTailType[I, struct.procData]; IF tailType = NIL THEN LOOP ELSE BEGIN case: CCTypes.IdFieldCase _ CCTypes.HasIdField[id, tailType, cc]; IF case = yes OR case = possible THEN {possible _ TRUE; EXIT}; END; ENDLOOP; IF NOT possible THEN CCE[operation, Rope.Cat["field ", id, " does not exist"]] -- client type error, no such field ELSE BEGIN nodetc: TypedCode _ CCTypes.CoerceToType[CCTypes.GetNodeType[cc], [CedarCode.NullCode[], fieldIndirectContext], cc]; code1: Code _ CedarCode.CodeToSelectField["&TailBody", nodetc.type]; finaltc: TypedCode _ CCTypes.SelectIdField[id, CCTypes.GetNodeType[cc], cc]; code: Code _ CedarCode.ConcatCode[nodetc.code, CedarCode.ConcatCode[code1, finaltc.code]]; RETURN[[code, finaltc.type]]; END; END; END; <> <<>> <> <<>> <> <<>> <> <<>> IndirectVRNodeProcs: TYPE = VariantRecords.IndirectVRNodeProcs; IndirectVRData: TYPE = RECORD[ targetType: Type, vrInfo: VRInfo, procs: REF IndirectVRNodeProcs, indirectTail: Node, procsData: REF ANY]; CreateIndirectVariantRecordNode: PUBLIC PROC[vrType: CirioTypes.Type, procs: REF IndirectVRNodeProcs, procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN vrTypeInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[vrType, cc]]; vtType: Type _ vrTypeInfo.tailType; ivrData: REF IndirectVRData _ NEW[IndirectVRData _ [vrType, vrTypeInfo, procs, NIL, procsData]]; node: Node _ CedarCode.CreateCedarNode[IndirectVROps, CCTypes.GetIndirectType[vrType], ivrData]; ivrData.indirectTail _ CreateIndirectVariantTailNode[vtType, ivrData, cc]; RETURN[node]; END; IndirectVROps: REF CedarCode.OperationsBody _ NEW[CedarCode.OperationsBody_[ getCurrentType: IndirectVRGetCurrentType, unaryOp: IndirectVRUnaryOp, store: IndirectVRStore, load: IndirectVRLoad, selectField: IndirectVRSelectField, show: IndirectVRShow]]; <> <<>> <> <<>> <> <> <<>> IndirectVRGetCurrentType: PROC[node: Node, cc: CC] RETURNS[Type] = {RETURN[CCTypes.GetIndirectType[ObtainTargetValueType[node, cc]]]}; IndirectVRUnaryOp: PROC [op: CedarCode.Operator, type: CirioTypes.Type, node: CirioTypes.Node, cc: CC] RETURNS [CirioTypes.Node] = BEGIN indirectNodeData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[node]]; RETURN[indirectNodeData.procs.getPointer[indirectNodeData.procsData, cc]]; END; IndirectVRStore: PROC[valType: Type, valNode: Node, indirectType: Type, indirectNode: Node, cc: CC] = BEGIN indirectData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; indirectPreamble: Node _ CedarCode.SelectFieldFromNode["&Preamble", indirectType, indirectNode, cc]; indirectPreambleType: Type _ CedarCode.GetTypeOfNode[indirectPreamble]; indirectTail: Node _ CedarCode.SelectFieldFromNode["&Tail", indirectType, indirectNode, cc]; indirectTailType: Type _ CedarCode.GetTypeOfNode[indirectTail]; valPreamble: Node _ CedarCode.ExtractFieldFromNode["&Preamble", valType, valNode, cc]; valPreambleType: Type _ CedarCode.GetTypeOfNode[valPreamble]; valTail: Node _ CedarCode.ExtractFieldFromNode["&Tail", valType, valNode, cc]; valTailType: Type _ CedarCode.GetTypeOfNode[valTail]; IF CCTypes.ContainsVariance[indirectData.targetType, cc] THEN CCE[operation, "attempt to store into a variant record field"]; -- client error? we don't permit stores into target types that contain variance. CedarCode.StoreThroughIndirectNode[valPreambleType, valPreamble, indirectPreambleType, indirectPreamble, cc]; CedarCode.StoreThroughIndirectNode[valTailType, valTail, indirectTailType, indirectTail, cc]; END; <> IndirectVRLoad: PROC[indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] = BEGIN valType: Type _ ObtainTargetValueType[indirectNode, cc]; data: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; RETURN[CreateVariantRecordNode[valType, DLVRProcs, data, cc, FALSE]]; END; IndirectVRSelectField: PROC[id: Rope.ROPE, indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] = BEGIN data: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; SELECT TRUE FROM Rope.Equal[id, "&Preamble"] => RETURN[data.procs.selectPreamble[data.procsData, cc]]; Rope.Equal[id, "&Tail"] => RETURN[data.indirectTail]; ENDCASE => CCE[cirioError]; -- shouldn't happen END; IndirectVRShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = { ivrType: Type _ CedarCode.GetTypeOfNode[node]; vr: Node _ CedarCode.LoadThroughIndirectNode[ivrType, node, cc]; to.PutChar['^]; CedarCode.ShowNode[to, vr, depth-1, width, cc]; RETURN}; <> <> ObtainTargetValueType: PROC[indirectNode: Node, cc: CC] RETURNS[Type] = BEGIN data: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; tvt: Type _ data.targetType; vrInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[tvt, cc]]; WHILE vrInfo.nVariants # 0 DO -- we still have variability. Dig into the data structure and come up with the first index value from a so-far undifferentiated level. index: INT _ TailGetNextUndifferentiatedIndex[CCTypes.GetIndirectType[vrInfo.tailType], data.indirectTail, cc]; tvt _ GetVRVariant[tvt, index, cc]; vrInfo _ NARROW[CCTypes.GetProcDataFromGroundType[tvt, cc]]; ENDLOOP; RETURN[tvt]; END; VRGetNextUndifferentiatedIndex: PROC[indirectVRType: Type, indirectVRNode: Node, cc: CC] RETURNS[INT] = BEGIN targetVRType: Type _ CCTypes.GetRTargetType[indirectVRType, cc]; targetVRInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[targetVRType, cc]]; targetTailType: Type _ targetVRInfo.tailType; indirectVRData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectVRNode]]; indirectTail: Node _ indirectVRData.indirectTail; RETURN[TailGetNextUndifferentiatedIndex[CCTypes.GetIndirectType[targetTailType], indirectTail, cc]]; END; <> <<>> DLVRProcs: REF VariantRecordNodeProcs _ NEW[VariantRecordNodeProcs _[ extractPreamble: DLVRExtractPreamble, variantIndex: DLVRVariantIndex, extractTag: DLVRExtractTag, extractTailBody: DLVRExtractTailBody]]; DLVRExtractPreamble: PROC[procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN ivrData: REF IndirectVRData _ NARROW[procsData]; indirectToField: Node _ ivrData.procs.selectPreamble[ivrData.procsData, cc]; indirectFieldType: Type _ CedarCode.GetTypeOfNode[indirectToField]; RETURN[CedarCode.LoadThroughIndirectNode[indirectFieldType, indirectToField, cc]]; END; DLVRVariantIndex: PROC[procsData: REF ANY, cc: CC] RETURNS[INT] = BEGIN ivrData: REF IndirectVRData _ NARROW[procsData]; IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; RETURN[ivrData.procs.readVariantIndex[ivrData.procsData, cc]]; END; DLVRExtractTag: PROC[procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN ivrData: REF IndirectVRData _ NARROW[procsData]; IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; { indirectToTag: Node _ ivrData.procs.selectTag[ivrData.procsData, cc]; indirectTagType: Type _ CedarCode.GetTypeOfNode[indirectToTag]; RETURN[CedarCode.LoadThroughIndirectNode[indirectTagType, indirectToTag, cc]]; }; END; DLVRExtractTailBody: PROC[procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN ivrData: REF IndirectVRData _ NARROW[procsData]; IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; { indirectToTailBody: Node _ ivrData.procs.selectTailBody[ivrData.procsData, cc]; indirectTailType: Type _ CedarCode.GetTypeOfNode[indirectToTailBody]; RETURN[CedarCode.LoadThroughIndirectNode[indirectTailType, indirectToTailBody, cc]]; } END; <<>> <> <<>> <> <> <> CreateIndirectVariantTailNode: PROC[vtType: CirioTypes.Type, ivrData: REF IndirectVRData, cc: CC] RETURNS[CirioTypes.Node] = BEGIN node: Node _ CedarCode.CreateCedarNode[IndirectVTOps, CCTypes.GetIndirectType[vtType], ivrData]; RETURN[node]; END; IndirectVTOps: REF CedarCode.OperationsBody _ NEW[CedarCode.OperationsBody_[ getCurrentType: IndirectVTGetCurrentType, store: IndirectVTStore, load: IndirectVTLoad, selectField: IndirectVTSelectField, show: IndirectVTShow]]; <> IndirectVTGetCurrentType: PROC[node: Node, cc: CC] RETURNS[Type] = BEGIN typeOfVR: Type _ ObtainTargetValueType[node, cc]; vrInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[typeOfVR, cc]]; RETURN[CCTypes.GetIndirectType[vrInfo.tailType]]; END; <> IndirectVTStore: PROC[valType: Type, valNode: Node, indirectType: Type, indirectNode: Node, cc: CC] = BEGIN ivrData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; { indirectTag: Node _ ivrData.procs.selectTag[ivrData.procsData, cc]; indirectTagType: Type _ CedarCode.GetTypeOfNode[indirectTag]; indirectTailBody: Node _ ivrData.procs.selectTailBody[ivrData.procsData, cc]; indirectTailBodyType: Type _ CedarCode.GetTypeOfNode[indirectTailBody]; valTag: Node _ CedarCode.ExtractFieldFromNode["&Tag", valType, valNode, cc]; valTagType: Type _ CedarCode.GetTypeOfNode[valTag]; valTailBody: Node _ CedarCode.ExtractFieldFromNode["&TailBody", valType, valNode, cc]; valTailBodyType: Type _ CedarCode.GetTypeOfNode[valTailBody]; IF CCTypes.ContainsVariance[ivrData.targetType, cc] THEN CCE[operation, "attempt to store into a variant record field"]; -- client error? we don't permit stores into target types that contain variance. <> <<>> CedarCode.StoreThroughIndirectNode[valTailBodyType, valTailBody, indirectTailBodyType, indirectTailBody, cc]; } END; IndirectVTLoad: PROC[indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] = BEGIN valType: Type _ ObtainTargetValueType[indirectNode, cc]; ivrData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; CCE[cirioError]; -- can this happen? if so, somehow I have to load the enclosing variantrecord, then extract the tail field. END; IndirectVTSelectField: PROC[id: Rope.ROPE, indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] = BEGIN ivrData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectNode]]; SELECT TRUE FROM Rope.Equal[id, "&Tag"] => IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"] ELSE RETURN[ivrData.procs.selectTag[ivrData.procsData, cc]]; Rope.Equal[id, "&TailBody"] => IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"] ELSE RETURN[ivrData.procs.selectTailBody[ivrData.procsData, cc]]; ENDCASE => CCE[cirioError]; -- shouldn't happen END; IndirectVTShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = { ivtType: Type _ CedarCode.GetTypeOfNode[node]; vt: Node _ CedarCode.LoadThroughIndirectNode[ivtType, node, cc]; CedarCode.ShowNode[to, vt, depth, width, cc]; RETURN}; <> <> TailGetNextUndifferentiatedIndex: PROC[indirectTailType: Type, indirectTailNode: Node, cc: CC] RETURNS[INT] = BEGIN -- this code will be better fleshed out when we have implemented the tail nodes targetTailType: Type _ CCTypes.GetRTargetType[indirectTailType, cc]; targetVRInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[targetTailType, cc]]; ivrData: REF IndirectVRData _ NARROW[CedarCode.GetDataFromNode[indirectTailNode]]; IF targetVRInfo.nMods = 0 THEN -- we are at an undifferentiated level IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"] ELSE RETURN[ivrData.procs.readVariantIndex[ivrData.procsData, cc]] ELSE -- we are still differentiated, burrow deeper BEGIN indirectVRType: Type _ CCTypes.GetIndirectType[targetVRInfo.struct.details.getTailType[targetVRInfo.mods.first, targetVRInfo.struct.procData]]; IF NOT ivrData.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; { indirectVRNode: Node _ ivrData.procs.selectTailBody[ivrData.procsData, cc]; RETURN[VRGetNextUndifferentiatedIndex[indirectVRType, indirectVRNode, cc]] } END; END; <<>> <> VariantRecordNodeProcs: TYPE = VariantRecords.VariantRecordNodeProcs; VRData: TYPE = RECORD[ type: Type, vrInfo: VRInfo, self: Node, alreadyLoaded: BOOLEAN, procs: REF VariantRecordNodeProcs, tail: Node, procsData: REF ANY]; CreateVariantRecordNode: PUBLIC PROC[type: CirioTypes.Type, procs: REF VariantRecordNodeProcs, procsData: REF ANY, cc: CC, alreadyLoaded: BOOLEAN] RETURNS[CirioTypes.Node] = BEGIN vrTypeInfo: VRInfo _ NARROW[CCTypes.GetProcDataFromGroundType[type, cc]]; vtType: Type _ vrTypeInfo.tailType; vrData: REF VRData _ NEW[VRData _ [type, vrTypeInfo, NIL, alreadyLoaded, procs, NIL, procsData]]; node: Node _ CedarCode.CreateCedarNode[VariantRecordOps, type, vrData]; vrData.self _ node; vrData.tail _ CreateVariantTailNode[vtType, vrData, cc]; RETURN[node]; END; VariantRecordOps: REF CedarCode.OperationsBody _ NEW[CedarCode.OperationsBody_[ forceIn: VRForceIn, extractField: VRExtractField, show: VRShow]]; VRForceIn: PROC[type: Type, node: Node, cc: CC] RETURNS[Node] = BEGIN data: REF VRData _ NARROW[CedarCode.GetDataFromNode[node]]; IF data.alreadyLoaded THEN RETURN[node] ELSE BEGIN nodeType: Type _ CedarCode.GetTypeOfNode[node]; nominalPreamble: Node _ data.procs.extractPreamble[data.procsData, cc]; preambleType: Type _ CedarCode.GetTypeOfNode[nominalPreamble]; preamble: Node _ CedarCode.ForceNodeIn[preambleType, nominalPreamble, cc]; IF NOT data.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; {index: INT _ data.procs.variantIndex[data.procsData, cc]; nominalTag: Node _ data.procs.extractTag[data.procsData, cc]; tagType: Type _ CedarCode.GetTypeOfNode[nominalTag]; tag: Node _ CedarCode.ForceNodeIn[tagType, nominalTag, cc]; nominalTailBody: Node _ data.procs.extractTailBody[data.procsData, cc]; tailBodyType: Type _ CedarCode.GetTypeOfNode[nominalTailBody]; tailBody: Node _ CedarCode.ForceNodeIn[tailBodyType, nominalTailBody, cc]; RETURN[ConstructVariantRecord[nodeType, preamble, index, tag, tailBody, cc]];} END; END; VRExtractField: PROC[id: Rope.ROPE, type: Type, node: Node, cc: CC] RETURNS[Node] = BEGIN data: REF VRData _ NARROW[CedarCode.GetDataFromNode[node]]; SELECT TRUE FROM Rope.Equal[id, "&Preamble"] => RETURN[data.procs.extractPreamble[data.procsData, cc]]; Rope.Equal[id, "&Tail"] => RETURN[data.tail]; ENDCASE => CCE[cirioError]; -- shouldn't happen END; VRShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = { data: REF VRData _ NARROW[CedarCode.GetDataFromNode[node]]; to.PutRope["["]; CedarCode.ShowNode[to, data.procs.extractPreamble[data.procsData, cc], depth-1, width, cc]; to.PutRope[","]; SS.Bp[to, lookLeft, CCTypes.sia, " "]; CedarCode.ShowNode[to, data.tail, depth-1, width, cc]; to.PutRope["]"]; RETURN}; <> <<>> <> ConstructVariantRecord: PROC[vrType: Type, preamble: Node, index: INT, tag: Node, tailBody: Node, cc: CC] RETURNS[Node] = BEGIN cvrData: REF CVRProcsData _ NEW[CVRProcsData_[ preamble, index, tag, tailBody]]; RETURN[CreateVariantRecordNode[vrType, ConstructedVRProcs, cvrData, cc, TRUE]]; END; CVRProcsData: TYPE = RECORD[ preamble: Node, index: INT, tag: Node, tailBody: Node]; ConstructedVRProcs: REF VariantRecordNodeProcs _ NEW[VariantRecordNodeProcs _[ extractPreamble: CVRExtractPreamble, variantIndex: CVRVariantIndex, extractTag: CVRExtractTag, extractTailBody: CVRExtractTailBody]]; CVRExtractPreamble: PROC[procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN cvrData: REF CVRProcsData _ NARROW[procsData]; RETURN[cvrData.preamble]; END; CVRVariantIndex: PROC[procsData: REF ANY, cc: CC] RETURNS[INT] = BEGIN cvrData: REF CVRProcsData _ NARROW[procsData]; RETURN[cvrData.index]; END; CVRExtractTag: PROC[procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN cvrData: REF CVRProcsData _ NARROW[procsData]; RETURN[cvrData.tag]; END; CVRExtractTailBody: PROC[procsData: REF ANY, cc: CC] RETURNS[CirioTypes.Node] = BEGIN cvrData: REF CVRProcsData _ NARROW[procsData]; RETURN[cvrData.tailBody]; END; <<>> <> <<>> <<>> CreateVariantTailNode: PUBLIC PROC[type: CirioTypes.Type, vrData: REF VRData, cc: CC] RETURNS[CirioTypes.Node] = BEGIN node: Node _ CedarCode.CreateCedarNode[VariantTailOps, type, vrData]; RETURN[node]; END; VariantTailOps: REF CedarCode.OperationsBody _ NEW[CedarCode.OperationsBody_[ forceIn: VTForceIn, extractField: VTExtractField, show: VTShow]]; VTForceIn: PROC[type: Type, node: Node, cc: CC] RETURNS[Node] = BEGIN data: REF VRData _ NARROW[CedarCode.GetDataFromNode[node]]; IF data.alreadyLoaded THEN RETURN[node] ELSE BEGIN vrNode: Node _ data.self; vrType: Type _ CedarCode.GetTypeOfNode[vrNode]; vrIn: Node _ VRForceIn[vrType, vrNode, cc]; vrInData: REF VRData _ NARROW[CedarCode.GetDataFromNode[vrIn]]; RETURN[vrInData.tail]; END; END; VTExtractField: PROC[id: Rope.ROPE, type: Type, node: Node, cc: CC] RETURNS[Node] = BEGIN data: REF VRData _ NARROW[CedarCode.GetDataFromNode[node]]; SELECT TRUE FROM Rope.Equal[id, "&Tag"] => IF NOT data.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"] ELSE RETURN[data.procs.extractTag[data.procsData, cc]]; Rope.Equal[id, "&TailBody"] => IF NOT data.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"] ELSE RETURN[data.procs.extractTailBody[data.procsData, cc]]; ENDCASE => CCE[cirioError]; -- shouldn't happen END; VTShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = { data: REF VRData _ NARROW[CedarCode.GetDataFromNode[node]]; to.PutChar['(]; IF NOT data.vrInfo.struct.controlled THEN CCE[cirioError, "Unimplemented operation on unbound variant record"]; CedarCode.ShowNode[to, data.procs.extractTag[data.procsData, cc], depth, width, cc]; to.PutChar[')]; IF depth = 0 THEN to.PutRope["[...]"] ELSE CedarCode.ShowNode[to, data.procs.extractTailBody[data.procsData, cc], depth-1, width, cc]; RETURN}; END..