<<>> <> <> <> <> <> <> <> <> <> 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; <> <> <<>> <<>> <> 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]]; <> <> 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 <> <> 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; <> 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 <> <> 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; <> 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; <> RecordCCTypesGetNVariants: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[INT] = {RETURN[0]}; <> 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; <<>> <> RecordCCTypesCoerceToType: PROC[targetType: Type, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] = BEGIN tcTypeInfo: RecordTypeInfo _ NARROW[procData]; <> 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]; <> 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 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); <> 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}; <> 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"]]; <> 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? <> ENDCASE => ERROR; RETURN[[CedarCode.CodeToSelectField[id, fieldIndirectContext], indirectFieldType]]; END ELSE CCE[operation, Rope.Cat["field ", id, " does not exist"]]; -- no such field END; <> <<>> 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; <> 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; <> 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 <<>> <> nodeTimeReadWrite, nodeTimeReadOnly => BEGIN field: Node _ irData.procs.selectField[index, indirectFieldType, irData.data, cc]; RETURN[CedarCode.LoadThroughIndirectNode[indirectFieldType, field, cc]]; END; <<>> <> nodeTimeConstant => RETURN[irData.procs.fieldIndexToNodeTimeConstantValue[index, fieldType, irData.data, cc]]; <> typeTimeConstant => RETURN[irTypeInfo.procs.fieldIndexToCompileTimeConstantValue[index, cc, irTypeInfo]]; ENDCASE => CCE[cirioError]; END; <> <<>> 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.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}; <<>> <<>> <> ConstructRecordNode: PUBLIC PROC[recordType: CirioTypes.Type, fields: LIST OF CirioTypes.Node, cc: CC] RETURNS[CirioTypes.Node] = BEGIN <> <> <> <> <> 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..