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,
bti: BasicTypeInfo];

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]
ELSE
RETURN[tc]
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.PutFR1["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};



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

’
CPointerTypesImpl.mesa
Copyright Σ 1990, 1992 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
Willie-s, May 14, 1992 4:59 pm PDT
Started by theimer by copying from PointerTypesImpl.mesa at May 1, 1989 4:56:50 pm PDT.

Nodes begin here
Pointer nodes

ΚŽ•NewlineDelimiter

–
(cedarcode) style™
codeš
œ™Kšœ
Οe
œ7™BK™'K™=K™>K™"—K˜Kš
œW™WK˜š
Οk	˜	KšœžœΆ
žœ˜Ρ
Kšœ
žœ
˜ž
KšœžœN˜^Kšœžœ^˜qKšœžœ˜%Kšžœ
˜Kš
œ˜—K˜šΟnœžœ
ž˜ Kšžœ$ž˜-Kšžœ˜—Kšœž˜Kšžœžœ˜&Kšœžœ˜Kšœžœ˜'Kšœžœ˜Kšœžœ˜Kšœžœ˜Kšœžœ˜/šžœžœ&žœžœ˜NK™—Kšœ
žœžœ˜(šœžœžœ
˜Kš
œ
˜
š
œ˜K˜——Kšœžœ˜Kšœ
žœ˜K˜š
Ÿœžœ
žœžœžœ
˜dKšœžœ*˜HK˜|Kšžœ˜—K˜šŸœžœžœ˜TK˜*Kš
œ˜—K˜šŸœžœžœžœ
žœ,žœ˜tKšœžœ˜,Kšžœžœ
žœ
žœb˜
KšžœY˜_—K˜šŸœžœ%žœžœ
žœžœ
žœ˜aKšœžœ˜,Kšžœžœ
žœ
žœ^˜}KšžœL˜R—K˜šŸœžœžœ˜LK˜1K˜5K˜-K˜K˜)K˜K˜!K˜%—K˜šŸœžœžœžœ
žœžœ˜}Kšœžœ˜(Kšœ
žœ!˜/šžœ
ž˜š
œ˜Kšœžœ1˜Nšžœ˜ Kš
œ(˜(Kš
œ(˜(Kš
œ˜——š
œ˜˜;KšžœN˜QKšœžœ˜	—Kšžœ2˜8—Kšžœžœ˜—Kš
œ˜—K˜šŸ œžœ.žœžœ
žœžœ˜‘
Kšœžœ˜/šžœž˜Kšœžœ˜%š
œ˜˜;KšžœN˜QKšœžœ˜	—Kšžœ˜—Kšžœžœ<˜J—Kš
œ˜—K˜šŸœžœžœžœ
žœžœ˜YKš
ž˜Kšœžœ˜0Kšžœ˜Kšžœ
˜—K˜šŸœžœ#žœžœžœ
žœžœ
˜€
Kš
ž˜Kšžœ˜Kšžœ
˜—K˜šŸœžœ&žœžœ
žœžœ
˜qKš
ž˜Kšœžœ˜0šžœ%žœ
˜,Kšžœ˜—š
ž˜Kšžœ˜
—Kšžœ
˜—K˜šŸœžœ+žœžœ
žœžœ
˜qKš
ž˜Kšœžœ˜0šžœž˜˜Kš
ž˜šžœ˜Kš
œ`˜`Kš
œ˜—Kš
ž˜—Kšžœžœ˜—Kšžœ
˜K˜—šŸœžœ>žœžœ
žœžœ
˜…
Kš
ž˜Kšœžœ˜0šžœž˜˜)šžœ˜Kš
œ
˜
š
œ!˜!Kš
œM˜M——Kš
œ˜—˜
šžœ˜Kš
œ
˜
š
œ!˜!Kš
œE˜E——Kš
œ˜—KšžœžœžœN˜n—Kšžœ
˜—K˜šŸœžœžœžœ˜7šœžœ!˜)KšžœN˜QKšœžœ˜
——K˜šŸœžœžœ
žœžœžœžœžœ
žœ˜zKšœžœ˜0K˜Kš
œT˜TKšžœ˜—K˜š
œ™˜Kš
œ
™
™K˜—š
Ÿœžœ
žœ6žœžœ˜gKš
ž˜Kšžœ8˜>Kšžœ
˜K˜—šŸœžœžœ˜MK˜K˜K˜—K˜šŸœžœ\žœžœ
˜Š
Kšœ*žœ&˜VK˜Cšžœž˜š
œ˜K˜ošžœž˜š
œ
˜
šžœ"žœ&žœ˜SK˜SKšžœ˜—Kšžœ
žœ˜—Kšžœžœ˜—Kš
œ˜—š
œ˜šžœž˜˜Kšžœ0˜6—š
œ˜šžœž˜Kšžœ,˜2—Kšžœ
žœ˜—Kšžœžœ˜ ——Kšžœžœ˜—Kš
œ˜—K˜šŸœžœ.žœžœ	˜WKš
ž˜Kšœ&žœ*˜VKšžœt˜zKšžœ
˜—K˜šŸœžœžœ
žœžœ	žœžœ˜TKšœ&žœ"˜NK˜‚
K˜Kš
œ1˜1Kšžœ˜—K˜——Kšžœ˜—…— |*¬