[_CDMiwok_01_]<cedarcommon2.0>Cirio>RecordsImpl.mesa!6

RecordsImpl.mesa

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

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;

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;

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;

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.Cat[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.PutF[" --error (%g)--", [rope[fmtErr]] ];

ENDLOOP;

IF NOT info.isAFieldList THEN to.PutChar[']];

reportage ← IO.RopeFromROS[reports];

IF reportage.Length[] > 0 THEN to.PutF[" (%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.Cat["type for non-existant field ", id]],

Rope.Cat["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;

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.Cat["unk. type for non-existant field ", id]];

RETURN CedarOtherPureTypes.CreateUnknownTypeNode[fieldType, Rope.Cat["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;

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..