CedarNumericTypesImpl.mesa
Copyright Ó 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Sturgis, September 13, 1989 11:46:03 am PDT
Last changed by Theimer on July 16, 1989 4:27:30 pm PDT
Hopcroft July 26, 1989 10:23:52 am PDT
Spreitze, January 9, 1992 9:54 am PST
Laurie Horton, January 29, 1992 10:17 am PST
Katsuyuki Komatsu January 6, 1993 10:42 am PST
DIRECTORY
CedarCode USING[CodeToDoBinaryOp, Code, CodeToCoerce, ConcatCode, CodeToMakeAMNode, CodeToDoUnaryOp, CreateCedarNode, GetDataFromNode, GetTypeOfNode, OperationsBody, Operator],
CCTypes USING[BinaryTargetTypes, CCError, CCErrorCase, CCTypeProcs, ConformanceCheck, CreateCedarType, GetBooleanType, GetCedarNumericType, GetGroundTypeClass, GetNodeType, GetProcDataFromGroundType, GetProcDataFromType, GetWrongType, LR, Operator, SetCedarNumericType],
CedarNumericTypes USING[NumericDescriptor],
CedarOtherPureTypes USING[CreateBooleanNode],
CirioTypes USING[BasicTypeInfo, CompilerContext, Mem, Node, Type, TypeClass, TypedCode],
Convert USING[RopeFromCard, RopeFromInt, RopeFromReal],
IO,
Rope;
CedarNumericTypesImpl:
CEDAR
PROGRAM
IMPORTS CedarCode, CCTypes, CedarOtherPureTypes, Convert, IO
EXPORTS CedarNumericTypes
= BEGIN OPEN CCTypes, CedarCode, CedarNumericTypes, CirioTypes;
CC: TYPE = CompilerContext;
CCE: ERROR[case: CCTypes.CCErrorCase, msg: Rope.ROPE ← NIL] ← CCTypes.CCError;
GetNumericType:
PROC[desc: NumericDescriptor, cc:
CC]
RETURNS[t: CirioTypes.Type] = {
t ← CCTypes.GetCedarNumericType[desc, cc, FALSE];
IF t=NIL THEN t ← CreateNumericType[desc, cc, NIL];
RETURN};
CreateNumericType:
PUBLIC
PROC[desc: NumericDescriptor, cc:
CC, bti: CirioTypes.BasicTypeInfo]
RETURNS[CirioTypes.Type] = {
nominal: CirioTypes.Type ← CCTypes.GetCedarNumericType[desc, cc, FALSE];
IF nominal=
NIL
OR (bti#
NIL
AND
NARROW[CCTypes.GetProcDataFromType[nominal], NumericType].bti=
NIL)
THEN {
nominal ← CreateCedarType[$numeric, NumericCCTypeProcs, IndirectNumericCCTypeProcs, cc, NEW[NumericTypePrivate ← [NEW[NumericDescriptor ← desc], bti]] ];
CCTypes.SetCedarNumericType[cc, desc, nominal]};
RETURN[nominal]};
NumericType: TYPE ~ REF NumericTypePrivate;
NumericTypePrivate:
TYPE ~
RECORD [
desc: REF NumericDescriptor,
bti: CirioTypes.BasicTypeInfo];
GetDescriptorFromCedarNumericType:
PUBLIC
PROC[type: CirioTypes.Type, cc:
CC]
RETURNS[
REF NumericDescriptor] = {
gtd: REF ANY ← GetProcDataFromGroundType[type, cc];
WITH gtd
SELECT
FROM
nt: NumericType => RETURN[nt.desc];
ENDCASE => RETURN[NIL]};
NumericCCTypeProcs:
REF CCTypeProcs ←
NEW[CCTypeProcs ←[
checkConformance: NumericCheckConformance,
binaryOperandTypes: NumericBinaryOperandTypes,
asIndexSet: NumericAsIndexSet,
operand: NumericOperand,
coerceToType: NumericCoerceToType,
binaryOp: NumericBinaryOp,
unaryOp: NumericUnaryOp,
nAryOperandType: NumericNAryOperandType,
nAryOp: NumericNAryOp,
getNElements: NumericalGetNElements,
printType: NumericalPrintType
]];
IndirectNumericCCTypeProcs:
REF CCTypeProcs ←
NEW[CCTypeProcs ←[
createIndirectNode: NumericCreateIndirect,
getBitSize: NumericBitSize,
printType: NumericalPrintType
]];
NumericCreateIndirect:
PROC [cc:
CC, procData:
REF
ANY, indirectType, targetType: Type, mem: Mem]
RETURNS [Node] ~ {
nt: NumericType ~ NARROW[procData];
IF nt.bti=NIL THEN CCE[cirioError, "bti-less numeric type asked to createIndirect"];
RETURN nt.bti.createIndirectNode[nt.bti, cc, indirectType, targetType, mem]};
NumericBitSize:
PROC[indirectType, targetType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[
CARD] ~ {
nt: NumericType ~ NARROW[procData];
IF nt.bti=NIL THEN CCE[cirioError, "bti-less numeric type asked to getBitSize"];
RETURN nt.bti.getBitSize[nt.bti, cc, indirectType, targetType]};
valType was the control parameter
NumericCheckConformance:
PROC[valType, varType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[CCTypes.ConformanceCheck] =
BEGIN
WITH GetProcDataFromGroundType[varType, cc]
SELECT
FROM
varNT: NumericType => {
valNT: NumericType ← NARROW[GetProcDataFromGroundType[valType, cc]];
RETURN[IF NDEqual[valNT.desc^, varNT.desc^] THEN yes ELSE no];
};
ENDCASE => RETURN[no];
END;
By the time we get here, the left operand type is numeric and both operands are suitable for the given op. Therefore, the right operand should also be numeric or amnode
Note: experiments by Russ Atkinson November 7, 1988 show that mul and div behave differently on mixed signed/unsigned 32 bit arguments. I have choosen to not allow any mixed signed/unsigned 32 bit arguments.
Remark: Perhaps this can be combined with NumericNAryOperandType. At least, there are several pieces of code that occur here several times and there several times that could be made into procedures.
NumericBinaryOperandTypes:
PROC[op: Operator, left, right: Type, cc:
CC, procData:
REF
ANY]
RETURNS[BinaryTargetTypes] =
BEGIN
leftNT: NumericType ← NARROW[procData];
leftDesc: REF NumericDescriptor ← leftNT.desc;
rightClass: TypeClass ← GetGroundTypeClass[right, cc];
SELECT op
FROM
$plus, $minus, $div, $mult, $mod, $le, $lt, $eq, $ne, $gt, $ge =>
SELECT rightClass
FROM
$wrong, $amnode => RETURN[[right, right]];
$numeric =>
BEGIN
rightNT: NumericType ← NARROW[GetProcDataFromGroundType[right, cc]];
rightDesc: REF NumericDescriptor ← rightNT.desc;
WITH leftDesc
SELECT
FROM
realLeft: REF real NumericDescriptor => RETURN[[left, left]];
signedLeft:
REF signed NumericDescriptor =>
WITH rightDesc
SELECT
FROM
realRight: REF real NumericDescriptor => RETURN[[right, right]];
signedRight:
REF signed NumericDescriptor =>
BEGIN -- we must actually construct a new type since the given ones might be subranges
maxBits: INT ← MAX[signedLeft.nBits, signedRight.nBits];
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[[maxType, maxType]];
END;
unsignedRight:
REF unsigned NumericDescriptor =>
BEGIN
we must watch out for signed/unsigned problems with comparisons
and what do we use as a max type for <INT32, CARD32>
SELECT op
FROM
$plus, $minus, $div, $mult, $mod =>
BEGIN
maxBits: INT ← MAX[signedLeft.nBits, unsignedRight.nBits];
IF (maxBits = 32)
AND (signedLeft.nBits = unsignedRight.nBits)
THEN
CCE[operation, "signed/unsigned error"]; -- signed/unsigned client error
IF signedLeft.nBits = unsignedRight.nBits
THEN
BEGIN -- must both be 16 bit operands, so either 32 bit target type will do
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[[maxType, maxType]];
END;
IF signedLeft.nBits = 32
THEN
BEGIN -- go for signed as other must be 16 bit operand
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[[maxType, maxType]];
END;
IF unsignedRight.nBits = 32
THEN
BEGIN -- go for unsigned as other must be 16 bit operand
maxType: Type ← GetNumericType[[maxBits, unsigned[full[]]], cc];
RETURN[[maxType, maxType]];
END;
CCE[cirioError] -- shouldn't happen
END;
$le, $lt, $eq, $ne, $gt, $ge => CCE[operation, "signed/unsigned error"]; -- signed/unsigned client error
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
unsignedLeft:
REF unsigned NumericDescriptor =>
WITH rightDesc
SELECT
FROM
realRight: REF real NumericDescriptor => RETURN[[right, right]];
signedRight:
REF signed NumericDescriptor =>
BEGIN
we must watch out for signed/unsigned problems with comparisons
and what do we use as a max type for <CARD32, INT32>
SELECT op
FROM
$plus, $minus, $div, $mult, $mod =>
BEGIN
maxBits: INT ← MAX[unsignedLeft.nBits, signedRight.nBits];
IF (maxBits = 32)
AND (unsignedLeft.nBits = signedRight.nBits)
THEN
CCE[operation, "signed/unsigned error"]; -- signed/unsigned client error
IF unsignedLeft.nBits = signedRight.nBits
THEN
BEGIN -- must both be 16 bit operands, so either 32 bit target type will do
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[[maxType, maxType]];
END;
IF unsignedLeft.nBits = 32
THEN
BEGIN -- go for unsigned as other must be 16 bit operand
maxType: Type ← GetNumericType[[maxBits, unsigned[full[]]], cc];
RETURN[[maxType, maxType]];
END;
IF signedRight.nBits = 32
THEN
BEGIN -- go for signed as other must be 16 bit operand
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[[maxType, maxType]];
END;
CCE[cirioError] -- shouldn't happen
END;
$le, $lt, $eq, $ne, $gt, $ge => CCE[operation, "signed/unsigned error"]; -- signed/unsigned client error
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
unsignedRight:
REF unsigned NumericDescriptor =>
BEGIN -- we must actually construct a new type since the given ones might be subranges
maxBits: INT ← MAX[unsignedLeft.nBits, unsignedRight.nBits];
maxType: Type ← GetNumericType[[maxBits, unsigned[full[]]], cc];
RETURN[[maxType, maxType]];
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen;
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen?
END;
NumericAsIndexSet:
PROC[type: Type, cc:
CC, procData:
REF
ANY]
RETURNS[Type] =
BEGIN
nt: NumericType ← NARROW[procData];
desc: REF NumericDescriptor ← nt.desc;
WITH desc
SELECT
FROM
sd:
REF full signed NumericDescriptor =>
this is a GLITCH in the Cedar language.
I am told that it was introduced to make SEQUENCE n: INTEGER OF FOO produce a sequence that is indexed starting from 0. I don't know if it also applies to INT32.
SELECT sd.nBits
FROM
16 => RETURN[GetNumericType[[16, signed[subRange[0, LAST[INTEGER]]]], cc]];
ENDCASE => RETURN[type];
ENDCASE => RETURN[type];
END;
tc.type is numeric
NumericOperand:
PROC[op: Operator, lr:
LR, tc: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
SELECT op
FROM
$plus, $minus, $div, $mult, $mod, $le, $lt, $eq, $gt, $ge, $max, $min => RETURN[tc];
$and, $or, $not => RETURN[[tc.code, GetWrongType[cc]]];
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
tc.type is numeric
we take the following simplistic view. If the two type descriptors are equal, we return tc. If they are different, some cases do not allow any run time coercion, we generate an operation error. For the moment, we will generate coercions in situations that we should generate an error. That will lead to a run time error that we could have caught at compile time.
NumericCoerceToType:
PROC[targetType: Type, tc: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
targetClass: TypeClass ← GetGroundTypeClass[targetType, cc];
SELECT targetClass
FROM
$wrong => RETURN[[tc.code, GetWrongType[cc]]];
$amnode =>
RETURN[[ConcatCode[tc.code, CodeToMakeAMNode[tc.type]], GetNodeType[cc]]];
$numeric =>
BEGIN
targetNT: NumericType ← NARROW[GetProcDataFromGroundType[targetType, cc]];
targetDescriptor: REF NumericDescriptor ← targetNT.desc;
sourceNT: NumericType ← NARROW[procData];
sourceDescriptor: REF NumericDescriptor ← sourceNT.desc;
IF NDEqual[targetDescriptor^, sourceDescriptor^]
THEN
RETURN[tc]
ELSE
WITH sourceDescriptor
SELECT
FROM
realSource:
REF real NumericDescriptor =>
CCE[operation]; -- target must be discrete numeric, else we would have equal descriptors
signedSource: REF signed NumericDescriptor => RETURN[[ConcatCode[tc.code, CodeToCoerce[tc.type, targetType]], targetType]];
unsignedSource:
REF unsigned NumericDescriptor =>
RETURN[
[ConcatCode[tc.code, CodeToCoerce[tc.type, targetType]], targetType]];
ENDCASE => CCE[cirioError];
END;
ENDCASE => CCE[typeConformity];
END;
for numeric operations we assume that the target type is left.type
NumericBinaryOp:
PROC[op: Operator, left, right: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
targetType: CirioTypes.Type ←
SELECT op
FROM
$plus, $minus, $div, $mult, $mod => left.type,
$le, $lt, $eq, $gt, $ge => GetBooleanType[cc],
ENDCASE => CCE[cirioError]; -- shouldn't happen
leftNT: NumericType ← NARROW[procData];
leftDescriptor: REF NumericDescriptor ← leftNT.desc;
rightNT: NumericType ← NARROW[GetProcDataFromGroundType[right.type, cc]];
rightDescriptor: REF NumericDescriptor ← rightNT.desc;
RETURN[[ConcatCode[
left.code, ConcatCode[
right.code,
CodeToDoBinaryOp[op, left.type, right.type]]], targetType]];
END;
NumericUnaryOp:
PROC[op: Operator, arg: TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
targetType: CirioTypes.Type ←
SELECT op
FROM
$plus, $minus => arg.type,
ENDCASE => CCE[cirioError]; -- shouldn't happen
RETURN[[ConcatCode[
arg.code,
CodeToDoUnaryOp[op, arg.type]], targetType]];
END;
By the time we get here, typeSoFar is numeric and nextType is suitable for the given op.
NumericNAryOperandType:
PROC[op: Operator, typeSoFar, nextType: Type, cc:
CC, procData:
REF
ANY]
RETURNS[Type] =
BEGIN
soFarNT: NumericType ← NARROW[procData];
soFarDesc: REF NumericDescriptor ← soFarNT.desc;
nextClass: TypeClass ← GetGroundTypeClass[nextType, cc];
SELECT nextClass
FROM
$wrong, $amnode => RETURN[nextType];
$numeric =>
BEGIN
nextNT: NumericType ← NARROW[GetProcDataFromGroundType[nextType, cc]];
nextDesc: REF NumericDescriptor ← nextNT.desc;
WITH soFarDesc
SELECT
FROM
realSoFar: REF real NumericDescriptor => RETURN[typeSoFar];
signedSoFar:
REF signed NumericDescriptor =>
WITH nextDesc
SELECT
FROM
realNext: REF real NumericDescriptor => RETURN[nextType];
signedNext:
REF signed NumericDescriptor =>
BEGIN
we must actually construct a new type since the given ones might be subranges
maxBits: INT ← MAX[signedSoFar.nBits, signedNext.nBits];
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[maxType];
END;
unsignedNext: REF unsigned NumericDescriptor => CCE[operation, "signed/unsigned error"]; -- signed/unsigned client error
ENDCASE => CCE[cirioError]; -- shouldn't happen
unsignedSoFar:
REF unsigned NumericDescriptor =>
WITH nextDesc
SELECT
FROM
realNext: REF real NumericDescriptor => RETURN[nextType];
signedNext:
REF signed NumericDescriptor =>
CCE[operation, "signed/unsigned error"];
signed/unsigned client error
unsignedNext:
REF unsigned NumericDescriptor =>
BEGIN
we must actually construct a new type since the given ones might be subranges
maxBits: INT ← MAX[unsignedSoFar.nBits, unsignedNext.nBits];
maxType: Type ← GetNumericType[[maxBits, signed[full[]]], cc];
RETURN[maxType];
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
assumes that args is non empty
assumes that all arguments have same type
NumericNAryOp:
PROC[op: Operator, args:
LIST
OF TypedCode, cc:
CC, procData:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
targetType: CirioTypes.Type ← args.first.type;
nt: NumericType ← NARROW[procData];
descriptor: REF NumericDescriptor ← nt.desc;
code: Code ← args.first.code;
FOR ltc:
LIST
OF TypedCode ← args.rest, ltc.rest
WHILE ltc #
NIL
DO
argNT: NumericType ← NARROW[GetProcDataFromGroundType[ltc.first.type, cc]];
argDescriptor: REF NumericDescriptor 𡤊rgNT.desc;
IF NOT NDEqual[argDescriptor^, descriptor^] THEN CCE[cirioError]; -- shouldn't happen
code ← ConcatCode[code, ltc.first.code];
code ← ConcatCode[code, CodeToDoBinaryOp[op, targetType, ltc.first.type]];
ENDLOOP;
RETURN[[code, targetType]];
END;
NumericalGetNElements:
PROC[type: Type, cc:
CC, procData:
REF
ANY]
RETURNS[
CARD] =
BEGIN
nt: NumericType ← NARROW[procData];
descriptor: REF NumericDescriptor ← nt.desc;
WITH d: descriptor
SELECT
FROM
signed =>
WITH sd: d
SELECT
FROM
full =>
SELECT sd.nBits
FROM
<BITS[CARD] => RETURN[2**sd.nBits];
=
BITS[
CARD] =>
RETURN[
LAST[
CARD]];
WRONG!! we should be returning LAST[CARD]+1, but of course we can't represent that as a CARD. Perhaps I should change this interface? On the other hand, the only current user is Show applied to an array, and all this will do is prevent us from seeing all the entries, something we would never do.
ENDCASE => CCE[cirioError];
subRange => RETURN[sd.top-sd.bottom+1];
ENDCASE => CCE[cirioError];
unsigned =>
WITH sd: d
SELECT
FROM
full =>
SELECT sd.nBits
FROM
<BITS[CARD] => RETURN[2**sd.nBits];
=
BITS[
CARD] =>
RETURN[
LAST[
CARD]];
WRONG!! we should be returning LAST[CARD]+1, but of course we can't represent that as a CARD. Perhaps I should change this interface? On the other hand, the only current user is Show applied to an array, and all this will do is prevent us from seeing all the entries, something we would never do.
ENDCASE => CCE[cirioError];
subRange => RETURN[sd.top-sd.bottom+1];
ENDCASE => CCE[cirioError];
ENDCASE => CCE[cirioError];
END;
NumericalPrintType:
PROC [to:
IO.
STREAM, type: Type, printDepth:
INT, printWidth:
INT, cc:
CC, procData:
REF
ANY] = {
nt: NumericType ← NARROW[procData];
descriptor: REF NumericDescriptor ← nt.desc;
WITH d: descriptor
SELECT
FROM
real =>
to.PutRope["REAL"];
signed =>
WITH sd: d
SELECT
FROM
full =>
SELECT sd.nBits
FROM
8 => to.PutRope["CHAR"]; -- The arm for signed full 8-bit descriptors will never be taken, because nothing creates a signed full 8-bit CCTypes.NumericDescriptor. In Cedar, CHAR is distinct from the numeric types.
16 => to.PutRope["INT16"];
32 => to.PutRope["INT"];
64 => to.PutRope["DINT"];
ENDCASE => CCE[cirioError];
subRange => to.PutF["INT[%g..%g]", [integer[sd.bottom]], [integer[sd.top]] ];
ENDCASE => CCE[cirioError];
unsigned =>
WITH sd: d
SELECT
FROM
full =>
SELECT sd.nBits
FROM
8 => to.PutRope["BYTE"];
16 => to.PutRope["CARD16"];
32 => to.PutRope["CARD"];
64 => to.PutRope["DCARD"];
ENDCASE => CCE[cirioError];
subRange => to.PutF["CARD[%g..%g]", [cardinal[sd.bottom]], [cardinal[sd.top]] ];
ENDCASE => CCE[cirioError];
ENDCASE => CCE[cirioError];
};
Useful Code
NDEqual:
PUBLIC
PROC[left, right: NumericDescriptor]
RETURNS[eq:
BOOLEAN] = {
IF left.nBits#right.nBits THEN RETURN[FALSE];
WITH lf: left
SELECT
FROM
real => RETURN[right.primary = real];
signed =>
WITH r: right
SELECT
FROM
real, unsigned => RETURN[FALSE];
signed =>
WITH llf: lf
SELECT
FROM
full => RETURN[r.secondary = full];
subRange =>
WITH rr: r
SELECT
FROM
full => RETURN[FALSE];
subRange => RETURN[llf.bottom=rr.bottom AND llf.top = rr.top];
ENDCASE => CCE[cirioError]; -- shouldn't happen;
ENDCASE => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen
unsigned =>
WITH r: right
SELECT
FROM
real, signed => RETURN[FALSE];
unsigned =>
WITH llf: lf
SELECT
FROM
full => RETURN[r.secondary = full];
subRange =>
WITH rr: r
SELECT
FROM
full => RETURN[FALSE];
subRange => RETURN[llf.bottom=rr.bottom AND llf.top = rr.top];
ENDCASE => CCE[cirioError]; -- shouldn't happen;
ENDCASE => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen
};
NDHash:
PUBLIC
PROC [nd: NumericDescriptor]
RETURNS [
CARDINAL] ~ {
sum: CARDINAL ← LOOPHOLE[nd.nBits, CARD] + nd.primary.ORD*257;
WITH x: nd
SELECT
FROM
real => NULL;
signed => {
sum ← sum + x.secondary.ORD*65;
WITH y: x
SELECT
FROM
full => NULL;
subRange => sum ← sum + LOOPHOLE[y.bottom, CARD]*3 + LOOPHOLE[y.top, CARD]*17;
ENDCASE => ERROR;
};
unsigned => {
sum ← sum + x.secondary.ORD*65;
WITH y: x
SELECT
FROM
full => NULL;
subRange => sum ← sum + y.bottom*3 + y.top*17;
ENDCASE => ERROR;
};
ENDCASE => ERROR;
RETURN[sum]};
NDFormat:
PUBLIC
PROC [nd: NumericDescriptor]
RETURNS [Rope.
ROPE] ~ {
WITH x: nd
SELECT
FROM
real => RETURN IO.PutFR["[%g, real[]]", [integer[x.nBits]] ];
signed =>
WITH y: x
SELECT
FROM
full => RETURN IO.PutFR["[%g, signed[full[]]]", [integer[x.nBits]] ];
subRange => RETURN IO.PutFR["[%g, signed[subrange[%g, %g]]]", [integer[x.nBits]], [integer[y.bottom]], [integer[y.top]] ];
ENDCASE => ERROR;
unsigned =>
WITH y: x
SELECT
FROM
full => RETURN IO.PutFR["[%g, unsigned[full[]]]", [integer[x.nBits]] ];
subRange => RETURN IO.PutFR["[%g, unsigned[subrange[%g, %g]]]", [integer[x.nBits]], [cardinal[y.bottom]], [cardinal[y.top]] ];
ENDCASE => ERROR;
ENDCASE => ERROR};
nodes
Node: TYPE = CirioTypes.Node;
CreateNumericNode:
PUBLIC
PROC[type: Type, rep:
REF
ANY]
RETURNS[Node] =
BEGIN
RETURN[CreateCedarNode[NumericalOps, type, rep]];
END;
NumericalOps:
REF CedarCode.OperationsBody ←
NEW[CedarCode.OperationsBody ←[
examineBoolean: NumericalExamineBoolean,
coerce: NumericalCoerce,
binaryOp: NumericalBinaryOp,
unaryOp: NumericalUnaryOp,
asIndex: NumericalAsIndex,
show: NumericalShow,
getNodeRepresentation: NumericalGetRepresentation
]];
NOTE: these implementations could use some vetting
NumericalExamineBoolean:
PROC[node: Node, cc:
CC]
RETURNS[
BOOLEAN] =
{CCE[cirioError]}; -- shouldn't happen
NumericalCoerce:
PROC[sourceType, targetType: Type, node: Node, cc:
CC]
RETURNS[Node] =
BEGIN
expectedSourceNT: NumericType
← NARROW[GetProcDataFromGroundType[sourceType, cc]];
expectedSourceDescriptor: REF NumericDescriptor ← expectedSourceNT.desc;
actualSourceNT: NumericType
← NARROW[GetProcDataFromGroundType[CedarCode.GetTypeOfNode[node], cc]];
actualSourceDescriptor: REF NumericDescriptor ← actualSourceNT.desc;
targetNT: NumericType
← NARROW[GetProcDataFromGroundType[targetType, cc]];
targetDescriptor: REF NumericDescriptor ← targetNT.desc;
CheckEqualDescriptors[expectedSourceDescriptor, actualSourceDescriptor];
WITH targetDescriptor
SELECT
FROM
td:
REF real NumericDescriptor =>
BEGIN
targetReal: REAL ← 0.0;
WITH CedarCode.GetDataFromNode[node]
SELECT
FROM
lit: REF REAL => targetReal ← lit^;
lit: REF INT => targetReal ← lit^;
lit:
REF
CARD =>
BEGIN -- must be a large CARD
reduced: CARD ← (lit^ - CARD[LAST[INT]])-CARD[1];
reducedReal: REAL ← reduced;
targetReal ← (reducedReal+REAL[LAST[INT]])+1.0;
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen;
RETURN[CreateNumericNode[targetType, NEW[REAL ← targetReal]]];
END;
td:
REF signed NumericDescriptor =>
BEGIN
targetINT: INT;
WITH CedarCode.GetDataFromNode[node]
SELECT
FROM
lit: REF REAL => CCE[cirioError]; -- shouldn't happen (we don't coerce from REAL to non REAL)
lit: REF INT => targetINT ← lit^;
lit:
REF
CARD =>
IF lit^ >
CARD[
LAST[
INT]]
THEN
CCE[operation, "bounds check"]
-- bounds check--
ELSE targetINT ← INT[lit^];
ENDCASE => CCE[cirioError]; -- shouldn't happen
WITH td
SELECT
FROM
f: REF full signed NumericDescriptor => NULL;
sr:
REF subRange signed NumericDescriptor =>
BEGIN
IF targetINT < sr.bottom THEN CCE[operation, "bounds check"]; -- bounds check
IF targetINT > sr.top THEN CCE[operation, "bounds check"]; -- bounds check
END;
ENDCASE;
RETURN[CreateNumericNode[targetType, NEW[INT ← targetINT]]];
END;
td:
REF unsigned NumericDescriptor =>
BEGIN
targetCARD: CARD;
WITH CedarCode.GetDataFromNode[node]
SELECT
FROM
lit: REF REAL => CCE[cirioError]; -- shouldn't happen (we don't coerce from REAL to non REAL)
lit:
REF
INT =>
BEGIN
IF lit^ < 0 THEN CCE[operation, "bounds check"]; -- bounds check
targetCARD ← CARD[lit^];
END;
lit: REF CARD => targetCARD ← lit^;
ENDCASE => CCE[cirioError]; -- shouldn't happen
WITH td
SELECT
FROM
f: REF full unsigned NumericDescriptor => NULL;
sr:
REF subRange unsigned NumericDescriptor =>
BEGIN
IF targetCARD < sr.bottom THEN CCE[operation, "bounds check"]; -- bounds check
IF targetCARD > sr.top THEN CCE[operation, "bounds check"]; -- bounds check
END;
ENDCASE;
RETURN[CreateNumericNode[targetType, NEW[CARD ← targetCARD]]];
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
NumericalBinaryOp:
PROC[op: CCTypes.Operator, leftType, rightType: Type, leftNode, rightNode: Node, cc:
CC]
RETURNS[Node] =
BEGIN
leftTNt: NumericType ← NARROW[GetProcDataFromGroundType[leftType, cc]];
leftNNt: NumericType ← NARROW[GetProcDataFromGroundType[CedarCode.GetTypeOfNode[leftNode], cc]];
rightTNt: NumericType ← NARROW[GetProcDataFromGroundType[rightType, cc]];
rightNNt: NumericType ← NARROW[GetProcDataFromGroundType[CedarCode.GetTypeOfNode[rightNode], cc]];
leftDescriptor: REF NumericDescriptor ← leftTNt.desc;
CheckEqualDescriptors[leftDescriptor, leftNNt.desc];
CheckEqualDescriptors[rightTNt.desc, rightNNt.desc];
CheckEqualDescriptors[leftDescriptor, rightNNt.desc];
it is my belief that these types will always be the same
WITH leftDescriptor
SELECT
FROM
ld:
REF real NumericDescriptor =>
BEGIN
lr: REF REAL ← NARROW[CedarCode.GetDataFromNode[leftNode]];
rr: REF REAL ← NARROW[CedarCode.GetDataFromNode[rightNode]];
SELECT op
FROM
$plus, $minus, $mult, $div, $mod, $max, $min =>
BEGIN
newREAL:
REAL ←
SELECT op
FROM
$plus => lr^+rr^,
$minus => lr^-rr^,
$mult => lr^*rr^,
$div => lr^/rr^,
mod => lr^ MOD rr^, - - what happens here?
$max => MAX[lr^, rr^],
$min => MIN[lr^, rr^],
ENDCASE => CCE[cirioError];
RETURN[CreateNumericNode[leftType, NEW[REAL ← newREAL]]];
END;
$le, $lt, $eq, $ne, $gt, $ge =>
BEGIN
newBoolean:
BOOLEAN ←
SELECT op
FROM
$le => lr^ <= rr^,
$lt => lr^ < rr^,
$eq => lr^ = rr^,
$ne => lr^ # rr^,
$gt => lr^ > rr^,
$ge => lr^ >= rr^,
ENDCASE => CCE[cirioError];
RETURN[CedarOtherPureTypes.CreateBooleanNode[newBoolean, cc]];
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
ld:
REF full signed NumericDescriptor =>
BEGIN
li: REF INT ← NARROW[CedarCode.GetDataFromNode[leftNode]];
ri: REF INT ← NARROW[CedarCode.GetDataFromNode[rightNode]];
SELECT op
FROM
$plus, $minus, $mult, $div, $mod, $max, $min =>
BEGIN
newINT:
INT ←
SELECT op
FROM
$plus => li^+ri^,
$minus => li^-ri^,
$mult => li^*ri^,
$div => li^/ri^,
$mod => li^ MOD ri^,
$max => MAX[li^, ri^],
$min => MIN[li^, ri^],
ENDCASE => CCE[cirioError];
RETURN[CreateNumericNode[leftType, NEW[INT ← newINT]]];
END;
$le, $lt, $eq, $ne, $gt, $ge =>
BEGIN
newBoolean:
BOOLEAN ←
SELECT op
FROM
$le => li^ <= ri^,
$lt => li^ < ri^,
$eq => li^ = ri^,
$ne => li^ # ri^,
$gt => li^ > ri^,
$ge => li^ >= ri^,
ENDCASE => CCE[cirioError];
RETURN[CedarOtherPureTypes.CreateBooleanNode[newBoolean, cc]];
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
ld: REF subRange signed NumericDescriptor => CCE[cirioError]; -- shouldn't happen
ld:
REF full unsigned NumericDescriptor =>
BEGIN
lc: REF CARD ← NARROW[CedarCode.GetDataFromNode[leftNode]];
rc: REF CARD ← NARROW[CedarCode.GetDataFromNode[rightNode]];
SELECT op
FROM
$plus, $minus, $mult, $div, $mod, $max, $min =>
BEGIN
newCARD:
CARD ←
SELECT op
FROM
$plus => lc^+rc^,
$minus => lc^-rc^,
$mult => lc^*rc^,
$div => lc^/rc^,
$mod => lc^ MOD rc^,
$max => MAX[lc^, rc^],
$min => MIN[lc^, rc^],
ENDCASE => CCE[cirioError];
RETURN[CreateNumericNode[leftType, NEW[CARD ← newCARD]]];
END;
$le, $lt, $eq, $ne, $gt, $ge =>
BEGIN
newBoolean:
BOOLEAN ←
SELECT op
FROM
$le => lc^ <= rc^,
$lt => lc^ < rc^,
$eq => lc^ = rc^,
$ne => lc^ # rc^,
$gt => lc^ > rc^,
$ge => lc^ >= rc^,
ENDCASE => CCE[cirioError];
RETURN[CedarOtherPureTypes.CreateBooleanNode[newBoolean, cc]];
END;
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
ld: REF subRange unsigned NumericDescriptor => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
NumericalUnaryOp:
PROC[op: CCTypes.Operator, type: Type, node: Node, cc:
CC]
RETURNS[Node] =
BEGIN
nt: NumericType ← NARROW[GetProcDataFromGroundType[type, cc]];
descriptor: REF NumericDescriptor ← nt.desc;
WITH descriptor
SELECT
FROM
d:
REF real NumericDescriptor =>
BEGIN
r: REF REAL ← NARROW[CedarCode.GetDataFromNode[node]];
newREAL:
REAL ←
SELECT op
FROM
$plus =>r^,
$minus => -r^,
ENDCASE => CCE[cirioError]; -- shouldn't happen
RETURN[CreateNumericNode[type, NEW[REAL ← newREAL]]];
END;
d:
REF full signed NumericDescriptor =>
BEGIN
i: REF INT ← NARROW[CedarCode.GetDataFromNode[node]];
newINT:
INT ←
SELECT op
FROM
$plus => i^,
$minus => -i^,
ENDCASE => CCE[cirioError]; -- shouldn't happen
RETURN[CreateNumericNode[type, NEW[INT ← newINT]]];
END;
d: REF subRange signed NumericDescriptor => CCE[cirioError]; -- shouldn't happen
d:
REF full unsigned NumericDescriptor =>
BEGIN
c: REF CARD ← NARROW[CedarCode.GetDataFromNode[node]];
newCARD:
CARD ←
SELECT op
FROM
$plus => c^,
$minus => -c^,
ENDCASE => CCE[cirioError];
RETURN[CreateNumericNode[type, NEW[CARD ← newCARD]]];
END;
d: REF subRange unsigned NumericDescriptor => CCE[cirioError]; -- shouldn't happen
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
NumericalAsIndex:
PROC[type: Type, node: Node, cc:
CC]
RETURNS[
CARD] =
BEGIN
nt: NumericType ← NARROW[GetProcDataFromGroundType[CedarCode.GetTypeOfNode[node], cc]];
descriptor: REF NumericDescriptor ← nt.desc;
WITH descriptor
SELECT
FROM
d:
REF full signed NumericDescriptor =>
BEGIN
val: REF INT32 ← NARROW[CedarCode.GetDataFromNode[node]];
RETURN[val^];
END;
d:
REF subRange signed NumericDescriptor =>
BEGIN
val: REF INT32 ← NARROW[CedarCode.GetDataFromNode[node]];
index: INT32 ← val^ - d.bottom;
RETURN[index];
END;
d:
REF full unsigned NumericDescriptor =>
BEGIN
val: REF CARD32 ← NARROW[CedarCode.GetDataFromNode[node]];
RETURN[val^];
END;
d:
REF subRange unsigned NumericDescriptor =>
BEGIN
val: REF CARD32 ← NARROW[CedarCode.GetDataFromNode[node]];
index: CARD32 ← val^ - d.bottom;
RETURN[index];
END;
ENDCASE => CCE[cirioError];
END;
NumericalShow:
PROC[to:
IO.
STREAM, node: Node, depth:
INT, width:
INT, cc:
CC] =
BEGIN
nt: NumericType ← NARROW[GetProcDataFromGroundType[CedarCode.GetTypeOfNode[node], cc]];
descriptor: REF NumericDescriptor ← nt.desc;
WITH descriptor
SELECT
FROM
d:
REF real NumericDescriptor =>
to.PutRope[Convert.RopeFromReal[NARROW[CedarCode.GetDataFromNode[node], REF REAL]^]];
d:
REF full signed NumericDescriptor =>
to.PutRope[Convert.RopeFromInt[NARROW[CedarCode.GetDataFromNode[node], REF INT]^]];
d:
REF subRange signed NumericDescriptor =>
to.PutRope[Convert.RopeFromInt[NARROW[CedarCode.GetDataFromNode[node], REF INT]^]];
d:
REF full unsigned NumericDescriptor =>
to.PutRope[Convert.RopeFromCard[NARROW[CedarCode.GetDataFromNode[node], REF CARD]^]];
d:
REF subRange unsigned NumericDescriptor =>
to.PutRope[Convert.RopeFromCard[NARROW[CedarCode.GetDataFromNode[node], REF CARD]^]];
ENDCASE => CCE[cirioError]; -- shouldn't happen
END;
NumericalGetRepresentation:
PROC[node: Node, cc:
CC]
RETURNS[
REF
ANY] =
{RETURN[CedarCode.GetDataFromNode[node]]};
CheckEqualDescriptors:
PROC[left, right:
REF NumericDescriptor] =
{IF NOT NDEqual[left^, right^] THEN CCE[cirioError]};
END..