|
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: 26624 (0x6800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Val_Dyn_Save, seg_0474c9
└─⟦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 Val_Dyn_Save is
package Value_String is new Unbounded_String (10);
function Are_Equal (S1, S2 : Value_String.Variable_String) return Boolean;
package String_List is new Generic_List (Value_String.Variable_String,
Are_Equal, Value_String.Copy);
type Acces_Str_List is access String_List.Object;
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 =>
Sw : Acces_Str_List;
when Unknown =>
null;
end case;
end record;
function Are_Equal (S1, S2 : Value_String.Variable_String) return Boolean is
begin
return ((Value_String.Image (S1)) = (Value_String.Image (S2)));
end Are_Equal;
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 Set_Of_Words =>
null; -- a negocier
when Unknown =>
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;
procedure Raise_Expected_Type (Obj : in Object) is
begin
case Get_Kind (Obj) is
when Integer_Number =>
raise Integer_Expected;
when Boolean_Number =>
raise Boolean_Expected;
when String_Of_Characters =>
raise String_Expected;
when Set_Of_Words =>
raise Set_Expected;
when Vocabulary_Word =>
raise Word_Expected;
when Unknown =>
null;
end case;
end Raise_Expected_Type;
function Get_Value (Obj : in Object) return Integer is
begin
if (Get_Kind (Obj) = Integer_Number) then
return Obj.all.I;
else
Raise_Expected_Type (Obj);
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
if (Get_Kind (Obj) = Integer_Number) then
Obj.all := (What => Integer_Number, I => Val);
else
Raise_Expected_Type (Obj);
end if;
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_Expected_Type (Obj);
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
if (Get_Kind (Obj) = Vocabulary_Word) then
Obj.all := (What => Vocabulary_Word,
W => Value_String.Value (Val));
else
Raise_Expected_Type (Obj);
end if;
end if;
else
if (Obj = null) then
Obj := new Value'(What => String_Of_Characters,
S => Value_String.Value (Val));
else
if (Get_Kind (Obj) = String_Of_Characters) then
Obj.all := (What => String_Of_Characters,
S => Value_String.Value (Val));
else
Raise_Expected_Type (Obj);
end if;
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_Expected_Type (Obj);
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
if (Get_Kind (Obj) = Boolean_Number) then
Obj.all := (What => Boolean_Number, B => Val);
else
Raise_Expected_Type (Obj);
end if;
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 Set_Of_Words =>
if (Target = null) then
Create (Target);
end if;
String_List.Deep_Copy (Source.Sw.all, Target.Sw.all);
when Unknown =>
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
procedure Print_Set (Set : in Object) is
It : String_List.Iterator;
Cpt_Mot : Natural;
begin
if (Set /= null) then
if (Get_Kind (Set) /= Set_Of_Words) then
raise Set_Expected;
end if;
String_List.Initialize (It, Set.Sw.all);
Cpt_Mot := 0;
while not String_List.At_End (It) loop
if Cpt_Mot = 3 then
Cpt_Mot := 0;
Text_Io.New_Line;
end if;
Cpt_Mot := Cpt_Mot + 1;
Text_Io.Put
(Value_String.Image (String_List.Consult (It)) & " ");
String_List.Next (It);
end loop;
else
Text_Io.Put ("ensemble vide");
end if;
end Print_Set;
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 =>
Print_Set (Obj);
when Unknown =>
Text_Io.Put ("valeur inexistante");
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_Mismatch;
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 Set_Of_Words | Unknown =>
raise Illegal_Operation;
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_Mismatch;
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_Of_Words | Unknown =>
raise Illegal_Operation;
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_Mismatch;
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_Of_Words | Unknown =>
raise Illegal_Operation;
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_Mismatch;
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_Of_Words | Unknown =>
raise Illegal_Operation;
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_Mismatch;
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_Of_Words | Unknown =>
raise Illegal_Operation;
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_Mismatch;
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 Set_Of_Words | Unknown =>
raise Illegal_Operation; 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 Integer_Expected;
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_Mismatch;
end if;
if (Get_Kind (Left) /= Integer_Number) then
raise Integer_Expected;
end if;
Set_Value (Result, Left.all.I + Right.all.I);
end Add;
procedure Substract (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Mismatch;
end if;
if (Get_Kind (Left) /= Integer_Number) then
raise Integer_Expected;
end if;
Set_Value (Result, Left.all.I - Right.all.I);
end Substract;
procedure Multiply (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Mismatch;
end if;
if (Get_Kind (Left) /= Integer_Number) then
raise Integer_Expected;
end if;
Set_Value (Result, Left.all.I * Right.all.I);
end Multiply;
procedure Divide (Left, Right : in Object; Result : in out Object) is
begin
if (Get_Kind (Left) /= Get_Kind (Right)) then
raise Type_Mismatch;
end if;
if (Get_Kind (Left) /= Integer_Number) then
raise Integer_Expected;
end if;
if (Right.all.I = 0) then
raise Division_By_Zero;
end if;
Set_Value (Result, Left.all.I / Right.all.I);
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_Mismatch;
end if;
if (Get_Kind (Left) /= Boolean_Number) then
raise Boolean_Expected;
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_Mismatch;
end if;
if (Get_Kind (Left) /= Boolean_Number) then
raise Boolean_Expected;
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 Boolean_Expected;
end if;
Set_Value (Resul, not (Obj.all.B));
end Logical_Not;
-- *** les ensembles ***
procedure Create (Set : in out Object) is
Tmp_List : Acces_Str_List;
begin
Tmp_List := new String_List.Object;
String_List.Free (Tmp_List.all);
Set := new Value'(What => Set_Of_Words, Sw => Tmp_List);
end Create;
procedure In_Set (Set : in Object;
Element : in String;
Result : in out Object) is
Exist : Boolean;
begin
if (Set /= null) then
if (Get_Kind (Set) /= Set_Of_Words) then
raise Set_Expected;
end if;
Exist := String_List.Is_In_List
(Set.Sw.all, Value_String.Value (Element));
else
Exist := False;
end if;
Set_Value (Result, Exist);
end In_Set;
procedure Append_To_Set (Set : in out Object; Element : in String) is
Tmp_List : Acces_Str_List;
begin
if (Set = null) then
Create (Set);
end if;
if (Get_Kind (Set) /= Set_Of_Words) then
raise Set_Expected;
end if;
String_List.Add (Set.Sw.all, Value_String.Value (Element));
end Append_To_Set;
procedure Delete_From_Set (Set : in out Object; Element : in String) is
Tmp_List : Acces_Str_List;
begin
-- si element pas dans liste, ou si la liste n'existe pas, rien n'est fait
if (Set /= null) then
if (Get_Kind (Set) /= Set_Of_Words) then
raise Set_Expected;
end if;
String_List.Delete (Set.Sw.all, Value_String.Value (Element));
end if;
end Delete_From_Set;
procedure Purge_Set (Set : in out Object) is
begin
if (Set /= null) then
if (Get_Kind (Set) /= Set_Of_Words) then
raise Set_Expected;
end if;
String_List.Free (Set.Sw.all);
end if;
end Purge_Set;
end Val_Dyn_Save;
nblk1=19
nid=0
hdr6=32
[0x00] rec0=1c rec1=00 rec2=01 rec3=00e
[0x01] rec0=1d rec1=00 rec2=10 rec3=02e
[0x02] rec0=23 rec1=00 rec2=0f rec3=01a
[0x03] rec0=23 rec1=00 rec2=07 rec3=02a
[0x04] rec0=02 rec1=00 rec2=14 rec3=012
[0x05] rec0=19 rec1=00 rec2=11 rec3=02a
[0x06] rec0=20 rec1=00 rec2=19 rec3=006
[0x07] rec0=11 rec1=00 rec2=0d rec3=00c
[0x08] rec0=19 rec1=00 rec2=02 rec3=010
[0x09] rec0=17 rec1=00 rec2=0c rec3=016
[0x0a] rec0=1d rec1=00 rec2=03 rec3=038
[0x0b] rec0=18 rec1=00 rec2=18 rec3=01e
[0x0c] rec0=05 rec1=00 rec2=17 rec3=032
[0x0d] rec0=17 rec1=00 rec2=16 rec3=008
[0x0e] rec0=16 rec1=00 rec2=15 rec3=016
[0x0f] rec0=17 rec1=00 rec2=0e rec3=066
[0x10] rec0=17 rec1=00 rec2=04 rec3=02a
[0x11] rec0=02 rec1=00 rec2=09 rec3=002
[0x12] rec0=20 rec1=00 rec2=06 rec3=022
[0x13] rec0=1e rec1=00 rec2=0b rec3=030
[0x14] rec0=1d rec1=00 rec2=08 rec3=030
[0x15] rec0=00 rec1=00 rec2=12 rec3=002
[0x16] rec0=22 rec1=00 rec2=05 rec3=00c
[0x17] rec0=1e rec1=00 rec2=0a rec3=006
[0x18] rec0=07 rec1=00 rec2=13 rec3=000
tail 0x2174aae6486538f2caea7 0x42a00088462060003