|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 27648 (0x6c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Dyn_Nod_Save, seg_047501
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Text_Io, Table_Of_Player_Commands, Error;
package body Dyn_Nod_Save is
use Dynamic_Value;
type Arguments is array (Positions range <>) of Object;
type Words is array (Positions) of Object;
type Node (What : Kinds := Unknown) is
record
case What is
when Value =>
Value_Content : Dynamic_Value.Object;
when Binary_Operator =>
Binary_Op : Binary_Operators;
Binary_Arg : Arguments (Left .. Right);
Binary_Result : Dynamic_Value.Object;
when Unary_Operator =>
Unary_Op : Unary_Operators;
Unary_Arg : Object;
Unary_Result : Dynamic_Value.Object;
when Ternary_Operator =>
Ternary_Op : Ternary_Operators;
Ternary_Arg : Arguments (Verb_Position .. Cplt1_Position);
Ternary_Result : Dynamic_Value.Object;
when others =>
null;
end case;
end record;
procedure Create_Value (Obj : in out Object) is
D_V : Dynamic_Value.Object;
begin
if (Obj = null) then
Obj := new Node'(What => Value, Value_Content => D_V);
else
raise Object_Already_Exists;
end if;
end Create_Value;
procedure Set_Value (Obj : in out Object; Val : in Dynamic_Value.Object) is
begin
if (Dynamic_Value.Get_Kind (Val) = Dynamic_Value.Unknown) then
raise Value_Does_Not_Exist_Or_Is_Not_Evaluated;
else
Obj.all.Value_Content := Val;
end if;
end Set_Value;
procedure Create_Unary_Operator
(Obj : in out Object; Op : Unary_Operators) is
D_V : Dynamic_Value.Object;
begin
if (Obj = null) then
Obj := new Node'(What => Unary_Operator,
Unary_Op => Op,
Unary_Arg => null,
Unary_Result => D_V);
else
raise Object_Already_Exists;
end if;
end Create_Unary_Operator;
procedure Create_Binary_Operator
(Obj : in out Object; Op : Binary_Operators) is
D_V : Dynamic_Value.Object;
begin
if (Obj = null) then
Obj := new Node'(What => Binary_Operator,
Binary_Op => Op,
Binary_Arg => (null, null),
Binary_Result => D_V);
else
raise Object_Already_Exists;
end if;
end Create_Binary_Operator;
procedure Create_Ternary_Operator
(Obj : in out Object; Op : Ternary_Operators) is
D_V : Dynamic_Value.Object;
begin
if (Obj = null) then
Obj := new Node'(What => Ternary_Operator,
Ternary_Op => Op,
Ternary_Arg => (null, null, null),
Ternary_Result => D_V);
else
raise Object_Already_Exists;
end if;
end Create_Ternary_Operator;
function Get_Kind (Obj : in Object) return Kinds is
begin
return Obj.all.What;
end Get_Kind;
function Get_Operator (Obj : in Object) return String is
begin
case Get_Kind (Obj) is
when Unary_Operator =>
return Unary_Operators'Image (Obj.all.Unary_Op);
when Binary_Operator =>
return Binary_Operators'Image (Obj.all.Binary_Op);
when Ternary_Operator =>
return Ternary_Operators'Image (Obj.all.Ternary_Op);
when others =>
raise Type_Clash;
end case;
end Get_Operator;
function Get_Type_Of_Object (Obj : in Object) return Authorized_Type is
begin
if (Obj = null) then
return Type_Unknown;
else
case (Get_Kind (Obj)) is
when Unknown =>
return Type_Unknown;
when Value =>
case Dynamic_Value.Get_Kind (Obj.all.Value_Content) is
-- faire un tab de correspondance
when Dynamic_Value.Integer_Number =>
return Type_Int;
when Dynamic_Value.Unknown =>
return Type_Unknown;
when Dynamic_Value.String_Of_Characters =>
return Type_String;
when Dynamic_Value.Vocabulary_Word =>
return Type_Voca;
when Dynamic_Value.Boolean_Number =>
return Type_Bool;
when Dynamic_Value.Set_Of_Words =>
return Type_Set_Words;
end case;
when Unary_Operator =>
--return (Tab_Of_Authorized_Type (Obj.all.Unary_Op)); pour plus tard
case Obj.all.Unary_Op is
when Plus | Minus =>
return Type_Int;
when Logical_Not =>
return Type_Bool;
when Complement =>
return Type_Voca;
when Verb =>
return Type_Voca_Or_Bool;
end case;
when Binary_Operator =>
case (Obj.all.Binary_Op) is
when Add | Subtract | Divide | Multiply =>
return Type_Int;
when Equal .. Logical_Or =>
return Type_Bool;
end case;
when Ternary_Operator =>
case Obj.all.Ternary_Op is
when Sentence =>
return Type_Bool;
end case;
end case;
end if;
end Get_Type_Of_Object;
function Is_Authorized_Type_For_Obj
(Arg : in Object; Obj : in Object) return Boolean is
begin
if (Obj = null) then
return False;
else
case (Get_Kind (Obj)) is
when Unknown | Value =>
return False;
when Unary_Operator =>
case (Obj.all.Unary_Op) is
when Plus | Minus =>
return (Get_Type_Of_Object (Arg) = Type_Int);
when Logical_Not =>
return (Get_Type_Of_Object (Arg) in
Type_Bool .. Type_Voca_Or_Bool);
when Complement | Verb =>
return ((Get_Type_Of_Object (Arg) = Type_Voca) or
(Get_Type_Of_Object (Arg) =
Type_Voca_Or_Bool));
end case;
when Binary_Operator =>
case (Obj.all.Binary_Op) is
when Add | Subtract | Divide | Multiply =>
return (Get_Type_Of_Object (Arg) = Type_Int);
when Equal | Different =>
return (Get_Type_Of_Object (Arg) in
Type_Int .. Type_Voca_Or_Bool);
when Less | Less_Equal | More | More_Equal =>
return (Get_Type_Of_Object (Arg) = Type_Int);
when Logical_Or | Logical_And =>
return (Get_Type_Of_Object (Arg) in
Type_Bool .. Type_Voca_Or_Bool);
end case;
when Ternary_Operator =>
return ((Get_Type_Of_Object (Arg) = Type_Voca) or
(Get_Type_Of_Object (Arg) = Type_Voca_Or_Bool));
end case;
end if;
end Is_Authorized_Type_For_Obj;
procedure Set_Argument (Obj : in out Object;
Arg : in Object;
Where : Positions := Center) is
Position_To_Test : Positions;
begin
case Get_Kind (Obj) is
when Value =>
Error.Set_Type_Error (Error.No_Argument_On_Value);
raise Error.Excep_Semantic_Error;
when Unary_Operator =>
if not (Is_Authorized_Type_For_Obj (Arg, Obj)) then
Error.Set_Type_Error
(Error.Unauthorized_Type_With_Previous_Unary_Operator);
raise Error.Excep_Semantic_Error;
end if;
Obj.all.Unary_Arg := Arg;
when Binary_Operator =>
if Where = Left then
Position_To_Test := Right;
else
Position_To_Test := Left;
end if;
if Get_Type_Of_Object (Obj.all.Binary_Arg (Position_To_Test)) =
Type_Unknown then
-- aucun argument de position oppose n'est accroche au noeud
if not (Is_Authorized_Type_For_Obj (Arg, Obj)) then
-- si l'argument n'a pas un type autorise pour l'operateur
Error.Set_Type_Error
(Error.
Unauthorized_Type_With_Previous_Binary_Operator);
raise Error.Excep_Semantic_Error;
end if;
elsif (Get_Type_Of_Object
(Obj.all.Binary_Arg (Position_To_Test)) /=
Get_Type_Of_Object (Arg)) then
-- si le deuxieme argument a accroche n'est pas du meme type que
--celui deja en place
Error.Set_Type_Error
(Error.
Unauthorized_Type_With_Previous_Argument_Of_Binary_Operator);
raise Error.Excep_Semantic_Error;
end if;
Obj.all.Binary_Arg (Where) := Arg;
when Ternary_Operator =>
if not (Is_Authorized_Type_For_Obj (Arg, Obj)) then
-- si l'argument n'a pas un type autorise pour l'operateur
Error.Set_Type_Error
(Error.Unauthorized_Type_With_Previous_Ternary_Operator);
raise Error.Excep_Semantic_Error;
end if;
Obj.all.Ternary_Arg (Where) := Arg;
when Unknown =>
raise Object_Is_Not_Created;
end case;
end Set_Argument;
function Get_Argument
(Obj : in Object; Where : Positions := Center) return Object is
begin
case Get_Kind (Obj) is
when Value =>
Error.Set_Type_Error (Error.No_Argument_On_Value);
raise Error.Excep_Semantic_Error;
when Unary_Operator =>
return Obj.all.Unary_Arg;
when Binary_Operator =>
return Obj.all.Binary_Arg (Where);
when Ternary_Operator =>
return Obj.all.Ternary_Arg (Where);
when Unknown =>
raise Object_Is_Not_Created;
end case;
end Get_Argument;
function Get_Value (Obj : in Object) return Dynamic_Value.Object is
begin
case Obj.all.What is
when Value =>
if (Dynamic_Value.Get_Kind (Obj.all.Value_Content) =
Dynamic_Value.Unknown) then
raise Value_Does_Not_Exist_Or_Is_Not_Evaluated;
else
return Obj.all.Value_Content;
end if;
when Unary_Operator =>
if (Dynamic_Value.Get_Kind (Obj.all.Unary_Result) =
Dynamic_Value.Unknown) then
raise Value_Does_Not_Exist_Or_Is_Not_Evaluated;
else
return Obj.all.Unary_Result;
end if;
when Binary_Operator =>
if (Dynamic_Value.Get_Kind (Obj.all.Binary_Result) =
Dynamic_Value.Unknown) then
raise Value_Does_Not_Exist_Or_Is_Not_Evaluated;
else
return Obj.all.Binary_Result;
end if;
when Ternary_Operator =>
if (Dynamic_Value.Get_Kind (Obj.all.Ternary_Result) =
Dynamic_Value.Unknown) then
raise Value_Does_Not_Exist_Or_Is_Not_Evaluated;
else
return Obj.all.Ternary_Result;
end if;
when others =>
raise Object_Is_Not_Created;
end case;
end Get_Value;
procedure Evaluate_Unary_Operator (Obj : in Object) is
begin
Evaluate (Get_Argument (Obj));
case Obj.all.Unary_Op is
when Plus =>
--voir si pas light
Dynamic_Value.Deep_Copy
(Get_Value (Get_Argument (Obj)), Obj.all.Unary_Result);
when Minus =>
Dynamic_Value.Change_Sign
(Get_Value (Get_Argument (Obj)), Obj.all.Unary_Result);
when Logical_Not =>
Dynamic_Value.Logical_Not
(Get_Value (Get_Argument (Obj)), Obj.all.Unary_Result);
when Verb | Complement =>
if Dynamic_Value.Get_Value (Get_Value (Get_Argument (Obj))) =
"complement1" then
Dynamic_Value.Deep_Copy
(Table_Of_Player_Commands.Get_Access_On_First_Complement,
Obj.all.Unary_Result);
elsif Dynamic_Value.Get_Value (Get_Value (Get_Argument (Obj))) =
"complement2" then
Dynamic_Value.Deep_Copy
(Table_Of_Player_Commands.
Get_Access_On_Second_Complement, Obj.all.Unary_Result);
else
--voir si pas light
Dynamic_Value.Deep_Copy
(Get_Value (Get_Argument (Obj)), Obj.all.Unary_Result);
end if;
end case;
end Evaluate_Unary_Operator;
procedure Evaluate_Binary_Operator (Obj : in Object) is
Tempo1, Tempo2 : Dynamic_Value.Object;
begin
Evaluate (Get_Argument (Obj, Left));
--voir si light copy
Dynamic_Value.Deep_Copy (Get_Value (Get_Argument (Obj, Left)), Tempo1);
Evaluate (Get_Argument (Obj, Right));
Dynamic_Value.Deep_Copy (Get_Value (Get_Argument (Obj, Right)), Tempo2);
case Obj.all.Binary_Op is
when Add =>
Dynamic_Value.Add (Left => Tempo1,
Right => Tempo2,
Result => Obj.all.Binary_Result);
when Subtract =>
Dynamic_Value.Substract (Tempo1, Tempo2, Obj.all.Binary_Result);
when Divide =>
Dynamic_Value.Divide (Tempo1, Tempo2, Obj.all.Binary_Result);
when Multiply =>
Dynamic_Value.Multiply (Tempo1, Tempo2, Obj.all.Binary_Result);
when Equal =>
Dynamic_Value.Are_Equal (Tempo1, Tempo2, Obj.all.Binary_Result);
when Less =>
Dynamic_Value.Is_Less (Tempo1, Tempo2, Obj.all.Binary_Result);
when Less_Equal =>
Dynamic_Value.Is_Less_Equal
(Tempo1, Tempo2, Obj.all.Binary_Result);
when More =>
Dynamic_Value.Is_More (Tempo1, Tempo2, Obj.all.Binary_Result);
when More_Equal =>
Dynamic_Value.Is_More_Equal
(Tempo1, Tempo2, Obj.all.Binary_Result);
when Different =>
Dynamic_Value.Is_Different
(Tempo1, Tempo2, Obj.all.Binary_Result);
when Logical_And =>
Dynamic_Value.Logical_And
(Tempo1, Tempo2, Obj.all.Binary_Result);
when Logical_Or =>
Dynamic_Value.Logical_Or
(Tempo1, Tempo2, Obj.all.Binary_Result);
end case;
end Evaluate_Binary_Operator;
procedure Evaluate_Ternary_Operator (Obj : in Object) is
Tempo_Verb, Tempo_Cplt1, Tempo_Cplt2 : Dynamic_Value.Object;
begin
Evaluate (Get_Argument (Obj, Verb_Position));
Dynamic_Value.Deep_Copy
(Get_Value (Get_Argument (Obj, Verb_Position)), Tempo_Verb);
Evaluate (Get_Argument (Obj, Cplt1_Position));
Dynamic_Value.Deep_Copy
(Get_Value (Get_Argument (Obj, Cplt1_Position)), Tempo_Cplt1);
Evaluate (Get_Argument (Obj, Cplt2_Position));
Dynamic_Value.Deep_Copy
(Get_Value (Get_Argument (Obj, Cplt2_Position)), Tempo_Cplt2);
case Obj.all.Ternary_Op is
when Sentence =>
Dynamic_Value.Are_Equal
(Tempo_Verb, Table_Of_Player_Commands.Get_Access_On_Verb,
Obj.all.Ternary_Result);
if Dynamic_Value.Get_Value (Obj.all.Ternary_Result) then
Dynamic_Value.Are_Equal (Tempo_Cplt1,
Table_Of_Player_Commands.
Get_Access_On_First_Complement,
Obj.all.Ternary_Result);
if Dynamic_Value.Get_Value (Obj.all.Ternary_Result) then
Dynamic_Value.Are_Equal
(Tempo_Cplt2, Table_Of_Player_Commands.
Get_Access_On_Second_Complement,
Obj.all.Ternary_Result);
end if;
end if;
end case;
end Evaluate_Ternary_Operator;
procedure Evaluate (Obj : in Object) is
begin
case Get_Kind (Obj) is
when Value =>
null;
when Unary_Operator =>
Evaluate_Unary_Operator (Obj);
when Binary_Operator =>
Evaluate_Binary_Operator (Obj);
when Ternary_Operator =>
Evaluate_Ternary_Operator (Obj);
when Unknown =>
raise Object_Is_Not_Created;
end case;
end Evaluate;
procedure Print (Obj : in Object) is
begin
case Get_Kind (Obj) is
when Value =>
Dynamic_Value.Print (Get_Value (Obj));
Text_Io.New_Line;
when Unary_Operator =>
Text_Io.Put_Line ("op = " &
Unary_Operators'Image (Obj.all.Unary_Op));
Dynamic_Value.Print (Obj.all.Unary_Result);
Text_Io.New_Line;
Text_Io.Put_Line ("Argument ");
Print (Get_Argument (Obj));
Text_Io.New_Line;
when Binary_Operator =>
Text_Io.Put_Line ("op = " &
Binary_Operators'Image (Obj.all.Binary_Op));
Dynamic_Value.Print (Obj.all.Binary_Result);
Text_Io.New_Line;
Text_Io.Put_Line ("Argument a gauche ");
Print (Get_Argument (Obj, Left));
Text_Io.Put_Line ("Argument a droite ");
Print (Get_Argument (Obj, Right));
Text_Io.New_Line;
when Ternary_Operator =>
Text_Io.Put_Line ("op = " &
Ternary_Operators'Image (Obj.all.Ternary_Op));
Dynamic_Value.Print (Obj.all.Ternary_Result);
Text_Io.New_Line;
Text_Io.Put_Line ("Argument a gauche ");
Print (Get_Argument (Obj, Left));
Text_Io.Put_Line ("Argument au centre ");
Print (Get_Argument (Obj, Center));
Text_Io.Put_Line ("Argument a droite ");
Print (Get_Argument (Obj, Right));
Text_Io.New_Line;
when Unknown =>
Text_Io.Put_Line (" Noeud non defini ! ");
end case;
end Print;
function Does_Exists (Obj : in Object) return Boolean is
begin
return Obj /= null;
end Does_Exists;
procedure Disconnect (Obj : in out Object) is
begin
Obj := null;
end Disconnect;
end Dyn_Nod_Save;
nblk1=1a
nid=1a
hdr6=2e
[0x00] rec0=17 rec1=00 rec2=01 rec3=050
[0x01] rec0=1f rec1=00 rec2=0f rec3=03c
[0x02] rec0=1c rec1=00 rec2=0a rec3=034
[0x03] rec0=1c rec1=00 rec2=12 rec3=07a
[0x04] rec0=1b rec1=00 rec2=02 rec3=038
[0x05] rec0=16 rec1=00 rec2=03 rec3=06e
[0x06] rec0=1d rec1=00 rec2=09 rec3=084
[0x07] rec0=12 rec1=00 rec2=07 rec3=038
[0x08] rec0=1a rec1=00 rec2=16 rec3=022
[0x09] rec0=02 rec1=00 rec2=0c rec3=06e
[0x0a] rec0=17 rec1=00 rec2=06 rec3=01c
[0x0b] rec0=13 rec1=00 rec2=13 rec3=036
[0x0c] rec0=20 rec1=00 rec2=04 rec3=01c
[0x0d] rec0=15 rec1=00 rec2=0d rec3=052
[0x0e] rec0=1a rec1=00 rec2=11 rec3=008
[0x0f] rec0=16 rec1=00 rec2=19 rec3=03a
[0x10] rec0=14 rec1=00 rec2=08 rec3=00a
[0x11] rec0=17 rec1=00 rec2=10 rec3=056
[0x12] rec0=14 rec1=00 rec2=14 rec3=054
[0x13] rec0=18 rec1=00 rec2=05 rec3=032
[0x14] rec0=1a rec1=00 rec2=0e rec3=006
[0x15] rec0=14 rec1=00 rec2=18 rec3=00a
[0x16] rec0=0e rec1=00 rec2=17 rec3=000
[0x17] rec0=13 rec1=00 rec2=0f rec3=000
[0x18] rec0=00 rec1=00 rec2=00 rec3=000
[0x19] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x2174ab3c4865392e4bf07 0x42a00088462060003
Free Block Chain:
0x1a: 0000 00 0b 00 13 00 10 20 20 20 20 20 20 20 20 20 20 ┆ ┆
0xb: 0000 00 15 00 04 80 01 20 01 20 20 20 20 20 20 20 20 ┆ ┆
0x15: 0000 00 00 00 56 80 16 20 20 20 20 20 20 20 20 20 20 ┆ V ┆