CPointerTypesImpl.mesa
Copyright Ó 1990 by Xerox Corporation. All rights reserved.
Hopcroft August 18, 1989 6:25:13 pm PDT
Last changed by Theimer on September 28, 1989 10:57:04 am PDT
Last tweaked by Mike Spreitzer on January 9, 1992 10:20 am PST
Started by theimer by copying from PointerTypesImpl.mesa at May 1, 1989 4:56:50 pm PDT.
DIRECTORY
CCTypes USING[BinaryTargetTypes, BreakPrintType, CCError, CCErrorCase, CCTypeProcs, CheckConformance, ConformanceCheck, CreateCedarType, GetIndirectType, GetProcDataFromGroundType, GetTypeClass, LR, Operator],
CedarCode USING[CodeToDoBinaryOp, CodeToLoadThroughIndirect, ConcatCode, CreateCedarNode, GetDataFromNode, LoadThroughIndirectNode, OperationsBody, ShowNode],
CirioTypes USING[BasicTypeInfo, Code, CompilerContext, Mem, Node, Type, TypedCode, TypeClass],
CNumericTypes USING [CreateNumericType, GetDescriptorFromCNumericType, NumericDescriptor, NumericDescriptorBody],
CPointerTypes USING[PointerNodeInfo],
IO,
Rope;
CPointerTypesImpl:
CEDAR
PROGRAM
IMPORTS CCTypes, CedarCode, CNumericTypes, IO
EXPORTS CPointerTypes
= BEGIN
CC: TYPE = CirioTypes.CompilerContext;
Type: TYPE = CirioTypes.Type;
TypedCode: TYPE = CirioTypes.TypedCode;
Code: TYPE = CirioTypes.Code;
Node: TYPE = CirioTypes.Node;
Mem: TYPE = CirioTypes.Mem;
BasicTypeInfo: TYPE = CirioTypes.BasicTypeInfo;
CCE:
ERROR[case: CCTypes.CCErrorCase, msg: Rope.
ROPE ←
NIL] ← CCTypes.CCError;
PointerInfo: TYPE = REF PointerInfoBody;
PointerInfoBody:
TYPE =
RECORD[
target: Type,
pointerClass: ATOM = $pointer;
numberClass: ATOM = $numeric;
CreatePointerType:
PUBLIC
PROC[clientTargetType: Type, cc:
CC, bti: BasicTypeInfo]
RETURNS[Type] = {
pointerInfo: PointerInfo ← NEW[PointerInfoBody←[clientTargetType, bti]];
type: Type ← CCTypes.CreateCedarType[pointerClass, PointerTypeCCTypeProcs, IndirectPointerTypeCCTypeProcs, cc, pointerInfo];
RETURN[type]};
IndirectPointerTypeCCTypeProcs:
REF CCTypes.CCTypeProcs ←
NEW[CCTypes.CCTypeProcs ←[
createIndirectNode: PointerCreateIndirect,
getBitSize: PointerBitSize]];
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]};
PointerTypeCCTypeProcs:
REF CCTypes.CCTypeProcs ←
NEW[CCTypes.CCTypeProcs ←[
checkConformance: PointerCCTypesCheckConformance,
binaryOperandTypes: PointerCCTypesBinaryOperandTypes,
getRTargetType: PointerCCTypesGetRTargetType,
operand: PointerCCTypesOperand,
coerceToType: PointerCCTypesCoerceToType,
unaryOp: PointerCCTypesUnaryOp,
binaryOp: PointerCCTypesBinaryOp,
printType: PointerCCTypesPrintType]];
PointerCCTypesCheckConformance:
PROC[valType, varType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[CCTypes.ConformanceCheck] = {
valInfo: PointerInfo ← NARROW[procData];
varClass: ATOM ← CCTypes.GetTypeClass[varType];
SELECT varClass
FROM
pointerClass => {
varInfo: PointerInfo ~ NARROW[CCTypes.GetProcDataFromGroundType[varType, cc]];
RETURN[CCTypes.CheckConformance[
CCTypes.GetIndirectType[valInfo.target],
CCTypes.GetIndirectType[varInfo.target],
cc]]};
numberClass => {
intType: CirioTypes.Type ← CNumericTypes.CreateNumericType[
NEW[CNumericTypes.NumericDescriptorBody ← [primary: signed, secondary: integer]],
cc, NIL];
RETURN[CCTypes.CheckConformance[intType, varType, cc]]};
ENDCASE => RETURN[no];
};
PointerCCTypesBinaryOperandTypes:
PROC[op: CCTypes.Operator, left, right: Type, cc:
CC, procData:
REF
ANY]
RETURNS[CCTypes.BinaryTargetTypes] = {
rightClass: ATOM ← CCTypes.GetTypeClass[right];
SELECT rightClass
FROM
pointerClass => RETURN[[left,right]];
numberClass => {
intType: CirioTypes.Type ← CNumericTypes.CreateNumericType[
NEW[CNumericTypes.NumericDescriptorBody ← [primary: signed, secondary: integer]],
cc, NIL];
RETURN[[left, intType]]};
ENDCASE => CCE[operation, "illegal pointer / something binary operation"];
};
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
RETURN[tc];
END;
PointerCCTypesCoerceToType:
PROC[targetType: Type, tc: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
IF pointerTypeInfo.target # targetType
THEN
CCE[typeConformity]
END;
PointerCCTypesUnaryOp:
PROC[op: CCTypes.Operator, arg: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ← NARROW[procData];
SELECT op
FROM
$uparrow =>
BEGIN
RETURN[[CedarCode.ConcatCode[
arg.code, CedarCode.CodeToLoadThroughIndirect[CCTypes.GetIndirectType[pointerTypeInfo.target]]],
pointerTypeInfo.target]];
END
ENDCASE => CCE[typeConformity];
END;
PointerCCTypesBinaryOp:
PROC[op: CCTypes.Operator, left, right: CirioTypes.TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pointerTypeInfo: PointerInfo ~ NARROW[procData];
SELECT op
FROM
$minus, $eq, $ne, $lt, $gt, $le, $ge => {
RETURN[[CedarCode.ConcatCode[
left.code,
CedarCode.ConcatCode[right.code,
CedarCode.CodeToDoBinaryOp[op, left.type, right.type]]], CreateBoolType[cc]]]
};
$plus => {
RETURN[[CedarCode.ConcatCode[
left.code,
CedarCode.ConcatCode[right.code,
CedarCode.CodeToDoBinaryOp[op, left.type, right.type]]], left.type]];
};
ENDCASE => CCE[unimplemented, IO.PutFR["the binary op `%g' is not implemented for C pointers", [atom[op]] ]];
END;
CreateBoolType:
PROC [cc:
CC]
RETURNS [CirioTypes.Type]
~{
RETURN CNumericTypes.CreateNumericType[
NEW[CNumericTypes.NumericDescriptorBody ← [primary: signed, secondary: integer]],
cc, NIL]};
PointerCCTypesPrintType:
PROC [to:
IO.
STREAM, type: Type, printDepth:
INT, printWidth:
INT, cc:
CC, procData:
REF
ANY] = {
pointerTypeInfo: PointerInfo ← NARROW[procData];
to.PutRope["POINTER TO"];
CCTypes.BreakPrintType[to, pointerTypeInfo.target, printDepth, printWidth, cc, " "];
RETURN};
Nodes begin here
Pointer nodes
CreatePointerNode:
PUBLIC
PROC[type: Type, info: CPointerTypes.PointerNodeInfo, cc:
CC]
RETURNS[Node] =
BEGIN
RETURN[CedarCode.CreateCedarNode[PointerNodeOps, type, info]];
END;
PointerNodeOps:
REF CedarCode.OperationsBody ←
NEW[CedarCode.OperationsBody←[
binaryOp: PointerNodeBinaryOp,
load: PointerNodeLoad,
show: PointerNodeShow]];
PointerNodeBinaryOp:
PROC[op: CCTypes.Operator, leftType, rightType: Type, leftNode, rightNode: CirioTypes.Node, cc:
CC]
RETURNS[Node] = {
leftData: CPointerTypes.PointerNodeInfo ← NARROW[CedarCode.GetDataFromNode[leftNode]];
rightClass: CirioTypes.TypeClass ← CCTypes.GetTypeClass[rightType];
SELECT rightClass
FROM
numberClass => {
rightDescriptor: CNumericTypes.NumericDescriptor ← CNumericTypes.GetDescriptorFromCNumericType[rightType, cc];
SELECT op
FROM
$plus => {
IF rightDescriptor.primary = signed
AND
rightDescriptor.secondary = integer
THEN {
newIndirectNode: CirioTypes.Node ← leftData.add[leftNode, rightNode, leftData, cc];
RETURN[newIndirectNode]}
ELSE CCE[typeConformity]};
ENDCASE => CCE[typeConformity];
};
pointerClass => {
SELECT op
FROM
$le, $lt, $eq, $ne, $gt, $ge =>
RETURN[leftData.compare[leftNode, rightNode, op, cc]];
$minus => {
IF leftType = rightType
THEN
RETURN[leftData.subtract[leftNode, rightNode, cc]]
ELSE CCE[typeConformity]};
ENDCASE => CCE[typeConformity]};
ENDCASE => CCE[typeConformity];
};
PointerNodeLoad:
PROC [indirectType: Type, indirectNode: Node, cc:
CC]
RETURNS [Node] ~
BEGIN
data: CPointerTypes.PointerNodeInfo ← NARROW[CedarCode.GetDataFromNode[indirectNode]];
RETURN[CedarCode.LoadThroughIndirectNode[CCTypes.GetIndirectType[data.clientTargetType], data.indirectToClientTarget, cc]]
END;
PointerNodeShow:
PROC[to:
IO.
STREAM, node: Node, depth:
INT, width:
INT, cc:
CC] = {
data: CPointerTypes.PointerNodeInfo ← NARROW[CedarCode.GetDataFromNode[node]];
target: Node ← CedarCode.LoadThroughIndirectNode[CCTypes.GetIndirectType[data.clientTargetType], data.indirectToClientTarget, cc];
to.PutChar['^];
CedarCode.ShowNode[to, target, depth, width, cc];
RETURN};
END..