
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: 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;


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;

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..
  %  
VariantRecordsImpl.mesa
Copyright Ó 1991, 1992 by Xerox Corporation.  All rights reserved.
Sturgis, March 28, 1989 1:11:15 pm PST
Last changed by Theimer on November 28, 1989 5:36:33 pm PST
Hopcroft July 26, 1989 11:04:55 am PDT
Spreitze, January 10, 1992 8:09 am PST
Laurie Horton, January 29, 1992 9:53 am PST
Philip James, January 28, 1992 5:55 pm PST
Variant Records are a union type.  They are not a variety of record, although I tried that as one implementation.  That led to too many complications, lots of selects trying to decide whether we had a record in hand or a variant record.  

A variant record has fixed type preamble (which is a FieldList type) and a variable type tail.
For the moment, we also include the representation of a discriminated type as well.


A variant record type will be described by a pair: <vrStruct, modList>.  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.

note: these variants may be due to variation quite deep in the tail types.
Check the variance of the variant record's preamble.
note: if we are already discriminated, then the index applies to the first nested level of undiscriminated variant record.

Copy the given list and add the new index element.
Remember: valType is the standard control parameter.
valType confroms to varType if their corresponding structs conform, and var.mods is a final subsequence of val.mods.
Issue: Paint?
Issue: someone must block storage of a variant record into a variant record field that is not fully discriminated, unless the store is for initialization.
If the fully undifferentiated types don't agree, then we stop immediately.  I am not sure how Cedar really handles these subtlties.
WHO calls this?
tc.type is the standard control parameter
we can assume that conforms returns false
(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.)
This Narrow is only possible if tc.type and targetType have the same VariantRecordStructure and tc.type is less discriminated than targetType, i.e., that targetType conforms to tc.type.
The Narrow is implemented by a run-time coercion, that may raise an exception.
If this is all satisfied, then the run time check will be for exact discrimination.
Also, perhaps this is the place to prevent stores into non fully discriminated variant record fields (except for initialization)

I think that there is some amibiguity about leaving off the field name of the tail field in a field-path-name.
remark: The code in the following two procedures is similar to that for for record types.  Maybe there is some common default I should be using.

so it is ok to do it

I am forced to invent a type for the variant tail part of variant records.  These can be loaded onto the stack when a source program explicitly supplies the name of the tail in a sequence of field names.  The code generation associated with varaint records will only have the name for the tail field in hand, and won't have an id to use inside that field.  Hence, it can only generate code to put the tail on the stack, and leave it up to the caller to generate code to delve inside.

note: if we are already discriminated, then the index applies to the first nested level of undiscriminated variant record
As for the case of VariantRecord, we no longer provide a CoerceToType routine, but will eventually provide a NarrowToType.
One can conceive of a weaker conforms test than the one I provide here.  A vrTailType is a pure (discriminated) union.  One might return true in the following circumstance: The val tag type is the same as the var tag type.  (Or is a subrange of the var tag type?)  Not all val tag values correspond to a variant, but those that do conform to the corresponding variant of the var type. However, here we perform a much stronger test.  We require that the overlying variantRecords conform, which includes the requirement that the preambles conform.  I am not sure of what the real Cedar compiler does.

February 13, 1989 1:21:02 pm PST  Upon reading this code I am not sure that it is strong enough.  For example, does it check that the tag types and names are correct?.  etc.


This code seems to be the same for any union type?
Understand.  We are a union type.  Hence, the value on top of the stack is an element of our union type.  Such an element is a pair: <tag, tailBody>, where tailBody is one of the types obtained by struct.details.getTailType.
MJS, May 22, 1991: Hypothesis: we can omit createIndirectNode and getBitSize 'cause they'll never be called.
As commented above, these three procedures feel like they should default somehow to standard procedures.
indirect.type is the standard control parameter
MUST FIX: we should be testing CCTypes.ContainsVariance rather than this explicit test.  Otherwise we will not catch stores into records containing variant record fields.
so it is ok to do it


WARNING: the indirect to tag field must have ReadOnly features.
So I have to build it here, for the moment.
Moreover, it is not clear where I have shown (or tested), when we are storing into a fully discriminated variant record variable a fully discriminated variant record value that conforms, that the tag values are the same.  I guess we depend upon the caller of the various create functions to have assured us of that?
Note: This code was constructed by copying VariantTailCCTypesExtractdField and replacing each extract with a select, and a few Foos with indirectFoos.  There must be a better way.
Nodes begin here

There will be a node for each indirect type and a node for each direct type.  four nodes in all.  However, there will be more than one set of procs for the direct types: e.g, a deferred load implementation and a fully loaded implementation.  Further, as we did for types, we use a single data structure for a VariantRecord and for the VariantTail that it contains.

indirect variant record nodes

note: these procedures act almost as if we were implementing an indirect field list with known field names (&Preamble and &Tail).  However, there are some differences relating to the behavior as a union type. Perhaps there would be some simpler implementation that could use a field list node to hold the preamble and tail field.)

For the moment, we permit a store only if the target type contains no variance.  This is a protection against the possible problems that follow from the combined non-atomic store and non-atomic right.  Presumably, if the target type contains no variance, and the source value type conforms to the target type, then we shall not be changing any tag values.  Ultimately, we may allow a store if we go out and check all the possible target tags against source tags.  (At this writing, I havn't checked to see if real Cedar allows such a store.)  This still depends on tags never changing after initialization.  [Oh, we also eventually have to make provision to allow a store during initialization.]  Or, we could invent (non Cedar) style implementations in which assorted appropriate read and write locks are installed.

Further: I suspect that if the target type contains variance, this store would never have been generated?

WARNING: We have to put the no-variance check into record stores as well, in record impl.
General Comment: (Applies to all my implementation modules.)  I seem to sometimes write the code for node operations using information from the supplied types, and sometimes from the types obtained from the nodes.  For purity, if these routines were to become a stage in a compiler, they would only have the supplied types, and hence I should only be using the supplied types!

This is where we have to nail down the actual type of the target value.  This may require inspecting several levels of tag value (or the equivalent).  However, it does not require discriminating the types of embedded fields that happen to be union types. 
support code
This code is n-squared in the depth of the variant record nesting.  That shouldn't be much of a problem because we rarely create such a nesting more than three levels deep.  If it is a problem, then it could be replaced by code that generates call-backs with the successive index values of undiscriminated levels in the nesting.
deferred load variant record procs


indirect vr tail nodes

a vr tail essentially has two fields:
tag field
tail body
There is a problem here.  ObtainTargetValueType assumes that its node is an indirectVR, not an indirectVT.  This same problem holds for IndirectVTLoad.  Either these routines are never called, or I will have to fix this.  I am not at all sure if the present code will work.
For the moment, we will permit this only then the target type is both fully discriminated and contains no variance
We don't store the tag field because it is not supposed to change?

support code
see notes above for support code associated with ObtainTargetValueType

variant record nodes
constructed variant records

Note: constructed field lists code has two cases correspodning to whether we are presented with nodes as preamble and tail, or not.  I have not yet programmed that situation, since I have not yet prepared for variant record constructors in the acceptable syntax.  When I permit such constructors in the syntax (i.e., more than just inspection), then I have to consider that case here?

vr tail nodes


 Ę,Ř  (cedarcode) styleNewlineDelimiter
 codeK
Ďe7BK&&K;K&K&K+K*K Ďk		K°!ŕK7K.>K
ÂŃK%>KK!-KKKH\K Ďn!K*!TKK	@K K&NK K&KKK'KKK+IK KîîK K^^KSSK K KôôK K
"KĎc%KKKKKK""K
K KKKKKKKKKKJJK K K  )ÝKKwK:KK  )ŃK'KKKKKKKKK K	KK yKAK4KK'-KKKIKLgKK2KKKMK4KKKK  KzzKKK0HK	
"K*GK KK	K /K /KK K22KK
KKKK
#KBK	#KKKKKK KOK KaK#K	1 `KK KKK %	KK"KK K,KKKKKOK K~K
KK =KKKKKK 9KKKKK NK7K?K/K1K/K%K-K5K3KAAK+ K44KttK KK$KK#K 0?KK'K'KdK"K1	"1KKK%7KKKK 2KKK K KK K %kKK$K$K+ 7K KQK"K4JK2HKOK"K-C	*KIKIK	0K	6K	6*KK]K"K2KKKK
LKKK (rKK#K 0?KK'K'K K
B[K4	"1KKK%:KKKKKKK K
%]KK
>RKKJcK4MK2KKHaK-F	*KIKIK	2K	9K	9+K<UKKKKK
K  `K %K K vK K!aKK KK K K))K))KKššKNNKSSK &wK	+ ^K"KK-KKKK  \KK KKK %KKK "=KK "KK ¤¸KK #=KK ¤¸KK K K Knn"
{KK K 8>K 39KFKFK3KK&1KKAKKKKF)KKBK?K3KK*K >DKBKlKA"KK1KKK8 #cKK KK )lK KKK K K!!KK2KKK  KK>>KK,KJKcK44KK!#K#KKCUK"AKK#KKK"$KKKKJJKK$&$&K*.K)-KK K  K K  VK0K!K-K)K;K KK ,zK KbhK %gK KIOK #%KK"K "=KK !,~KK K K= ëK K"KKK;KKKK )
"KK K 8>K 39KMK^K3KK&1KKHKK1SKKIKWK3KK6AK šżKIKmK@"KK1KKK8 #cKK K K KăăK  Kyy
DKK0GKK2K3QKKK K LK5K-K#K)K+K3K3K Kzz KÖÖK K­­K "}KK#K 0?K;AKKK ZKK"KKK %KKK "=KK K22&uK	+ ^K"KK-KKKK 
KK"K!K 3 0K\bK !	'KKK
+VKKKKK "KK ¤¸KK !=KK ¤¸K Kŕŕ 
yKK"K!K  &KK@KK 5KKFKpK3KK ĺęKK
	'K@	 KKAK
>KK	
7 #rKKYcKAK=KKKKK K K TK'K%K9KlK  Khh K//KŞŞ,|KK KI> K K"KKK;KKKK iK"KK4K7KK K K??K++KťťKłł'
"KK"K!K  &KKGKK 5KKMKK3KK ĺęKK
	'K@	 KKAK
>KK	
7 #rKKtKDKL.K+KKKK K K KěěK  K KĘĘK K K&?K KKKKKK !!KK0KK#K	.`K`K KJKKK LK)KKKK#K K°°K KiiK KYYKřřK BK<CK 
ĐbnĄLKK"OKDJKK KeKK*SKdKGK\K?KVK=KNK5K K7= QĎK KmK]K K˙˙-TKK8K*KK7EKK 

.jKK*KK0UK5K /KK 	SK.K@KK/KK K K KČČGKK*KK KK-DK  ĽKeoK#K	-<KK KKK K K 
1gKK@K6SK-K,WK2K^dKK K""K 	EK%KKK'K K PKK	0KLKCKLRKK AKK	0K"BrK8>KK KKK	0K"BrKGK?KHNKKK K PKK	0K"BrKQKEKNTKKK K K K %%K		K		K K 
#|KK`KKK LK)KKK#K KBKK1K2IK+1K KrrKeKK	*NK"BrKEK=KMKGKLK3KVK=K K2= QĘK KBBK KmK KKK -TKK8K	*NK l}KK 

.jKK	*NK"B1ČK"B6ŇK /KK 	SK.K@K--KK KFFK 
 5mK OUKDK8UK	.RK  &E"-KADK7= -2KKK"BrKMKDJKKKK K K )EK KKKKK"KKK $­KK.IK#K	
aKGKK8KKK OKKKK 	?KK
";'KK/KGK>KJKBoK/:K=K4K;KGK>KJKHNKKK 

SKK
";K1VK-K /KK 	KK
";KK[[KK$&K6KKK K K K  K
&!yK	.K!KBOKK KKK
KK NK$KKK&K K OKK	.KKK @KK	.KKK K JKK	.KKK OKK	.KKK K K K K  pKKEKKK MKKKK 	?KK
";'KKK/K+K

"?KKK 

SKK
";KB,ŔKB1ĘK /KK 	KK
";KK KBoK KTK
KK\`KK K     Ź  ˙  