RecordsImpl.mesa
Copyright Ó 1990, 1992 by Xerox Corporation. All rights reserved.
Sturgis, November 20, 1988
Sturgis, December 11, 1989 2:10:39 pm PST
Last changed by Theimer on August 9, 1989 11:58:36 pm PDT
Hopcroft July 26, 1989 10:41:24 am PDT
Spreitze, January 9, 1992 7:52 pm PST
Laurie Horton, January 23, 1992 1:24 pm PST
Philip James, January 23, 1992 1:50 pm PST
Willie-s, May 14, 1992 12:44 pm PDT
DIRECTORY
CCTypes USING[BreakPrintType, CCError, CCErrorCase, CCTypeProcs, CheckConformance, CheckFamilyInclusion, CoerceToType, ConformanceCheck, Conforms, CreateCedarType, DoObject, GetIndirectType, GetNodeType, GetTargetTypeOfIndirect, GetTypeClass, GetProcDataFromGroundType, GetRTargetType, GetWrongType, ContainsVariance, IdFieldCase, LR, Operator, GetGroundTypeClass, PrintTypeBracketed, sia],
CedarCode USING[AMNodeConstructRecordNode, Code, CodeToBuildRecord, CodeToExtractField, CodeToLoadThroughIndirect, CodeToSelectField, CodeToStoreUnpopped, ConcatCode, CreateCedarNode, ForceNodeIn, GetDataFromNode, GetTypeOfNode, LoadThroughIndirectNode, Operator, OperationsBody, ShowNode, StoreThroughIndirectNode],
CedarOtherPureTypes USING [CreateIndirectToAnUnknownType, CreateUnknownType, CreateUnknownTypeNode],
CirioBackstop,
CirioSyntacticOperations USING[NameArgPair, CompileForRHS, ParseTree, NilParseTree],
CirioTypes USING[Code, CompilerContext, Mem, Node, Type, TypeClass, TypedCode],
IO,
Records USING[FieldCase, IndirectRecordNodeProcs, RecordNodeProcs, RecordTypeProcs],
Rope,
StructuredStreams;
RecordsImpl: CEDAR PROGRAM
IMPORTS CCTypes, CedarCode, CedarOtherPureTypes, CirioBackstop, CirioSyntacticOperations, IO, Rope, StructuredStreams
EXPORTS Records
= BEGIN OPEN CSO:CirioSyntacticOperations, SS:StructuredStreams;
CC: TYPE = CirioTypes.CompilerContext;
Code: TYPE = CedarCode.Code;
Type: TYPE = CirioTypes.Type;
TypedCode: TYPE = CirioTypes.TypedCode;
Mem: TYPE = CirioTypes.Mem;
Node: TYPE = CirioTypes.Node;
CCE: ERROR[case: CCTypes.CCErrorCase, msg: Rope.ROPE ¬ NIL] ¬ CCTypes.CCError;
Some comments
My original design had a feature that delayed the actual loading of a record onto the stack. There was a specific type, called a deferedLoadType, which behaved just like a record type, except that what was on the stack was an indirect to a record. That more or less worked, but trouble was about to develop as I began to think about extractors, treating an indirect record ( on left hand side of an assignment) as an extractor, and then considering what would happen with "(rec^←x).field". I decided to move the defered loading feature to interpreter run time, using different kinds of nodes. There have still been several variations on this theme. I believe that I have ended up with a scheme in which the compiled time types know nothing about this mechanism, and further, there are no places that have to look to see if a type class is $record to decide to defer a load.
We begin with types
RecordTypeInfo: TYPE = REF RecordTypeInfoBody;
RecordTypeInfoBody: TYPE = RECORD[
containsVariance: VarianceInfo,
isAFieldList: BOOLEAN,
procs: REF Records.RecordTypeProcs,
indirectType: Type,
data: REF ANY];
VarianceInfo: TYPE = {dontKnow, deciding, yes, no};
CreateRecordType: PUBLIC PROC[procs: REF Records.RecordTypeProcs, cc: CC, data: REF ANY] RETURNS[CirioTypes.Type] =
{RETURN[MainCreateRecordType[procs, FALSE, cc, data]]};
CreateFieldListType: PUBLIC PROC[procs: REF Records.RecordTypeProcs, cc: CC, data: REF ANY] RETURNS[CirioTypes.Type] =
{RETURN[MainCreateRecordType[procs, TRUE, cc, data]]};
MainCreateRecordType: PROC[procs: REF Records.RecordTypeProcs, isAFieldList: BOOLEAN, cc: CC, data: REF ANY] RETURNS[Type] =
BEGIN
info: RecordTypeInfo ¬ NEW[RecordTypeInfoBody¬[
dontKnow, -- tentative
isAFieldList,
procs,
NIL,
data]];
type: Type ¬ CCTypes.CreateCedarType[$record, RecordCCTypeProcs, IndirectRecordCCTypeProcs, cc, info];
RETURN[type];
END;
RecordCCTypeProcs: REF CCTypes.CCTypeProcs ¬ NEW[CCTypes.CCTypeProcs ¬[
checkConformance: RecordCCTypesCheckConformance,
checkFamilyInclusion: RecordCCTypesCheckFamilyInclusion,
isASingleton: RecordCCTypesIsASingleton,
hasIdField: RecordCCTypesHasIdField,
containsVariance: RecordCCTypesContainsVariance,
getNVariants: RecordCCTypesGetNVariants,
operand: RecordCCTypesOperand,
coerceToType: RecordCCTypesCoerceToType,
constructor: RecordCCTypesConstructor,
pairConstructor: RecordCCTypesPairConstructor,
extractIdField: RecordCCTypesExtractIdField,
getTypeRepresentation: RecordCCTypesGetTypeRepresentation,
printType: RecordCCTypesPrintType]];
note (December 8, 1989 10:02:37 am PST): just added concept of constant fields to Records.mesa. I did not change the following conformance and family inclusion routines. Not clear to me if they need to change, or if so, how to change them.
note: valType was the control parameter
RecordCCTypesCheckConformance: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.ConformanceCheck] =
BEGIN
valInfo: RecordTypeInfo ¬ NARROW[procData];
dontKnow: BOOLEAN ¬ FALSE; -- tentative
WITH CCTypes.GetProcDataFromGroundType[varType, cc] SELECT FROM
varInfo: RecordTypeInfo =>
BEGIN
valPaint: REF ANY ¬ valInfo.procs.getPaint[valInfo.data];
varPaint: REF ANY ¬ varInfo.procs.getPaint[varInfo.data];
nValFields: INT ¬ valInfo.procs.nFields[valInfo.data];
nVarFields: INT ¬ valInfo.procs.nFields[varInfo.data];
IF varPaint # NIL THEN
BEGIN
val must also be painted, and with the same paint
further, we are guaranteed by the type constructors that if they have the same paint, then they have the same structure.
IF valPaint = NIL THEN RETURN[no];
IF valInfo.procs.comparePaint[valInfo.data, varPaint] THEN RETURN[yes] ELSE RETURN[no];
END;
IF nValFields # nVarFields THEN RETURN[no];
FOR I: INT IN [0..nValFields) DO
valFieldName: Rope.ROPE ¬ valInfo.procs.fieldIndexToName[I, valInfo.data];
varFieldName: Rope.ROPE ¬ varInfo.procs.fieldIndexToName[I, varInfo.data];
valFieldType: Type ¬ valInfo.procs.fieldIndexToType[I, cc, valInfo.data];
varFieldType: Type ¬ varInfo.procs.fieldIndexToType[I, cc, varInfo.data];
fieldConformity: CCTypes.ConformanceCheck;
IF NOT Rope.Equal[valFieldName, varFieldName] THEN RETURN[no];
fieldConformity ¬ CCTypes.CheckConformance[valFieldType, varFieldType, cc];
IF fieldConformity = no THEN RETURN[no];
IF fieldConformity = dontKnow THEN dontKnow ¬ TRUE;
ENDLOOP;
IF dontKnow THEN RETURN[dontKnow] ELSE RETURN[yes];
END;
ENDCASE => RETURN[no];
END;
note: valType was the control parameter
RecordCCTypesCheckFamilyInclusion: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
BEGIN
valInfo: RecordTypeInfo ¬ NARROW[procData];
dontKnow: BOOLEAN ¬ FALSE; -- tentative
WITH CCTypes.GetProcDataFromGroundType[varType, cc] SELECT FROM
varInfo: RecordTypeInfo =>
BEGIN
valPaint: REF ANY ¬ valInfo.procs.getPaint[valInfo.data];
varPaint: REF ANY ¬ varInfo.procs.getPaint[varInfo.data];
nValFields: INT ¬ valInfo.procs.nFields[valInfo.data];
nVarFields: INT ¬ valInfo.procs.nFields[varInfo.data];
IF varPaint # NIL THEN
BEGIN
val must also be painted, and with the same paint
further, we are guaranteed by the type constructors that if they have the same paint, then they have the same structure.
IF valPaint = NIL THEN RETURN[FALSE];
IF valInfo.procs.comparePaint[valInfo.data, varPaint] THEN RETURN[TRUE] ELSE RETURN[FALSE];
END;
IF nValFields # nVarFields THEN RETURN[FALSE];
FOR I: INT IN [0..nValFields) DO
valFieldName: Rope.ROPE ¬ valInfo.procs.fieldIndexToName[I, valInfo.data];
varFieldName: Rope.ROPE ¬ varInfo.procs.fieldIndexToName[I, varInfo.data];
valFieldType: Type ¬ valInfo.procs.fieldIndexToType[I, cc, valInfo.data];
varFieldType: Type ¬ varInfo.procs.fieldIndexToType[I, cc, varInfo.data];
IF NOT Rope.Equal[valFieldName, varFieldName] THEN RETURN[FALSE];
IF NOT CCTypes.CheckFamilyInclusion[valFieldType, varFieldType, cc] THEN RETURN[FALSE];
ENDLOOP;
RETURN[TRUE];
END;
ENDCASE => RETURN[FALSE];
END;
RecordCCTypesIsASingleton: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[NOT RecordCCTypesContainsVariance[type, cc, procData]]};
RecordCCTypesHasIdField: PROC[id: Rope.ROPE, fieldContext: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.IdFieldCase] =
BEGIN
tcTypeInfo: RecordTypeInfo ¬ NARROW[procData];
SELECT tcTypeInfo.procs.nameToFieldIndex[id, tcTypeInfo.data] FROM
-1 => RETURN[no];
ENDCASE => RETURN[yes];
END;
Note that we carefully wait until asked to determine whether the record type contains variance. This prevents us from entering the following infinite loop. Suppose there is a type cycle from one of our fields back to our type (this will certainly involve at least one pointer). Suppose all pointers in that cycle are refs. Suppose that we try to answer this question during type creation. Then we will have to create each of our field types. If one of those is a ref, it must create its target type in order to determine whether it should be a union type. This will carry us all the way around the loop.
RecordCCTypesContainsVariance: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
BEGIN
tcTypeInfo: RecordTypeInfo ¬ NARROW[procData];
BEGIN
ENABLE UNWIND =>
BEGIN
IF tcTypeInfo.containsVariance = deciding THEN tcTypeInfo.containsVariance ¬ dontKnow;
END;
IF tcTypeInfo.containsVariance = deciding THEN CCE[cirioError]; -- shouldnt happen
IF tcTypeInfo.containsVariance = dontKnow THEN
BEGIN
tcTypeInfo.containsVariance ¬ deciding;
FOR I: INT IN [0..tcTypeInfo.procs.nFields[tcTypeInfo.data]) DO
fieldType: Type ¬ tcTypeInfo.procs.fieldIndexToType[I, cc, tcTypeInfo.data];
IF CCTypes.ContainsVariance[fieldType, cc] THEN
{tcTypeInfo.containsVariance ¬ yes; EXIT};
ENDLOOP;
IF tcTypeInfo.containsVariance = deciding THEN tcTypeInfo.containsVariance ¬ no;
END;
RETURN[tcTypeInfo.containsVariance = yes];
END;
END;
perhaps this should be a default? or is it only called when a type containsVariance?
RecordCCTypesGetNVariants: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[INT] =
{RETURN[0]};
Note: when we add procedures, we will have to check for single field records and try stripping the brackets. This will lead to having to try two choices for dot: If we have a single field record containing the proposed identifier then we are ok, otherwise we have to strip the brackets. I am not sure where to place that code!!! there is not enough information here to do it!!! (i.e., the identifier is not available.) Maybe we have to treat dot as a binary operation?
RecordCCTypesOperand: PROC[op: CedarCode.Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
SELECT op FROM
$dot, $extractId => RETURN[tc];
$plus, $minus, $div, $mult, $mod, $le, $lt, $eq, $ne, $gt, $ge =>
BEGIN
info: RecordTypeInfo ¬ NARROW[procData];
nFields: INT ¬ info.procs.nFields[info.data];
IF nFields # 1 THEN CCE[operation, "type mismatch"]
ELSE
BEGIN
fieldName: Rope.ROPE ¬ info.procs.fieldIndexToName[0, info.data];
fieldType: Type ¬ info.procs.fieldIndexToType[0, cc, info.data];
code: Code ¬ CedarCode.CodeToExtractField[fieldName, tc.type];
code1: Code ¬ CedarCode.ConcatCode[tc.code, code];
RETURN [[code1, fieldType]];
END;
END;
ENDCASE => CCE[operation, "invalid operation"]; -- client error, invalid operation
END;
tc.type is the control parameter
RecordCCTypesCoerceToType: PROC[targetType: Type, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
tcTypeInfo: RecordTypeInfo ¬ NARROW[procData];
see if striping off one layer of brackets will do it
nFields: INT ¬ tcTypeInfo.procs.nFields[tcTypeInfo.data];
IF nFields = 1 THEN
BEGIN
fieldType: Type ¬ tcTypeInfo.procs.fieldIndexToType[0, cc, tcTypeInfo.data];
IF CCTypes.Conforms[fieldType, targetType, cc] THEN
BEGIN
fieldName: Rope.ROPE ¬ tcTypeInfo.procs.fieldIndexToName[0, tcTypeInfo.data];
code: Code ¬ CedarCode.ConcatCode[
tc.code,
CedarCode.CodeToExtractField[fieldName, tc.type]];
RETURN[[code, fieldType]];
END;
END;
CCE[cirioError]; -- client type error?
END;
RCFragments: TYPE = RECORD[SEQUENCE nFragments: CARDINAL OF TypedCode];
it would be nice to move this code, and the code for PairConstructor, into CirioSyntacticOperationsImpl. But not for now.
RecordCCTypesConstructor: PROC[list: LIST OF CSO.ParseTree, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
typeInfo: RecordTypeInfo ¬ NARROW[procData];
nFields: INT ¬ typeInfo.procs.nFields[typeInfo.data];
fieldIndex: INT ¬ 0;
tc1Fragments: REF RCFragments ¬ NEW[RCFragments[nFields]];
tc2Fragments: REF RCFragments ¬ NEW[RCFragments[nFields]];
code: CedarCode.Code ¬ NIL;
wrongSeen: BOOLEAN ¬ FALSE;
nodeSeen: BOOLEAN ¬ FALSE;
FOR lpt: LIST OF CSO.ParseTree ¬ list, lpt.rest WHILE lpt # NIL DO
IF fieldIndex >= nFields THEN CCE[cirioError] -- too many fields
ELSE
BEGIN
fieldType: Type ¬ typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
IF CSO.NilParseTree[lpt.first] THEN
BEGIN
fieldDefault: CSO.ParseTree;
defaultNameScope, oldNameScope: Node;
fieldType: Type;
fieldTC1: TypedCode;
fieldCodeClass: CirioTypes.TypeClass;
fieldType ¬ typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
[fieldDefault, defaultNameScope] ¬ typeInfo.procs.fieldIndexToDefault[fieldIndex, cc, typeInfo.data];
oldNameScope ¬ cc.nameScope;
cc.nameScope ¬ defaultNameScope;
fieldTC1 ¬ CSO.CompileForRHS[fieldDefault, fieldType, cc];
fieldCodeClass ¬ CCTypes.GetGroundTypeClass[fieldTC1.type, cc];
cc.nameScope ¬ oldNameScope;
tc1Fragments[fieldIndex] ¬ fieldTC1;
IF fieldCodeClass = $wrong THEN wrongSeen ¬ TRUE;
IF fieldCodeClass = $amnode THEN nodeSeen ¬ TRUE;
END
ELSE
BEGIN
fieldTC1: TypedCode ¬ CSO.CompileForRHS[lpt.first, fieldType, cc];
fieldCodeClass: CirioTypes.TypeClass ¬ CCTypes.GetGroundTypeClass[fieldTC1.type, cc];
tc1Fragments[fieldIndex] ¬ fieldTC1;
IF fieldCodeClass = $wrong THEN wrongSeen ¬ TRUE;
IF fieldCodeClass = $amnode THEN nodeSeen ¬ TRUE;
END;
fieldIndex ¬ fieldIndex + 1;
END;
ENDLOOP;
IF fieldIndex < nFields THEN
WHILE fieldIndex < nFields DO
fieldDefault: CSO.ParseTree;
defaultNameScope, oldNameScope: Node;
fieldType: Type;
fieldTC1: TypedCode;
fieldCodeClass: CirioTypes.TypeClass;
fieldType ¬ typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
IF typeInfo.procs.fieldIndexToDefault = NIL THEN CCE[case: unimplemented, msg: "Please redo operation supplying all of the parameters."];
[fieldDefault, defaultNameScope] ¬ typeInfo.procs.fieldIndexToDefault[fieldIndex, cc, typeInfo.data];
oldNameScope ¬ cc.nameScope;
cc.nameScope ¬ defaultNameScope;
fieldTC1 ¬ CSO.CompileForRHS[fieldDefault, fieldType, cc];
fieldCodeClass ¬ CCTypes.GetGroundTypeClass[fieldTC1.type, cc];
cc.nameScope ¬ oldNameScope;
tc1Fragments[fieldIndex] ¬ fieldTC1;
IF fieldCodeClass = $wrong THEN wrongSeen ¬ TRUE;
IF fieldCodeClass = $amnode THEN nodeSeen ¬ TRUE;
fieldIndex ¬ fieldIndex + 1;
ENDLOOP;
FOR fieldIndex IN [0..nFields) DO
fieldType: Type ¬ SELECT TRUE FROM
wrongSeen => CCTypes.GetWrongType[cc],
nodeSeen => CCTypes.GetNodeType[cc],
ENDCASE => typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
tc2Fragments[fieldIndex] ¬ CCTypes.CoerceToType[fieldType, tc1Fragments[fieldIndex], cc];
ENDLOOP;
FOR fieldIndex IN [0..nFields) DO
code ¬ code ¬ CedarCode.ConcatCode[
code,
tc2Fragments[fieldIndex].code];
ENDLOOP;
code ¬ CedarCode.ConcatCode[
code,
CedarCode.CodeToBuildRecord[nFields, targetType]];
RETURN[[code, targetType]];
END;
RecordCCTypesPairConstructor: PROC[list: LIST OF CirioSyntacticOperations.NameArgPair, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
typeInfo: RecordTypeInfo ¬ NARROW[procData];
nFields: INT ¬ typeInfo.procs.nFields[typeInfo.data];
tc1Fragments: REF RCFragments ¬ NEW[RCFragments[nFields]];
tc2Fragments: REF RCFragments ¬ NEW[RCFragments[nFields]];
code: CedarCode.Code ¬ NIL;
wrongSeen: BOOLEAN ¬ FALSE;
nodeSeen: BOOLEAN ¬ FALSE;
FOR I: INT IN [0..nFields) DO tc1Fragments[I] ¬ [NIL, NIL] ENDLOOP;
FOR lnap: LIST OF CirioSyntacticOperations.NameArgPair ¬ list, lnap.rest WHILE lnap # NIL DO
fieldIndex: INT ¬ typeInfo.procs.nameToFieldIndex[lnap.first.id, typeInfo.data];
IF fieldIndex = -1 THEN CCE[operation, Rope.Cat["field ", lnap.first.id, " does not exist"]] -- no such field name
ELSE
BEGIN
fieldType: Type ¬ typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
fieldTC1: TypedCode ¬ CSO.CompileForRHS[lnap.first.arg, fieldType, cc]; -- hmm, someone should handle defaulted fields (no tree). Should this be CSO.CompileForRHS?
fieldCodeClass: CirioTypes.TypeClass ¬ CCTypes.GetGroundTypeClass[fieldTC1.type, cc];
IF tc1Fragments[fieldIndex] # [NIL, NIL] THEN CCE[operation, Rope.Concat[lnap.first.id, " is a repeated field name"]]; -- repeated field name
tc1Fragments[fieldIndex] ¬ fieldTC1;
IF fieldCodeClass = $wrong THEN wrongSeen ¬ TRUE;
IF fieldCodeClass = $amnode THEN nodeSeen ¬ TRUE;
END;
ENDLOOP;
FOR fieldIndex: INT IN [0..nFields) DO
IF tc1Fragments[fieldIndex] = [NIL, NIL] THEN
BEGIN
fieldDefault: CSO.ParseTree;
defaultNameScope, oldNameScope: Node;
fieldType: Type;
fieldTC1: TypedCode;
fieldCodeClass: CirioTypes.TypeClass;
fieldType ¬ typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
IF typeInfo.procs.fieldIndexToDefault = NIL THEN CCE[case: unimplemented, msg: "Please redo operation supplying all of the parameters."];
[fieldDefault, defaultNameScope] ¬ typeInfo.procs.fieldIndexToDefault[fieldIndex, cc, typeInfo.data];
oldNameScope ¬ cc.nameScope;
cc.nameScope ¬ defaultNameScope;
fieldTC1 ¬ CSO.CompileForRHS[fieldDefault, fieldType, cc];
fieldCodeClass ¬ CCTypes.GetGroundTypeClass[fieldTC1.type, cc];
cc.nameScope ¬ oldNameScope;
tc1Fragments[fieldIndex] ¬ fieldTC1;
IF fieldCodeClass = $wrong THEN wrongSeen ¬ TRUE;
IF fieldCodeClass = $amnode THEN nodeSeen ¬ TRUE;
END;
ENDLOOP;
FOR fieldIndex: INT IN [0..nFields) DO
fieldType: Type ¬ SELECT TRUE FROM
wrongSeen => CCTypes.GetWrongType[cc],
nodeSeen => CCTypes.GetNodeType[cc],
ENDCASE => typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
tc2Fragments[fieldIndex] ¬ CCTypes.CoerceToType[fieldType, tc1Fragments[fieldIndex], cc];
ENDLOOP;
FOR fieldIndex: INT IN [0..nFields) DO
code ¬ code ¬ CedarCode.ConcatCode[
code,
tc2Fragments[fieldIndex].code];
ENDLOOP;
code ¬ CedarCode.ConcatCode[
code,
CedarCode.CodeToBuildRecord[nFields, targetType]];
RETURN[[code, targetType]];
END;
RecordCCTypesExtractIdField: PROC[id: Rope.ROPE, fieldContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
info: RecordTypeInfo ¬ NARROW[procData];
fieldIndex: INT ¬ info.procs.nameToFieldIndex[id, info.data];
IF fieldIndex > -1 THEN -- the field exists
BEGIN
fieldType: Type ¬ info.procs.fieldIndexToType[fieldIndex, cc, info.data];
RETURN[[CedarCode.CodeToExtractField[id, fieldContext], fieldType]];
END
ELSE
CCE[operation, Rope.Cat["field ", id, " does not exist"]]; -- no such field
END;
RecordCCTypesGetTypeRepresentation: PROC [type: Type, cc: CC, procData: REF ANY] RETURNS[REF ANY] = {
info: RecordTypeInfo ¬ NARROW[procData];
RETURN[info.data];
};
RecordCCTypesPrintType: PROC [to: IO.STREAM, type: Type, printDepth, printWidth: INT, cc: CC, procData: REF ANY] = {
reports: IO.STREAM ~ IO.ROS[];
info: RecordTypeInfo ¬ NARROW[procData];
nFields: INT ¬ info.procs.nFields[info.data];
iWidth: INT ¬ IF nFields>1 THEN (printWidth*2)/3 ELSE printWidth;
reportage: Rope.ROPE;
<<IF nFields = 0 THEN RETURN;>>
IF NOT info.isAFieldList THEN to.PutChar['[];
IF printDepth < 1
THEN to.PutRope["..."]
ELSE FOR i: INT IN [0..nFields) DO
FormatField: PROC RETURNS [Rope.ROPE] ~ {
fieldName: Rope.ROPE ¬ info.procs.fieldIndexToName[i, info.data];
fieldType: Type ¬ info.procs.fieldIndexToType[i, cc, info.data];
iDepth: INT ¬ IF CCTypes.GetTypeClass[fieldType] = $definition THEN 0 ELSE (printDepth-1);
If the fieldType is a definition type then we only print the definition type's name and NOT its definition. We achieve this by reducing the printing depth to force PrintType to only print the definition name.
PrintNamedFieldType: PROC ~ {
to.PutRope[fieldName];
to.PutChar[':];
CCTypes.BreakPrintType[to, fieldType, iDepth, iWidth, cc, " "];
RETURN};
IF i>0 THEN {
to.PutChar[',];
SS.Bp[to, lookLeft, CCTypes.sia, " "]}
ELSE SS.Bp[to, lookLeft, CCTypes.sia];
IF NOT Rope.IsEmpty[fieldName]
THEN CCTypes.DoObject[to, PrintNamedFieldType]
ELSE CCTypes.PrintTypeBracketed[to, fieldType, iDepth, iWidth, cc];
RETURN [NIL]};
fmtErr: Rope.ROPE ¬ CirioBackstop.Protect[FormatField, reports];
IF fmtErr.Length[] > 0 THEN to.PutF1[" --error (%g)--", [rope[fmtErr]] ];
ENDLOOP;
IF NOT info.isAFieldList THEN to.PutChar[']];
reportage ¬ IO.RopeFromROS[reports];
IF reportage.Length[] > 0 THEN to.PutF1[" (%g)", [rope[reportage]] ];
RETURN};
indirect record types
IndirectRecordCCTypeProcs: REF CCTypes.CCTypeProcs ¬ NEW[CCTypes.CCTypeProcs ¬[
createIndirectNode: RecordCreateIndirect,
getBitSize: RecordBitSize,
operand: IndirectRecordCCTypesOperand,
store: IndirectRecordCCTypesStore,
load: IndirectRecordCCTypesLoad,
selectIdField: IndirectRecordCCTypesSelectIdField,
printType: RecordCCTypesPrintType]];
RecordCreateIndirect: PROC [cc: CC, procData: REF ANY, indirectType, targetType: Type, mem: Mem] RETURNS [Node] ~ {
info: RecordTypeInfo ¬ NARROW[procData];
RETURN info.procs.createIndirectNode[cc, info.data, indirectType, targetType, mem]};
RecordBitSize: PROC[indirectType, targetType: Type, cc: CC, procData: REF ANY] RETURNS[CARD] ~ {
info: RecordTypeInfo ¬ NARROW[procData];
RETURN info.procs.getBitSize[indirectType, cc, info.data]};
IndirectRecordCCTypesOperand: PROC[op: CCTypes.Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
SELECT op FROM
$selectId, $address => RETURN[tc];
ENDCASE => CCE[operation, "illegal operation"]; -- client error, illegal operation
END;
IndirectRecordCCTypesStore: PROC[value: TypedCode, indirect: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
info: RecordTypeInfo ¬ NARROW[procData];
nFields: INT ¬ info.procs.nFields[info.data];
code: Code ¬ CedarCode.ConcatCode[
indirect.code,
CedarCode.ConcatCode[
value.code,
CedarCode.CodeToStoreUnpopped[indirect.type, value.type]]];
FOR I: INT IN [0..nFields) DO
indirectFieldCase: Records.FieldCase ¬ info.procs.fieldIndexToFieldCase[I, cc, info.data];
IF indirectFieldCase # nodeTimeReadWrite THEN
BEGIN
id: Rope.ROPE ¬ info.procs.fieldIndexToName[I, info.data];
CCE[operation, Rope.Cat["field ", id, " is not modifiable"]];
what about record initialization?
END;
ENDLOOP;
RETURN[[code, value.type]];
END;
IndirectRecordCCTypesLoad: 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;
IndirectRecordCCTypesSelectIdField: PROC[id: Rope.ROPE, fieldIndirectContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
info: RecordTypeInfo ¬ NARROW[procData];
fieldIndex: INT ¬ info.procs.nameToFieldIndex[id, info.data];
IF fieldIndex > -1 THEN -- the field exists
BEGIN
fieldType: Type ¬ info.procs.fieldIndexToType[fieldIndex, cc, info.data];
fieldCase: Records.FieldCase ¬ info.procs.fieldIndexToFieldCase[fieldIndex, cc, info.data];
indirectFieldType: Type ¬ CCTypes.GetIndirectType[fieldType];
SELECT fieldCase FROM
nodeTimeReadWrite, nodeTimeReadOnly, nodeTimeConstant => NULL;
typeTimeConstant => CCE[operation, Rope.Cat["field ", id, " has no runtime address"]]; -- what about initialization?
note: if we are in this routine, then we must have been on the left hand side of an assignment (actually, compiling for left side; this also happens when compiling @expr on rhs, for example). If we had been on the right hand side, then we would be dealing in records, not indirects to records. (These records would be represented by defered loads.)
ENDCASE => ERROR;
RETURN[[CedarCode.CodeToSelectField[id, fieldIndirectContext], indirectFieldType]];
END
ELSE
CCE[operation, Rope.Cat["field ", id, " does not exist"]]; -- no such field
END;
Indirect record nodes
IndirectRecordData: TYPE = RECORD[
targetType: Type,
procs: REF Records.IndirectRecordNodeProcs,
data: REF ANY];
IndirectRecordOps: REF CedarCode.OperationsBody ¬ NEW[CedarCode.OperationsBody¬[
getCurrentType: IndirectRecordGetCurrentType,
unaryOp: IndirectRecordUnaryOp,
store: IndirectRecordStore,
load: IndirectRecordLoad,
selectField: IndirectRecordSelectField,
show: IndirectRecordShow]];
CreateIndirectRecordNode: PUBLIC PROC[targetRecordType: CirioTypes.Type, procs: REF Records.IndirectRecordNodeProcs, data: REF ANY, cc: CC] RETURNS[Node] =
BEGIN
node: Node ¬ CedarCode.CreateCedarNode[IndirectRecordOps, CCTypes.GetIndirectType[targetRecordType], NEW[IndirectRecordData ¬ [targetRecordType, procs, data]]];
RETURN[node];
END;
This is the default version. It assumes that the target type is not a union type.
IndirectRecordGetCurrentType: PROC[node: Node, cc: CC] RETURNS[Type] =
{RETURN[CedarCode.GetTypeOfNode[node]]};
IndirectRecordUnaryOp: PROC [op: CedarCode.Operator, type: CirioTypes.Type, node: CirioTypes.Node, cc: CC] RETURNS [CirioTypes.Node] =
BEGIN
indirectNodeData: REF IndirectRecordData ¬ NARROW[CedarCode.GetDataFromNode[node]];
RETURN[indirectNodeData.procs.getPointer[indirectNodeData.data, cc]];
END;
IndirectRecordStore: PROC[valType: Type, valNode: Node, indirectType: Type, indirectNode: Node, cc: CC] =
BEGIN
indirectTypeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[indirectType, cc]];
valTypeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[valType, cc]];
valNodeData: REF RecordData ¬ NARROW[CedarCode.GetDataFromNode[valNode]];
indirectNodeData: REF IndirectRecordData ¬ NARROW[CedarCode.GetDataFromNode[indirectNode]];
nFields: INT ¬ valTypeInfo.procs.nFields[valTypeInfo.data];
FOR I: INT IN [0..nFields) DO
indirectFieldType: Type ¬ CCTypes.GetIndirectType[indirectTypeInfo.procs.fieldIndexToType[I, cc, indirectTypeInfo.data]];
indirectFieldCase: Records.FieldCase ¬ indirectTypeInfo.procs.fieldIndexToFieldCase[I, cc, indirectTypeInfo.data];
IF indirectFieldCase = nodeTimeReadWrite THEN
BEGIN
indirectField: Node ¬ indirectNodeData.procs.selectField[I, indirectFieldType, indirectNodeData.data, cc];
valFieldType: Type ¬ valTypeInfo.procs.fieldIndexToType[I, cc, valTypeInfo.data];
valField: Node ¬ valNodeData.procs.extractField[I, valFieldType, valNodeData.data, cc];
CedarCode.StoreThroughIndirectNode[valFieldType, valField, indirectFieldType, indirectField, cc];
END
ENDLOOP;
END;
IndirectRecordLoad: PROC[indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] =
BEGIN -- in effect, we defer the load
targetType: Type ¬ CCTypes.GetRTargetType[indirectType, cc];
data: REF IndirectRecordData ¬ NARROW[CedarCode.GetDataFromNode[indirectNode]];
RETURN[CreateRecordNode[targetType, DeferedLoadProcs, data, cc, FALSE]]
END;
IndirectRecordSelectField: PROC[id: Rope.ROPE, indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] =
BEGIN
indirectTypeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[indirectType, cc]];
indirectNodeData: REF IndirectRecordData ¬ NARROW[CedarCode.GetDataFromNode[indirectNode]];
targetType: Type ¬ CCTypes.GetRTargetType[indirectType, cc];
targetTypeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[targetType, cc]];
fieldIndex: INT ¬ targetTypeInfo.procs.nameToFieldIndex[id, targetTypeInfo.data];
IF fieldIndex<0 THEN RETURN CedarOtherPureTypes.CreateIndirectToAnUnknownType[
CedarOtherPureTypes.CreateUnknownType[cc, Rope.Concat["type for non-existant field ", id]],
Rope.Concat["indirect to non-existant field ", id],
cc];
{fieldCase: Records.FieldCase ¬ indirectTypeInfo.procs.fieldIndexToFieldCase[fieldIndex, cc, indirectTypeInfo.data];
fieldIndirectType: Type ¬ CCTypes.GetIndirectType[indirectTypeInfo.procs.fieldIndexToType[fieldIndex, cc, indirectTypeInfo.data]];
SELECT fieldCase FROM
nodeTimeReadWrite, nodeTimeReadOnly, nodeTimeConstant => RETURN[indirectNodeData.procs.selectField[fieldIndex, fieldIndirectType, indirectNodeData.data, cc]];
typeTimeConstant => RETURN CedarOtherPureTypes.CreateIndirectToAnUnknownType[
CCTypes.GetTargetTypeOfIndirect[fieldIndirectType],
Rope.Cat["field ", id, " has no runtime address"],
cc];
ENDCASE => ERROR;
}END;
We don't require that the client of CreateIndirectRecordNode be prepared to do a show, since that client is frequently some target world entity.
IndirectRecordShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = {
ircdType: Type ¬ CedarCode.GetTypeOfNode[node];
rcd: Node ¬ CedarCode.LoadThroughIndirectNode[ircdType, node, cc];
to.PutChar['^];
CedarCode.ShowNode[to, rcd, depth, width, cc];
RETURN};
DeferedLoadProcs: REF Records.RecordNodeProcs ¬ NEW[Records.RecordNodeProcs ¬[
extractField: DeferedLoadExtractField]];
DeferedLoadExtractField: PROC[index: INT, fieldType: CirioTypes.Type, data: REF ANY, cc: CC] RETURNS[Node] =
BEGIN
irData: REF IndirectRecordData ¬ NARROW[data];
irTypeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[irData.targetType, cc]];
indirectFieldType: Type ¬ CCTypes.GetIndirectType[fieldType];
indirectFieldCase: Records.FieldCase ¬ irTypeInfo.procs.fieldIndexToFieldCase[index, cc, irTypeInfo.data];
SELECT indirectFieldCase FROM
actual bits exist in memory for this first pair of cases
nodeTimeReadWrite, nodeTimeReadOnly =>
BEGIN
field: Node ¬ irData.procs.selectField[index, indirectFieldType, irData.data, cc];
RETURN[CedarCode.LoadThroughIndirectNode[indirectFieldType, field, cc]];
END;
no bits exist in memory for this next case, although the value is dependent on the location of the record. (These are all procedure constants.)
nodeTimeConstant =>
RETURN[irData.procs.fieldIndexToNodeTimeConstantValue[index, fieldType, irData.data, cc]];
no bits exist for this last case, but the value can be computed at type time.
typeTimeConstant =>
RETURN[irTypeInfo.procs.fieldIndexToCompileTimeConstantValue[index, cc, irTypeInfo]];
ENDCASE => CCE[cirioError];
END;
Record Nodes
RecordData: TYPE = RECORD[
type: Type,
alreadyLoaded: BOOLEAN,
procs: REF Records.RecordNodeProcs,
data: REF ANY];
RecordOps: REF CedarCode.OperationsBody ¬ NEW[CedarCode.OperationsBody¬[
forceIn: RecordForceIn,
extractField: RecordExtractField,
show: RecordShow]];
CreateRecordNode: PROC[recordType: CirioTypes.Type, procs: REF Records.RecordNodeProcs, data: REF ANY, cc: CC, alreadyLoaded: BOOLEAN] RETURNS[CirioTypes.Node] =
BEGIN
node: Node ¬ CedarCode.CreateCedarNode[RecordOps, recordType, NEW[RecordData ¬ [recordType, alreadyLoaded, procs, data]]];
RETURN[node];
END;
RecordForceIn: PROC[type: Type, node: Node, cc: CC] RETURNS[Node] =
BEGIN
data: REF RecordData ¬ NARROW[CedarCode.GetDataFromNode[node]];
IF data.alreadyLoaded THEN RETURN[node]
ELSE
BEGIN
typeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[type, cc]];
nFields: INT ¬ typeInfo.procs.nFields[typeInfo.data];
fields: LIST OF CirioTypes.Node ¬ NIL;
FOR I: INT DECREASING IN [0..nFields) DO
fieldType: Type ¬ typeInfo.procs.fieldIndexToType[I, cc, typeInfo.data];
nominalField: CirioTypes.Node ¬ data.procs.extractField[I, fieldType, data.data, cc];
field: CirioTypes.Node ¬ CedarCode.ForceNodeIn[fieldType, nominalField, cc];
fields ¬ CONS[field, fields];
ENDLOOP;
RETURN[ConstructRecordNode[type, fields, cc]];
END;
END;
RecordExtractField: PROC[id: Rope.ROPE, type: Type, node: Node, cc: CC] RETURNS[Node] =
BEGIN
data: REF RecordData ¬ NARROW[CedarCode.GetDataFromNode[node]];
typeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[type, cc]];
fieldIndex: INT ¬ typeInfo.procs.nameToFieldIndex[id, typeInfo.data];
IF fieldIndex<0 THEN {
fieldType: Type ¬ CedarOtherPureTypes.CreateUnknownType[cc, Rope.Concat["unk. type for non-existant field ", id]];
RETURN CedarOtherPureTypes.CreateUnknownTypeNode[fieldType, Rope.Concat["no field named ", id], cc];
}
ELSE {
fieldType: Type ¬ typeInfo.procs.fieldIndexToType[fieldIndex, cc, typeInfo.data];
RETURN[data.procs.extractField[fieldIndex, fieldType, data.data, cc]];
};
END;
RecordShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = {
data: REF RecordData ¬ NARROW[CedarCode.GetDataFromNode[node]];
typeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[data.type, cc]];
rope: Rope.ROPE ¬ "";
nFields: INT ¬ typeInfo.procs.nFields[typeInfo.data];
cWidth: INT ¬ width;
iWidth: INT ¬ IF nFields>1 THEN (width*2)/3 ELSE width;
IF NOT typeInfo.isAFieldList THEN to.PutChar['[];
IF depth<1 AND nFields>0 THEN to.PutRope["..."]
ELSE FOR I: INT IN [0..nFields) DO
fieldType: Type ¬ typeInfo.procs.fieldIndexToType[I, cc, typeInfo.data];
field: Node ¬ data.procs.extractField[I, fieldType, data.data, cc];
name: Rope.ROPE ¬ typeInfo.procs.fieldIndexToName[I, typeInfo.data];
PrintNamedField: PROC ~ {
to.PutRope[name];
to.PutChar[':];
SS.Bp[to, lookLeft, CCTypes.sia, " "];
CCTypes.DoObject[to, PrintFieldVal];
RETURN};
PrintFieldVal: PROC ~ {CedarCode.ShowNode[to, field, depth-1, iWidth, cc]};
IF I>0
THEN {to.PutChar[',]; SS.Bp[to, lookLeft, CCTypes.sia, " "]}
ELSE SS.Bp[to, lookLeft, CCTypes.sia];
IF cWidth < 0 THEN {to.PutRope["..."]; EXIT}
ELSE IF name.Length > 0 THEN CCTypes.DoObject[to, PrintNamedField]
ELSE CCTypes.DoObject[to, PrintFieldVal];
cWidth ¬ cWidth-1;
ENDLOOP;
IF NOT typeInfo.isAFieldList THEN to.PutChar[']];
RETURN};
Constructed Records
ConstructRecordNode: PUBLIC PROC[recordType: CirioTypes.Type, fields: LIST OF CirioTypes.Node, cc: CC] RETURNS[CirioTypes.Node] =
BEGIN
there is a possibility that we did not have full information about the fields at compile time.
if so, the first field will be of class $amnode. [we never permit amnodes to appear in records?]
this is a lousy design. There should be a more explicity decision at compile time that this is what we are going to do, and compile time should have generated a different operation. But this will do for now.
this design has been copied to ArraysImpl, in which one will find similar remarks.
Both should be fixed at the same time
IF fields = NIL OR CCTypes.GetGroundTypeClass[CedarCode.GetTypeOfNode[fields.first], cc] # $amnode THEN
BEGIN
typeInfo: RecordTypeInfo ¬ NARROW[CCTypes.GetProcDataFromGroundType[recordType, cc]];
nFields: INT ¬ typeInfo.procs.nFields[typeInfo.data];
cr: ConstructedRecord ¬ NEW[ConstructedRecordBody[nFields]];
fieldIndex: INT ¬ 0;
FOR ln: LIST OF CirioTypes.Node ¬ fields, ln.rest WHILE ln # NIL DO
cr[fieldIndex] ¬ ln.first;
fieldIndex ¬ fieldIndex + 1;
ENDLOOP;
IF fieldIndex # nFields THEN CCE[operation, "not enough fields supplied"];
RETURN[CreateRecordNode[recordType, ConstructedRecordProcs, cr, cc, TRUE]];
END
ELSE
BEGIN -- first field is an amnode. We assume that they all are. We uncrate them and recompile. BUT, somehow this code should be in the Node implmentation. We must arrange for this to be an object proc of something. The only something available is either the first field (not likely for zero field records) or the target type. That would suggest that all the actions should be object procs of the types?
RETURN[CedarCode.AMNodeConstructRecordNode[recordType, fields, cc]];
END;
END;
ConstructedRecord: TYPE = REF ConstructedRecordBody;
ConstructedRecordBody: TYPE = RECORD[
SEQUENCE nFields: CARDINAL OF Node];
ConstructedRecordProcs: REF Records.RecordNodeProcs ¬ NEW[Records.RecordNodeProcs¬[
extractField: CRExtractField]];
CRExtractField: PROC[index: INT, fieldType: CirioTypes.Type, data: REF ANY, cc: CC] RETURNS[CirioTypes.Node] =
BEGIN
cr: ConstructedRecord ¬ NARROW[data];
RETURN[cr[index]];
END;
END..