|
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: 21504 (0x5400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Dynamic_Value_Saved, seg_0474d9
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Unbounded_String, Generic_List, Text_Io;
package body Dynamic_Value_Saved is
package Value_String is new Unbounded_String (1);
type Value (What : Kinds := Unknown) is
record
case What is
when Integer_Number =>
I : Integer;
when String_Of_Characters =>
S : Value_String.Variable_String;
when Vocabulary_Word =>
W : Value_String.Variable_String;
when Boolean_Number =>
B : Boolean;
when Set_Of_Words =>
null;
--a faire
when others =>
null;
end case;
end record;
procedure Dispose (Obj : in out Object) is
begin
Obj := null; -- le ramasse miette fait eventuellement le reste
end Dispose;
function Are_Equal (Obj1, Obj2 : in Object) return Boolean is
Kind1, Kind2 : Kinds;
begin
Kind1 := Get_Kind (Obj1);
Kind2 := Get_Kind (Obj2);
if (Kind1 = Kind2) then
case Kind1 is
when Integer_Number =>
return (Obj1.all.I = Obj2.all.I);
when String_Of_Characters =>
return (Value_String.Image (Obj1.all.S) =
Value_String.Image (Obj2.all.S));
when Vocabulary_Word =>
return (Value_String.Image (Obj1.all.W) =
Value_String.Image (Obj2.all.W));
when Boolean_Number =>
return (Obj1.all.B = Obj2.all.B);
when others =>
return True;
end case;
else
return False;
end if;
end Are_Equal;
function Get_Kind (Obj : in Object) return Kinds is
begin
if (Obj = null) then
return Unknown;
else
return Obj.all.What;
end if;
end Get_Kind;
function Get_Value (Obj : in Object) return Integer is
begin
if (Get_Kind (Obj) = Integer_Number) then
return Obj.all.I;
else
raise Type_Clash;
end if;
end Get_Value;
procedure Set_Value (Obj : in out Object; Val : Integer) is
begin
if (Obj = null) then
Obj := new Value'(What => Integer_Number, I => Val);
else
Obj.all := (What => Integer_Number, I => Val);
end if;
end Set_Value;
function Get_Value (Obj : in Object) return String is
begin
if (Get_Kind (Obj) = String_Of_Characters) then
return Value_String.Image (Obj.all.S);
else
if (Get_Kind (Obj) = Vocabulary_Word) then
return Value_String.Image (Obj.all.W);
else
raise Type_Clash;
end if;
end if;
end Get_Value;
procedure Set_Value (Obj : in out Object;
Val : String;
Is_A_Vocabulary_Word : Type_Value := String_Value) is
begin
if (Is_A_Vocabulary_Word = Voca_Value) then
if (Obj = null) then
Obj := new Value'(What => Vocabulary_Word,
W => Value_String.Value (Val));
else
Obj.all := (What => Vocabulary_Word,
W => Value_String.Value (Val));
end if;
else
if (Obj = null) then
Obj := new Value'(What => String_Of_Characters,
S => Value_String.Value (Val));
else
Obj.all := (What => String_Of_Characters,
S => Value_String.Value (Val));
end if;
end if;
end Set_Value;
function Get_Value (Obj : in Object) return Boolean is
begin
if (Get_Kind (Obj) = Boolean_Number) then
return Obj.all.B;
else
raise Type_Clash;
end if;
end Get_Value;
procedure Set_Value (Obj : in out Object; Val : in Boolean) is
begin
if (Obj = null) then
Obj := new Value'(What => Boolean_Number, B => Val);
else
Obj.all := (What => Boolean_Number, B => Val);
end if;
end Set_Value;
procedure Deep_Copy (Source : in Object; Target : in out Object) is
I : Integer;
B : Boolean;
S : Value_String.Variable_String;
W : Value_String.Variable_String;
begin
case Get_Kind (Source) is
when Integer_Number =>
I := Get_Value (Source);
Set_Value (Target, I);
when Boolean_Number =>
B := Get_Value (Source);
Set_Value (Target, B);
when String_Of_Characters =>
S := Value_String.Value (Get_Value (Source));
Set_Value (Target, Value_String.Image (S));
when Vocabulary_Word =>
W := Value_String.Value (Get_Value (Source));
Set_Value (Target, Value_String.Image (W), Voca_Value);
when others =>
null;
end case;
end Deep_Copy;
procedure Light_Copy (Source : in Object; Target : in out Object) is
begin
Target := Source;
end Light_Copy;
procedure Print (Obj : in Object) is
begin
case Get_Kind (Obj) is
when Integer_Number =>
Text_Io.Put (Integer'Image (Obj.all.I));
when String_Of_Characters =>
Text_Io.Put (Value_String.Image (Obj.all.S));
when Vocabulary_Word =>
Text_Io.Put (Value_String.Image (Obj.all.W));
when Boolean_Number =>
Text_Io.Put (Boolean'Image (Obj.all.B));
when Set_Of_Words =>
null;
--a completer
when others =>
null;
end case;
end Print;
-- procedure d'evaluation des objets
-- *** operations valables sur plusieurs types selon le sens commun ***
procedure Are_Equal (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I = Right.all.I);
when String_Of_Characters =>
Set_Value (Result, Value_String.Image (Left.all.S) =
Value_String.Image (Right.all.S));
when Vocabulary_Word =>
Set_Value (Result, Value_String.Image (Left.all.W) =
Value_String.Image (Right.all.W));
when Boolean_Number =>
Set_Value (Result, Left.all.B = Right.all.B);
when others =>
raise Type_Clash;
end case;
end Are_Equal;
procedure Is_Less (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I < Right.all.I);
when String_Of_Characters =>
Set_Value (Result, Value_String.Image (Left.all.S) <
Value_String.Image (Right.all.S));
when Vocabulary_Word =>
Set_Value (Result, Value_String.Image (Left.all.W) <
Value_String.Image (Right.all.W));
when others =>
raise Type_Clash;
end case;
end Is_Less;
procedure Is_Less_Equal (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I <= Right.all.I);
when String_Of_Characters =>
Set_Value (Result, Value_String.Image (Left.all.S) <=
Value_String.Image (Right.all.S));
when Vocabulary_Word =>
Set_Value (Result, Value_String.Image (Left.all.W) <=
Value_String.Image (Right.all.W));
when others =>
raise Type_Clash;
end case;
end Is_Less_Equal;
procedure Is_More (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I > Right.all.I);
when String_Of_Characters =>
Set_Value (Result, Value_String.Image (Left.all.S) >
Value_String.Image (Right.all.S));
when Vocabulary_Word =>
Set_Value (Result, Value_String.Image (Left.all.W) >
Value_String.Image (Right.all.W));
when others =>
raise Type_Clash;
end case;
end Is_More;
procedure Is_More_Equal (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I >= Right.all.I);
when String_Of_Characters =>
Set_Value (Result, Value_String.Image (Left.all.S) >=
Value_String.Image (Right.all.S));
when Vocabulary_Word =>
Set_Value (Result, Value_String.Image (Left.all.W) >=
Value_String.Image (Right.all.W));
when others =>
raise Type_Clash;
end case;
end Is_More_Equal;
procedure Is_Different (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I /= Right.all.I);
when String_Of_Characters =>
Set_Value (Result, Value_String.Image (Left.all.S) /=
Value_String.Image (Right.all.S));
when Vocabulary_Word =>
Set_Value (Result, Value_String.Image (Left.all.W) /=
Value_String.Image (Right.all.W));
when Boolean_Number =>
Set_Value (Result, Left.all.B /= Right.all.B);
when others =>
raise Type_Clash;
end case;
end Is_Different;
-- *** les entiers ***
procedure Change_Sign (Obj : in Object; Result : in out Object) is
begin
if (Get_Kind (Obj) /= Integer_Number) then
raise Type_Clash;
else
Set_Value (Result, -Obj.all.I);
end if;
end Change_Sign;
procedure Add (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number => Set_Value (Result, Left.all.I + Right.all.I);
when others =>
raise Type_Clash;
end case;
end Add;
procedure Substract (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I - Right.all.I);
when others =>
raise Type_Clash;
end case;
end Substract;
procedure Multiply (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
Set_Value (Result, Left.all.I * Right.all.I);
when others =>
raise Type_Clash;
end case;
end Multiply;
procedure Divide (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
case Get_Kind (Left) is
when Integer_Number =>
if (Right.all.I = 0) then
raise Division_By_Zero;
end if;
Set_Value (Result, Left.all.I / Right.all.I);
when others =>
null;
end case;
end Divide;
-- *** les booleens ***
procedure Logical_And (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
if (Get_Kind (Left) /= Boolean_Number) then
raise Type_Clash;
end if;
Set_Value (Result, Left.all.B and Right.all.B);
end Logical_And;
procedure Logical_Or (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Clash;
end if;
if (Get_Kind (Left) /= Boolean_Number) then
raise Type_Clash;
end if;
Set_Value (Result, Left.all.B or Right.all.B);
end Logical_Or;
procedure Logical_Not (Obj : in Object; Result : in out Object) is
begin
if (Get_Kind (Obj) /= Boolean_Number) then
raise Type_Clash;
end if;
Set_Value (Result, not (Obj.all.B));
end Logical_Not;
-- *** les ensembles ***
procedure In_Set (Set : in Object; Result : in out Object) is
begin
null;
end In_Set;
procedure Append_To_Set (Element : in Object; Set : in out Object) is
begin
null;
end Append_To_Set;
procedure Delete_From_Set (Element : in Object; Set : in out Object) is
begin
null;
end Delete_From_Set;
end Dynamic_Value_Saved;
nblk1=14
nid=0
hdr6=28
[0x00] rec0=21 rec1=00 rec2=01 rec3=05e
[0x01] rec0=00 rec1=00 rec2=13 rec3=020
[0x02] rec0=1d rec1=00 rec2=12 rec3=008
[0x03] rec0=23 rec1=00 rec2=0f rec3=028
[0x04] rec0=1b rec1=00 rec2=03 rec3=00e
[0x05] rec0=03 rec1=00 rec2=0c rec3=006
[0x06] rec0=20 rec1=00 rec2=0e rec3=014
[0x07] rec0=1c rec1=00 rec2=14 rec3=00a
[0x08] rec0=00 rec1=00 rec2=10 rec3=00e
[0x09] rec0=1b rec1=00 rec2=0d rec3=076
[0x0a] rec0=18 rec1=00 rec2=11 rec3=018
[0x0b] rec0=1b rec1=00 rec2=07 rec3=006
[0x0c] rec0=1a rec1=00 rec2=04 rec3=028
[0x0d] rec0=17 rec1=00 rec2=02 rec3=03c
[0x0e] rec0=1e rec1=00 rec2=09 rec3=002
[0x0f] rec0=00 rec1=00 rec2=06 rec3=012
[0x10] rec0=1e rec1=00 rec2=0a rec3=006
[0x11] rec0=1f rec1=00 rec2=0b rec3=04a
[0x12] rec0=22 rec1=00 rec2=05 rec3=020
[0x13] rec0=05 rec1=00 rec2=08 rec3=000
tail 0x2174aafb286538ffb811b 0x42a00088462060003