SaffronValueImpl.Mesa
Copyright Ó 1988 by Xerox Corporation. All rights reserved.
James Rauen, July 28, 1988 1:36:41 pm PDT
Last edited by: James Rauen August 23, 1988 5:36:09 pm PDT
DIRECTORY
BigIntegers USING [BigINT, BigFromRope, BigFromSmall, RopeFromBig],
IO USING [int, PutF, PutFR, rope, STREAM],
Rope USING [ROPE],
SaffronBaseDef USING [CanCastIntegerValue, ProgramFragmentNode],
SaffronContext USING [],
SaffronContextPrivateTypes,
SaffronErrorHandling USING [Error, InternalError],
SaffronPGDef USING [MakePGPushConstant],
SaffronProgramGraphPrivateTypes USING [ProcedureGraphNodeBody];
SaffronValueImpl: CEDAR PROGRAM
IMPORTS BigIntegers, IO, SaffronBaseDef, SaffronErrorHandling, SaffronPGDef
EXPORTS SaffronBaseDef, SaffronContext
= BEGIN
OPEN
BD: SaffronBaseDef,
EH: SaffronErrorHandling,
PG: SaffronPGDef,
PT: SaffronContextPrivateTypes;
TypeGraphNodeNode: TYPE = REF TypeGraphNodeNodeBody;
TypeGraphNodeNodeBody: PUBLIC TYPE = PT.TypeGraphNodeNodeBody;
TypeGraphNodeListNode: TYPE = REF TypeGraphNodeListNodeBody;
TypeGraphNodeListNodeBody: PUBLIC TYPE = PT.TypeGraphNodeListNodeBody;
ValueNode: TYPE = REF ValueNodeBody;
ValueNodeBody: PUBLIC TYPE = PT.ValueNodeBody;
ProcedureGraphNode: TYPE = REF ProcedureGraphNodeBody;
ProcedureGraphNodeBody: PUBLIC TYPE = SaffronProgramGraphPrivateTypes.ProcedureGraphNodeBody;
BigINT: TYPE = BigIntegers.BigINT;
RetrieveIntegerValue: PUBLIC PROC [v: ValueNode] RETURNS [BigINT] = BEGIN
elementVal: PT.ElementVal ← NARROW[NARROW[v, REF static ValueNodeBody].body];
RETURN[NARROW[elementVal, REF integer base PT.ElementValBody].val];
END;
Static: PUBLIC PROC [v: ValueNode] RETURNS [BOOLEAN] = BEGIN
RETURN[ISTYPE[v, REF static ValueNodeBody]];
END;
IsTrash: PUBLIC PROC [v: ValueNode] RETURNS [BOOLEAN] = BEGIN
RETURN[ISTYPE[v, REF trash ValueNodeBody]];
END;
ChangeType: PUBLIC PROC [v: ValueNode, newType: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
WITH v SELECT FROM
vv: REF dummy ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to change type of dummy value"];
vv: REF unparsed ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to change type of unparsed value"];
vv: REF static ValueNodeBody => {
vv.type ← newType; RETURN[vv] };
vv: REF trash ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to change type of trash value"];
vv: REF runtime ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to change type of runtime value"];
actually, this should insert code & succeed.
ENDCASE => ERROR;
END;
MakeTrash: PUBLIC PROC [tgn: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
v: REF trash ValueNodeBody ← NEW[trash ValueNodeBody ← [trash[code: NIL, type: tgn]]];
v.code ← PG.MakePGPushConstant[v];
RETURN [v];
END;
MakeDefaultMeValue: PUBLIC PROC RETURNS [ValueNode] = BEGIN
RETURN [NEW[ValueNodeBody ← [defaultMe[]]]];
END;
MakeRuntimeValue: PUBLIC PROC [code: BD.ProgramFragmentNode, tgn: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
RETURN [NEW[ValueNodeBody ← [runtime[code, tgn]]]];
END;
Type: PUBLIC PROC [v: ValueNode] RETURNS [TypeGraphNodeNode] = BEGIN
WITH v SELECT FROM
vv: REF dummy ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to find type of dummy value"];
vv: REF unparsed ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to find type of unparsed value"];
vv: REF static ValueNodeBody =>
RETURN [vv.type];
vv: REF trash ValueNodeBody =>
RETURN [vv.type];
vv: REF runtime ValueNodeBody =>
RETURN [vv.type];
actually, this should insert code & succeed.
ENDCASE => ERROR;
END;
Code: PUBLIC PROC [v: ValueNode] RETURNS [BD.ProgramFragmentNode] = BEGIN
WITH v SELECT FROM
vv: REF dummy ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to find code for dummy value"];
vv: REF unparsed ValueNodeBody =>
ERROR SaffronErrorHandling.InternalError["Tried to find code for unparsed value"];
vv: REF static ValueNodeBody =>
RETURN [vv.code];
vv: REF trash ValueNodeBody =>
RETURN [vv.code];
vv: REF runtime ValueNodeBody =>
RETURN [vv.code];
actually, this should insert code & succeed.
ENDCASE => ERROR;
END;
ShowValue: PUBLIC PROC [on: IO.STREAM, nest: INT, value: ValueNode] = BEGIN
Show just the value, not the type.
WITH value SELECT FROM
v: REF dummy ValueNodeBody  => on.PutF["Dummy (%g)", IO.rope[v.info]];
v: REF unparsed ValueNodeBody  => on.PutF["Unparsed value"];
v: REF defaultMe ValueNodeBody  => on.PutF["DEFAULT ME"];
v: REF static ValueNodeBody  => ShowStaticValue[on, nest, v];
v: REF trash ValueNodeBody  => on.PutF["TRASH"];
v: REF runtime ValueNodeBody  => SaffronContext.ShowProgramGraph[on, nest, v.code];
ENDCASE    => ERROR;
END;
ShowStaticValue: PROC [on: IO.STREAM, nest: INT, v: REF static ValueNodeBody] = BEGIN
WITH v.body SELECT FROM
u: PT.ElementVal  => ShowElementVal[on, nest, v];
u: PT.TransferVal  => ShowTransferVal[on, nest, v];
ENDCASE     => on.PutF["(Static value)"];
END;
Element
ShowElementVal: PROC [on: IO.STREAM, nest: INT, v: REF static ValueNodeBody] = BEGIN
val: PT.ElementVal ← NARROW[v.body];
WITH val SELECT FROM
vv: REF boolean base PT.ElementValBody =>
on.PutF[IF vv.val THEN "TRUE" ELSE "FALSE"];
vv: REF character base PT.ElementValBody =>
on.PutF["(character)"]; -- this could be nicer...
vv: REF enumerated base PT.ElementValBody =>
on.PutF["(enumerated value)"];
vv: REF integer base PT.ElementValBody =>
on.PutF[BigIntegers.RopeFromBig[vv.val]];
vv: REF subrange PT.ElementValBody =>
on.PutF["(subrange value)"];
ENDCASE;
END;
Succ: PUBLIC PROC [v: ValueNode] RETURNS [ValueNode] = BEGIN
WITH v SELECT FROM
vv: REF static ValueNodeBody => {
val: PT.ElementVal ← NARROW[vv.body];
RETURN [v];
};
vv: REF runtime ValueNodeBody => {
RETURN [v];
};
ENDCASE => ERROR EH.InternalError["Succ of something bad"];
END;
Pred: PUBLIC PROC [v: ValueNode] RETURNS [ValueNode] = BEGIN
WITH v SELECT FROM
vv: REF static ValueNodeBody => {
val: PT.ElementVal ← NARROW[vv.body];
RETURN [v];
};
vv: REF runtime ValueNodeBody => {
RETURN [v];
};
ENDCASE => ERROR EH.InternalError["Pred of something bad"];
END;
CastIntegerValue: PUBLIC PROC [value: BigINT, types: TypeGraphNodeListNode] RETURNS [ValueNode] ~ BEGIN
result: REF static ValueNodeBody ← NIL;
FOR typeList: LIST OF TypeGraphNodeNode ← types^, typeList.rest
WHILE ((typeList # NIL) AND (result = NIL)) DO
IF BD.CanCastIntegerValue[value, typeList.first]
THEN {
result ← NEW [static ValueNodeBody ← [static[
code: NIL,
type: typeList.first,
body: NEW[PT.ElementValBody ← [base[integer[value]]]]
]]];
result.code ← PG.MakePGPushConstant[result];
};
ENDLOOP;
IF result = NIL THEN {
SIGNAL SaffronErrorHandling.Error[0, IO.PutFR["Integer value %g exceeds the capacity of all integer types.", IO.rope[BigIntegers.RopeFromBig[value]]]];
result ← NEW [static ValueNodeBody ← [static[
code: NIL,
type: types^.first,
body: NEW[PT.ElementValBody ← [base[integer[BigIntegers.BigFromSmall[0]]]]]
]]];
};
result.code ← SaffronPGDef.MakePGPushConstant[result];
RETURN [result];
END;
ParseIntegerLiteral: PUBLIC PROC [text: Rope.ROPE, radix: INT] RETURNS [BigINT] = BEGIN
RETURN [BigIntegers.BigFromRope[text, radix]];
END;
MakeStaticBoolean: PUBLIC PROC [value: BOOLEAN, type: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
result: REF static ValueNodeBody ← NEW [static ValueNodeBody ← [static[
code: NIL,
type: type,
body: NEW[PT.ElementValBody ← [base[boolean[value]]]]
]]];
result.code ← SaffronPGDef.MakePGPushConstant[result];
RETURN [result];
END;
BooleanValue: PUBLIC PROC [v: ValueNode] RETURNS [BOOLEAN] = BEGIN
elementVal: PT.ElementVal ← NARROW[NARROW[v, REF static ValueNodeBody].body];
RETURN[NARROW[elementVal, REF boolean base PT.ElementValBody].val];
END;
MakeStaticCharacter: PUBLIC PROC [value: CHARACTER, type: TypeGraphNodeNode] RETURNS [ValueNode] = BEGIN
result: REF static ValueNodeBody ← NEW [static ValueNodeBody ← [static[
code: NIL,
type: type,
body: NEW[PT.ElementValBody ← [base[character[value]]]]
]]];
result.code ← SaffronPGDef.MakePGPushConstant[result];
RETURN [result];
END;
CharacterValue: PUBLIC PROC [v: ValueNode] RETURNS [CHARACTER] = BEGIN
elementVal: PT.ElementVal ← NARROW[NARROW[v, REF static ValueNodeBody].body];
RETURN[NARROW[elementVal, REF character base PT.ElementValBody].val];
END;
Transfer
MakeTransferValue: PUBLIC PROC [type: TypeGraphNodeNode, code: ProcedureGraphNode] RETURNS [ValueNode] = BEGIN
result: REF static ValueNodeBody ← NEW [static ValueNodeBody ← [static[
code: NIL,
type: type,
body: NEW[PT.TransferValBody ← [code]]
]]];
result.code ← SaffronPGDef.MakePGPushConstant[result];
RETURN [result];
END;
ShowTransferVal: PROC [on: IO.STREAM, nest: INT, v: REF static ValueNodeBody] = BEGIN
val: PT.TransferVal ← NARROW[v.body];
on.PutF[SELECT NARROW[v.type.body, REF PT.TransferTGNBody].mode FROM
proc  => "PROCEDURE",
port  => "PORT",
signal  => "SIGNAL",
error  => "ERROR",
process => "PROCESS",
program => "PROGRAM"
ENDCASE => ERROR
];
on.PutF[" descriptor %g", IO.int[LOOPHOLE[val.code.code]]];
show an address & lc, maybe?
END;
END.