|
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 - metrics - download
Length: 21504 (0x5400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Dv2, seg_0474d5
└─⟦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 Dv2 is
package Value_String is new Unbounded_String (1);
function Are_Equal (S1, S2 : Value_String.Variable_String) return Boolean;
package String_List is new Generic_List
(Value_String.Variable_String, Are_Equal);
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 others =>
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 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 (Element : in String;
Set : in Object;
Result : in out Object) is
Eb : Boolean;
begin
if (Get_Kind (Set) = Set_Of_Words) then
Eb := String_List.Is_In_List (Set.Sw.all,
Value_String.Value (Element));
Set_Value (Result, Eb);
else
raise Type_Clash;
end if;
end In_Set;
procedure Append_To_Set (Element : in String; Set : in out Object) is
Tmp_List : Acces_Str_List;
begin
if (Set = null) then
Tmp_List := new String_List.Object;
String_List.Free (Tmp_List.all);
Set := new Value'(What => Set_Of_Words, Sw => Tmp_List);
end if;
if (Get_Kind (Set) = Set_Of_Words) then
String_List.Add (Set.Sw.all, Value_String.Value (Element));
else raise Type_Clash;
end if;
end Append_To_Set;
procedure Delete_From_Set (Element : in String; Set : in out Object) is
Tmp_List : Acces_Str_List;
begin
if (Set = null) then
Tmp_List := new String_List.Object;
String_List.Free (Tmp_List.all);
Set := new Value'(What => Set_Of_Words, Sw => Tmp_List);
end if;
if (Get_Kind (Set) = Set_Of_Words) then
String_List.Delete (Set.Sw.all, Value_String.Value (Element));
-- si element pas dans liste, rien n'est fait
else
raise Type_Clash;
end if;
end Delete_From_Set;
procedure Purge_Set (Set : in out Object) is
begin
if (Get_Kind (Set) = Set_Of_Words) then
String_List.Free (Set.Sw.all);
else
raise Type_Clash;
end if;
end Purge_Set;
procedure Print_Set (Set : in out Object) is
It : String_List.Iterator;
begin
if (Get_Kind (Set) = Set_Of_Words) then
String_List.Initialize (It, Set.Sw.all);
while not String_List.At_End (It) loop
Text_Io.Put_Line (Value_String.Image
(String_List.Consult (It)));
String_List.Next (It);
end loop;
else
raise Type_Clash;
end if;
end Print_Set;
end Dv2;
nblk1=14
nid=12
hdr6=26
[0x00] rec0=1c rec1=00 rec2=01 rec3=02a
[0x01] rec0=1d rec1=00 rec2=03 rec3=008
[0x02] rec0=00 rec1=00 rec2=0c rec3=062
[0x03] rec0=26 rec1=00 rec2=0e rec3=002
[0x04] rec0=1c rec1=00 rec2=14 rec3=076
[0x05] rec0=22 rec1=00 rec2=10 rec3=06c
[0x06] rec0=1c rec1=00 rec2=0d rec3=012
[0x07] rec0=1f rec1=00 rec2=11 rec3=01e
[0x08] rec0=19 rec1=00 rec2=07 rec3=038
[0x09] rec0=16 rec1=00 rec2=04 rec3=062
[0x0a] rec0=17 rec1=00 rec2=02 rec3=07c
[0x0b] rec0=1c rec1=00 rec2=09 rec3=07e
[0x0c] rec0=1a rec1=00 rec2=06 rec3=046
[0x0d] rec0=1f rec1=00 rec2=0a rec3=020
[0x0e] rec0=20 rec1=00 rec2=0b rec3=000
[0x0f] rec0=1d rec1=00 rec2=05 rec3=016
[0x10] rec0=1d rec1=00 rec2=13 rec3=002
[0x11] rec0=1f rec1=00 rec2=0f rec3=00e
[0x12] rec0=0f rec1=00 rec2=08 rec3=000
[0x13] rec0=0f rec1=00 rec2=12 rec3=000
tail 0x2174aaf8086538ff0bf09 0x42a00088462060003
Free Block Chain:
0x12: 0000 00 00 01 da 80 0a 2e 49 74 65 72 61 74 6f 72 3b ┆ .Iterator;┆