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
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;
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.
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];
note: these variants may be due to variation quite deep in the tail types.
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];
Check the variance of the variant record's preamble.
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;
note: if we are already discriminated, then the index applies to the first nested level of undiscriminated variant record.
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;
Copy the given list and add the new index element.
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]];
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.
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;
If the fully undifferentiated types don't agree, then we stop immediately. I am not sure how Cedar really handles these subtlties.
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;
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)
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;
I think that there is some amibiguity about leaving off the field name of the tail field in a field-path-name.
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]];
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.
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.)
so it is ok to do it
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;
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
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]];
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.
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;
This code seems to be the same for any union type?
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;
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.
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]];
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.
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.)
so it is ok to do it
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;
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.
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;
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.)
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]];
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!
IndirectVRGetCurrentType:
PROC[node: Node, cc:
CC]
RETURNS[Type] =
{RETURN[CCTypes.GetIndirectType[ObtainTargetValueType[node, cc]]]};
IndirectVR
UnaryOp:
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;
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.
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};
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.
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;
deferred load variant record procs
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;
indirect vr tail nodes
a vr tail essentially has two fields:
tag field
tail body
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]];
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.
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;
For the moment, we will permit this only then the target type is both fully discriminated and contains no variance
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.
We don't store the tag field because it is not supposed to change?
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};
support code
see notes above for support code associated with ObtainTargetValueType
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;
variant record nodes
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};
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?
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;
vr tail nodes
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;
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..