DIRECTORY
CCTypes USING[ApplyOperand, BinaryTargetTypes, Conforms, CCError, CCErrorCase, CCTypeProcs, CheckConformance, CoerceToType, ConformanceCheck, CreateCedarType, CreateNodeFromRefAny, GetBooleanType, GetCirioAddressType, GetIndirectType, GetTypeClass, GetNilPointerType, GetNodeType, GetProcDataFromGroundType, GetProcDataFromType, GetRTargetType, GetTargetTypeOfIndirect, Index, Load, LR, Operand, Operator, SelectIdField, UnaryOp, PrintType, GetGroundTypeClass],
CedarCode USING[CodeToLoadContentsOfAMNode, CodeToLoadThroughIndirect, CodeToCoerce, CodeToDoBinaryOp, CodeToDoUnaryOp, CodeToStoreUnpopped, ConcatCode, CreateCedarNode, ForceNodeIn, GetDataFromNode, GetNodeRepresentation, GetTypeOfNode, LoadThroughIndirectNode, OperationsBody, ShowNode, StoreThroughIndirectNode, ExtractFieldFromNode, SelectFieldFromNode, Coerce],
CedarNumericTypes USING [CreateNumericNode, CreateNumericType],
CedarOtherPureTypes USING[CreateBooleanNode, CreateParseTreeNode],
CirioSyntacticOperations USING[ParseTree],
CirioTypes USING[CirioAddress, BasicTypeInfo, Code, CompilerContext, Mem, Node, Type, TypedCode, TypeClass],
IO,
PointerTypes USING[PointerNodeInfo],
Rope USING[ROPE];
PointerInfo: TYPE = REF PointerInfoBody;
PointerInfoBody:
TYPE =
RECORD[
target: Type,
bti: BasicTypeInfo];
target = NIL is used for NIL POINTER; target = UNKNOWN type is used for POINTER TO UNSPECIFIED.
GetReferentType:
PUBLIC
PROC[pointerType: Type]
RETURNS[Type] ~ {
pointerInfo: PointerInfo ← NARROW[CCTypes.GetProcDataFromType[pointerType]];
RETURN[pointerInfo.target]};
CreatePointerType:
PUBLIC
PROC[clientTargetType: Type, cc:
CC, bti: BasicTypeInfo]
RETURNS[Type] =
BEGIN
pointerInfo: PointerInfo ← NEW[PointerInfoBody←[clientTargetType, bti]];
type: Type ← CCTypes.CreateCedarType[$pointer, PointerTypeCCTypeProcs, IndirectPointerTypeCCTypeProcs, cc, pointerInfo];
RETURN[type];
END;
CreateNilPointerType:
PUBLIC
PROC[cc:
CC]
RETURNS[Type] =
BEGIN
nominal: Type ← CCTypes.GetNilPointerType[cc];
IF nominal #
NIL
THEN
RETURN[nominal];
BEGIN --MJS, May 22, 1991: I think we never make an indirect NilPointer Type, because that would mean there's some memory constrainted by the Type system to have a NIL pointer in it always, which I think doesn't happen. So we can have a NIL bti and no createIndirectNode or getBitSize procs in IndirectNilPointerTypeCCTypeProcs.
pointerInfo: PointerInfo ← NEW[PointerInfoBody←[NIL, NIL]];
type: Type ← CCTypes.CreateCedarType[$nilPointer, NilPointerTypeCCTypeProcs, IndirectNilPointerTypeCCTypeProcs, cc, pointerInfo];
RETURN[type];
END;
END;
PointerTypeCCTypeProcs:
REF CCTypes.CCTypeProcs ←
NEW[CCTypes.CCTypeProcs ←[
checkConformance: PointerCCTypesCheckConformance,
binaryOperandTypes: PointerCCTypesBinaryOperandTypes,
getRTargetType: PointerCCTypesGetRTargetType,
operand: PointerCCTypesOperand,
indexOperand: PointerCCTypesIndexOperand,
coerceToType: PointerCCTypesCoerceToType,
binaryOp: PointerCCTypesBinaryOp,
unaryOp: PointerCCTypesUnaryOp,
selectIdField: PointerCCTypesSelectIdField,
index: PointerCCTypesIndex,
printType: PointerCCTypesPrintType]];
PointerCCTypesCheckConformance:
PROC[valType, varType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[CCTypes.ConformanceCheck] =
BEGIN
valInfo: PointerInfo ← NARROW[procData];
WITH CCTypes.GetProcDataFromGroundType[varType, cc]
SELECT
FROM
varInfo: PointerInfo =>
BEGIN
IF varInfo.target = NIL THEN RETURN[no]; -- var is NIL POINTER, we are not.
IF CCTypes.GetTypeClass[varInfo.target] = $unknown THEN RETURN [yes];
RETURN[CCTypes.CheckConformance[CCTypes.GetIndirectType[valInfo.target], CCTypes.GetIndirectType[varInfo.target], cc]];
END;
ENDCASE => RETURN[no];
END;
PointerCCTypesBinaryOperandTypes:
PROC[op: CCTypes.Operator, left, right: Type, cc:
CC, procData:
REF
ANY]
RETURNS[CCTypes.BinaryTargetTypes] =
BEGIN
leftInfo: PointerInfo ← NARROW[procData];
rightClass: CirioTypes.TypeClass ← CCTypes.GetGroundTypeClass[right, cc];
SELECT op
FROM
$assign =>
someone is trying to store through the POINTER
arrange to give him an indirect to the body
RETURN[[CCTypes.GetIndirectType[leftInfo.target], leftInfo.target]];
$plus, $minus =>
BEGIN
SELECT rightClass
FROM
$numeric =>
BEGIN
ptrOffsetType: Type ← PointerAddType[cc];
RETURN [[left, ptrOffsetType]];
END;
$pointer =>
BEGIN
ptrDiffType: Type ← PointerDiffType[cc];
IF op # $minus THEN CCE[cirioError];
RETURN [[ptrDiffType, ptrDiffType]];
END;
ENDCASE => CCE[cirioError];
END;
$eq, $ne, $lt, $gt, $le, $ge => RETURN [[left, left]];
ENDCASE => CCE[cirioError];
END;
Someone is trying to do an assignment through a POINTER and needs a (tentative) target type for the compilation of the right hand side. Lets give him the client target type.
PointerCCTypesGetRTargetType:
PROC[type: Type, cc:
CC, procData:
REF
ANY]
RETURNS[Type] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
RETURN[pointerTypeInfo.target];
END;
PointerCCTypesOperand:
PROC[op: CCTypes.Operator, lr: CCTypes.
LR, tc: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
IF pointerTypeInfo.target =
NIL
THEN
-- we are dealing with a POINTER TO UNSPECIFIED.
True Cedar would reject this situation
We package everything up into nodes and try again at run time
RETURN[CCTypes.CoerceToType[CCTypes.GetNodeType[cc], tc, cc]]
ELSE
-- we are not dealing with a POINTER TO UNSPECIFIED.
SELECT op
FROM
$selectId, $uparrow, $index, $leftSideuparrow => RETURN[tc];
$plus, $minus => RETURN[tc];
$dot, $extractId, $apply =>
-- try dereferencing first
BEGIN
tc1: TypedCode ← CCTypes.UnaryOp[$uparrow, tc, cc];
RETURN[CCTypes.Operand[op, lr, tc1, cc]];
END;
$eq, $ne, $lt, $gt, $le, $ge => RETURN[tc];
ENDCASE => CCE[operation]; -- client error, invalid operation
END;
PointerCCTypesIndexOperand:
PROC[operatorType: Type, operand: CirioSyntacticOperations.ParseTree, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
IF pointerTypeInfo.target =
NIL
THEN
-- we are dealing with a POINTER TO UNSPECIFIED.
True Cedar would reject this situation
generate code to package the operand into a node. This will cause the caller to package the operator into a node and try again at run time.
BEGIN
node: Node ← CedarOtherPureTypes.CreateParseTreeNode[operand, cc];
code: CirioTypes.Code ← CedarCode.CodeToLoadContentsOfAMNode[node];
type: Type ← CCTypes.GetNodeType[cc];
RETURN[[code, type]];
END
ELSE
-- we are not dealing with a POINTER TO UNSPECIFIED.
treat the operand the same as would be done for an ApplyOperand of the pointer target type
RETURN[CCTypes.ApplyOperand[pointerTypeInfo.target, operand, cc]];
END;
By the time we get here, we know that we do not conform
So we try handing out an indirect to the body of the target
This is exactly what PointerCCTypesBinaryOperandTypes is expecting us to do when we are the left hand side of an assignment.
PointerCCTypesCoerceToType:
PROC[targetType: Type, tc: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
IF CCTypes.Conforms[CCTypes.GetCirioAddressType[cc], targetType, cc]
OR CCTypes.Conforms[PointerDiffType[cc], targetType, cc]
THEN
BEGIN
code: Code ← CedarCode.ConcatCode[tc.code, CedarCode.CodeToCoerce[tc.type, targetType]];
RETURN [[code, targetType]];
END
ELSE
CCE[typeConformity];
END;
PointerCCTypesBinaryOp:
PROC[op: CCTypes.Operator, left, right: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
rightClass: CirioTypes.TypeClass ← CCTypes.GetGroundTypeClass[right.type, cc];
finalOp: CCTypes.Operator ←
SELECT
TRUE
FROM
op = $plus AND rightClass = $numeric => $incrementPointer,
op = $minus AND rightClass = $numeric => $decrementPointer,
op = $minus AND rightClass = $pointer => $pointerDifference,
op = $eq AND rightClass = $pointer => $pointerEq,
op = $ne AND rightClass = $pointer => $pointerNe,
op = $lt AND rightClass = $pointer => $pointerLt,
op = $gt AND rightClass = $pointer => $pointerGt,
op = $le AND rightClass = $pointer => $pointerLe,
op = $ge AND rightClass = $pointer => $pointerGe,
ENDCASE => CCE[operation];
finalType: Type ←
SELECT
TRUE
FROM
op = $plus AND rightClass = $numeric => left.type,
op = $minus AND rightClass = $numeric => left.type,
op = $minus AND rightClass = $pointer => PointerDiffType[cc],
rightClass = $pointer AND (op = $eq OR op = $ne OR op = $lt OR op = $gt OR op = $le OR op = $ge) => CCTypes.GetBooleanType[cc],
ENDCASE => CCE[operation];
code: CirioTypes.Code ← CedarCode.ConcatCode[left.code, CedarCode.ConcatCode[right.code, CedarCode.CodeToDoBinaryOp[finalOp, left.type, right.type]]];
RETURN [[code, finalType]];
END;
PointerCCTypesUnaryOp:
PROC[op: CCTypes.Operator, arg: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
SELECT op
FROM
$leftSideuparrow =>
BEGIN
type: Type ← CCTypes.GetIndirectType[pointerTypeInfo.target];
RETURN[[arg.code, type]];
END;
$uparrow =>
BEGIN
code2: Code ← CedarCode.CodeToLoadThroughIndirect[CCTypes.GetIndirectType[pointerTypeInfo.target]];
code: Code ← CedarCode.ConcatCode[arg.code, code2];
RETURN[[code, pointerTypeInfo.target]];
END;
ENDCASE => CCE[typeConformity]; -- client type error
END;
hopefully, the id will be recognized by the body
PointerCCTypesSelectIdField:
PROC[id: Rope.
ROPE, fieldIndirectContext: Type, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
type1: Type ← CCTypes.GetIndirectType[pointerTypeInfo.target];
tc2: TypedCode ← CCTypes.SelectIdField[id, type1, cc];
RETURN[[tc2.code, tc2.type]];
END;
PointerCCTypesIndex:
PROC[operator: TypedCode, operand: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
type1: Type ← CCTypes.GetIndirectType[pointerTypeInfo.target];
tc1: TypedCode ← [operator.code, type1];
RETURN[CCTypes.Index[tc1, operand, cc]];
END;
PointerCCTypesPrintType:
PROC [to:
IO.
STREAM, type: Type, printDepth:
INT, printWidth:
INT, cc:
CC, procData:
REF
ANY] = {
pointerTypeInfo: PointerInfo ← NARROW[procData];
pointerTypeClass: CirioTypes.TypeClass ← CCTypes.GetGroundTypeClass[type, cc];
to.PutRope["LONG POINTER TO "];
CCTypes.PrintType[to, pointerTypeInfo.target, printDepth, printWidth, cc];
RETURN};
NilPointerTypeCCTypeProcs:
REF CCTypes.CCTypeProcs ←
NEW[CCTypes.CCTypeProcs ←[
checkConformance: NilPointerCCTypesCheckConformance]];
NilPointerCCTypesCheckConformance:
PROC[valType, varType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[CCTypes.ConformanceCheck] =
BEGIN
valInfo: PointerInfo ← NARROW[procData];
WITH CCTypes.GetProcDataFromGroundType[varType, cc]
SELECT
FROM
varInfo: PointerInfo =>
RETURN[yes]; -- NIL POINTER conforms to all POINTER types.
ENDCASE => RETURN[no];
END;
IndirectPointerTypeCCTypeProcs:
REF CCTypes.CCTypeProcs ←
NEW[CCTypes.CCTypeProcs ←[
createIndirectNode: PointerCreateIndirect,
getBitSize: PointerBitSize,
operand: IPointerCCTypesOperand,
unaryOp: IPointerCCTypesUnaryOp,
store: IPointerCCTypesStore,
load: IPointerCCTypesLoad,
printType: PointerCCTypesPrintType]];
IndirectNilPointerTypeCCTypeProcs:
REF CCTypes.CCTypeProcs ←
NEW[CCTypes.CCTypeProcs ←[
store: INilPointerCCTypesStore,
load: INilPointerCCTypesLoad]];
The code for load and store seems to be common to a lot of types. How can we make use of this fact?
PointerCreateIndirect:
PROC [cc:
CC, procData:
REF
ANY, indirectType, targetType: Type, mem: Mem]
RETURNS [Node] ~ {
pointerInfo: PointerInfo ~ NARROW[procData];
IF pointerInfo.bti=NIL THEN CCE[cirioError, "a pointer Type not connected to the target world is being asked to CreateIndirect"];
RETURN pointerInfo.bti.createIndirectNode[pointerInfo.bti, cc, indirectType, targetType, mem]};
PointerBitSize:
PROC[indirectType, targetType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[
CARD] ~ {
pointerInfo: PointerInfo ~ NARROW[procData];
IF pointerInfo.bti=NIL THEN CCE[cirioError, "a pointer Type not connected to the target world is being asked to GetBitSize"];
RETURN pointerInfo.bti.getBitSize[pointerInfo.bti, cc, indirectType, targetType]};
IPointerCCTypesOperand:
PROC[op: CCTypes.Operator, lr: CCTypes.
LR, tc: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
SELECT op
FROM
$selectId, $index, $leftSideuparrow =>
-- try dereferencing first
BEGIN
tc1: TypedCode ← CCTypes.Load[tc, cc];
RETURN[CCTypes.Operand[op, lr, tc1, cc]];
END;
$address => RETURN[tc];
ENDCASE => CCE[operation]; -- client error, invalid operation
END;
note: this is identical to the code for DefaultIndirect. How might we safely take advantage of this?
IPointerCCTypesUnaryOp:
PROC[op: CCTypes.Operator, arg: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
SELECT op
FROM
$address =>
BEGIN
code: CirioTypes.Code ← CedarCode.ConcatCode[
arg.code,
CedarCode.CodeToDoUnaryOp[op, arg.type]];
ptrType: Type ← CreatePointerType[CCTypes.GetTargetTypeOfIndirect[arg.type], cc, NIL--it's OK to give a NIL bti because the resultant pointer Type will never be asked to CreateIndirectNode or GetBitSize--];
RETURN [[code, ptrType]];
END;
ENDCASE => CCE[cirioError];
END;
IPointerCCTypesStore:
PROC[value: TypedCode, indirect: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
code: Code ← CedarCode.ConcatCode[
indirect.code,
CedarCode.ConcatCode[
value.code,
CedarCode.CodeToStoreUnpopped[indirect.type, value.type]]];
RETURN[[code, value.type]];
END;
IPointerCCTypesLoad:
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;
INilPointerCCTypesStore:
PROC[value: TypedCode, indirect: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
code: Code ← CedarCode.ConcatCode[
indirect.code,
CedarCode.ConcatCode[
value.code,
CedarCode.CodeToStoreUnpopped[indirect.type, value.type]]];
RETURN[[code, value.type]];
END;
INilPointerCCTypesLoad:
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;