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