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"];
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];
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];
ENDCASE => ERROR;
END;

ShowValue: PUBLIC PROC [on: IO.STREAM, nest: INT, value: ValueNode] = BEGIN
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"];
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;

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;

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]]];
END;




END.



μ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

actually, this should insert code & succeed.
actually, this should insert code & succeed.
actually, this should insert code & succeed.
Show just the value, not the type.
v: REF runtime ValueNodeBody 	=> SaffronContext.ShowProgramGraph[on, nest, v.code];
Element
Transfer
show an address & lc, maybe?
ΚΘ˜™Jš
œ<™<Jšœ&Οk™)Icode™:J™—š
	˜	Jšœœ2˜CJšœ
œœ˜*Jšœœœ˜Jšœœ,˜@Jšœœ˜Jš
œ˜Jšœœ˜2Jšœ
œ˜(Jšœ œ˜?J˜—šΟnœœ
˜Jšœœ4˜KJšœ˜&Jšœ˜J˜šœ
˜Jšœ˜Jšœ˜Jšœ˜Jšœ˜—J˜Jšœœœ˜4Jšœœ
œœ˜>J˜Kšœœœ˜<Kšœœ
œœ˜FJ˜Jšœœœ˜$Jšœœ
œœ˜.J˜Jšœœœ˜6Jšœœ
œ:˜]J˜Jšœœ˜"J˜š	žœœ
œœ˜IJš	œœœ
œœ˜MJšœ
œ
œœ˜CJšœ
˜J˜—šžœœ
œœœ˜<Jšœ
œœ˜,Jšœ
˜J˜—šžœœ
œœœ˜=Jšœ
œœ˜+Jšœ
˜J˜—š	ž
œœ
œ,œ˜^šœœ
˜šœœ˜JšœK˜P—šœœ˜!JšœN˜S—šœœ˜!Jšœœ˜ —šœœ˜JšœK˜P—šœœ˜ JšœM˜RJ™,—Jšœœ
˜—Jšœ
˜J˜—š	ž	œœ
œœ˜KJšœœœ$œ˜VJšœ	œ˜"Jšœ˜Jšœ
˜J˜—š	žœœ
œ
œ˜;Jšœœ!˜,Jšœ
˜J˜—šžœœ
œœ.œ˜pJšœœ(˜3Jšœ
˜J˜—š	žœœ
œœ˜Dšœœ
˜šœœ˜JšœI˜N—šœœ˜!JšœL˜Q—šœœ˜ Jšœ˜—šœœ˜Jšœ˜—šœœ˜ Jšœ˜J™,—Jšœœ
˜—Jšœ
˜J˜—šžœœ
œœœ˜Išœœ
˜šœœ˜JšœJ˜O—šœœ˜!JšœM˜R—šœœ˜ Jšœ˜—šœœ˜Jšœ˜—šœœ˜ Jšœ˜J™,—Jšœœ
˜—Jšœ
˜J˜—šž	œœœ
œœ˜KK™"šœœ
˜Kšœœ/œ˜FKšœœ6˜<Kšœœ3˜9Kšœœ7˜=Kšœœ*˜0KšœœM™SKšœœ
˜—Kšœ
˜K˜—š
žœœœ
œœœ˜Ušœœ
˜Jšœœ,˜1Jšœœ.˜3Jšœ"˜)—Jšœ
˜J˜—
headš
Οz™š
žœœœ
œœœ˜TJšœœœ	˜$šœœ
˜šœœœ˜)Jšœœœœ
˜,—šœœœ˜+JšœΟc˜1—šœœœ˜,J˜—šœœœ˜)J˜)—šœœ
œ˜%J˜—Jšœ
˜—Jšœ
˜J˜—š	žœœ
œœ˜<šœœ
˜šœœ˜!Jšœœœ
˜%Jšœ˜J˜—šœœ˜"Jšœ˜J˜—Jšœœ
œ(˜;—šœ
˜J˜—J˜—š	žœœ
œœ˜<šœœ
˜šœœ˜!Jšœœœ
˜%Jšœ˜J˜—šœœ˜"Jšœ˜J˜—Jšœœ
œ(˜;—šœ
˜J˜——š	žœœ
œ/œ˜gJšœœœ
˜'šœœ
œ+˜@š	œœœœ
˜.šœ
œ+˜0šœ˜š
œ-˜-Jšœœ
˜
Jš
œ˜Jšœœ
œ)˜5J˜—Jšœœ˜,J˜——Jšœ
˜——š
˜JšœœFœ(˜—
š
œ-˜-Jšœœ
˜
Jš
œ˜Jšœœ
œ?˜KJ˜—J˜—Jš
œ6˜6Jšœ
˜Jšœ
˜J˜—š
žœœ
œ
œ	œœ˜WJšœ(˜.Jšœ
˜J˜—šžœœ
œ	œœ˜dšœœ<˜GJšœœ
˜
Jš
œ˜Jšœœ
œ)˜5J˜—Jš
œ6˜6Jšœ
˜Jšœ
˜J˜—šžœœ
œœœ˜BJš	œœœ
œœ˜MJšœ
œ
œœ˜CJšœ
˜J˜—šžœœ
œ		œœ˜hJšœœ<˜Gšœœ
˜
Jš
œ˜Jšœœ
œ+˜7J˜—Jš
œ6˜6Jšœ
˜Jšœ
˜J˜—šžœœ
œœ	œ˜FJš	œœœ
œœ˜MJšœ
œ
œœ˜EJšœ
˜—J˜—š
Ÿ™š	žœœ
œ5œ˜nJšœœ<˜Gšœœ
˜
Jš
œ˜Jšœœ
œ˜&J˜—Jš
œ6˜6Jšœ
˜Jšœ
˜J˜—š
žœœœ
œœœ˜UJšœœœ	˜%š
œœ
œœ
œ˜DJ˜J˜J˜J˜J˜J˜Jšœ˜J˜—Jšœœœ˜;J™Jšœ
˜J˜—J˜J˜J˜—šœ
˜˜J˜————…—!V/