|
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: 22528 (0x5800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Enumeration_Facilities, package body Operators, package body Slot_Bak, seg_011182
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Text_Io;
with Constant_String;
package body Slot_Bak is
function Value (I : Integer) return Object is
begin
return Object'(Kind => Integer_Value, I_Val => I);
end Value;
function Value (F : Float) return Object is
begin
return Object'(Kind => Float_Value, F_Val => F);
end Value;
function Value (B : Boolean) return Object is
begin
return Object'(Kind => Boolean_Value, B_Val => B);
end Value;
function Value (C : Character) return Object is
begin
return (Object'(Kind => Character_Value, C_Val => C));
end Value;
function Value (S : String) return Object is
begin
return (Object'(Kind => String_Value,
S_Val => Constant_String.Value (S)));
end Value;
function Value (O : Instance.Reference) return Object is
begin
return (Kind => Class_Value, O_Val => O);
end Value;
------------------------------------------------------------
function Get (O : Object) return Integer is
Erreur_Type : exception;
begin
if O.Kind /= Integer_Value then
raise Erreur_Type;
else
return O.I_Val;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line ("variable n'est pas de type integer");
end Get;
function Get (O : Object) return Boolean is
Erreur_Type : exception;
begin
if O.Kind /= Boolean_Value then
raise Erreur_Type;
else
return O.B_Val;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line ("variable n'est pas de type boolean");
end Get;
function Get (O : Object) return Float is
Erreur_Type : exception;
begin
if O.Kind /= Float_Value then
raise Erreur_Type;
else
return O.F_Val;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line ("variable n'est pas de type float");
end Get;
function Get (O : Object) return Character is
Erreur_Type : exception;
begin
if O.Kind /= Character_Value then
raise Erreur_Type;
else
return O.C_Val;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line ("variable n'est pas de type character");
end Get;
function Get (O : Object) return String is
Erreur_Type : exception;
begin
if O.Kind /= String_Value then
raise Erreur_Type;
else
return Constant_String.Image (O.S_Val);
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line ("variable n'est pas de type string");
end Get;
function Get (O : Object) return Instance.Reference is
Erreur_Type : exception;
begin
if O.Kind /= Class_Value then
raise Erreur_Type;
else
return O.O_Val;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line ("variable n'est pas de type instance.reference");
end Get;
------------------------------------------------------------
procedure Set (O : in out Object;
To : Integer;
Changed_Kind : Boolean := False) is
Erreur_Type : exception;
begin
if O.Kind = Integer_Value then
O.I_Val := To;
else
if Changed_Kind then
raise Erreur_Type;
else
if O.Kind = String_Value then
O := Object'(Kind => Integer_Value, I_Val => To);
else
raise Erreur_Type;
end if;
end if;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line
("erreur_affectation a une variable de type non entier" &
"d'un entier a un champ de type ");
end Set;
procedure Set (O : in out Object;
To : Boolean;
Changed_Kind : Boolean := False) is
Erreur_Type : exception;
begin
if O.Kind = Boolean_Value then
O.B_Val := To;
else
if not Changed_Kind then
raise Erreur_Type;
else
-- if O.Kind = String_Value then
O := Object'(Kind => Boolean_Value, B_Val => To);
-- else
-- raise Erreur_Type;
-- end if;
end if;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line
("erreur_affectation a une variable de type non boolean" &
"d'un boolean ");
end Set;
----------
procedure Set (O : in out Object;
To : Float;
Changed_Kind : Boolean := False) is
Erreur_Type : exception;
begin
if O.Kind = Float_Value then
O.F_Val := To;
else
if not Changed_Kind then
raise Erreur_Type;
else
O := Object'(Kind => Float_Value, F_Val => To);
end if;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line
("erreur_affectation a une variable de type non reel" &
"d'un reel ");
end Set;
----------
procedure Set (O : in out Object;
To : Character;
Changed_Kind : Boolean := False) is
Erreur_Type : exception;
begin
if O.Kind = Character_Value then
O.C_Val := To;
else
if not Changed_Kind then
raise Erreur_Type;
else
O := Object'(Kind => Character_Value, C_Val => To);
end if;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line
("erreur_affectation a un champ de type non caractere" &
"d'une valeur de typecaractere ");
end Set;
----------
procedure Set (O : in out Object;
To : String;
Changed_Kind : Boolean := False) is
Erreur_Type : exception;
begin
if O.Kind = String_Value then
O.S_Val := Constant_String.Value (To);
else
if not Changed_Kind then
raise Erreur_Type;
else
O := Object'(Kind => String_Value,
S_Val => Constant_String.Value (To));
end if;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line
("erreur_affectation a un champ string d'une valeur " &
" de type non string ");
end Set;
----------
procedure Set (O : in out Object;
To : Instance.Reference;
Changed_Kind : Boolean := False) is
Erreur_Type : exception;
begin
if O.Kind = Float_Value then
O.O_Val := To;
else
if not Changed_Kind then
raise Erreur_Type;
else
O := Object'(Kind => Class_Value, O_Val => To);
end if;
end if;
exception
when Erreur_Type =>
Text_Io.Put_Line
("erreur_affectation a un champ de type reference " &
"d'une valeur de type different ");
end Set;
--============================================================
package body Operators is
package String_Operators renames Constant_String.Operators;
function Is_Same_Type (Left, Right : Object) return Boolean is
begin
return Left.Kind = Right.Kind;
end Is_Same_Type;
function "<" (Left, Right : Object) return Boolean is
Incompatible_Type : exception;
Others_Error : exception;
begin
if Left.Kind = Right.Kind then
case Left.Kind is
when Integer_Value =>
return Left.I_Val < Right.I_Val;
when Boolean_Value =>
return Left.B_Val < Right.B_Val;
when Float_Value =>
return Left.F_Val < Right.F_Val;
when Character_Value =>
return Left.C_Val < Right.C_Val;
when String_Value =>
return String_Operators."<" (Left.S_Val, Right.S_Val);
-- when Checked_Enumeration_Value =>
-- return Left.Ce_Val < Right.Ce_Val;
-- when Unchecked_Enumeration_Value =>
-- return Left.Ue_Val < Right.Ue_Val;
-- when Class_Value =>
-- return Left.O_Val < Right.O_Val;
when others =>
raise Others_Error;
end case;
else
raise Incompatible_Type;
end if;
exception
when Incompatible_Type =>
Text_Io.Put_Line ("< interdit avec deux types non identique");
when Others_Error =>
Text_Io.Put_Line (" erreur- < est permis seulement avec des " &
"variables de types entier, reel ou boolean");
end "<";
---------------------
function "<=" (Left, Right : Object) return Boolean is
Incompatible_Type : exception;
Others_Error : exception;
begin
if Left.Kind = Right.Kind then
case Left.Kind is
when Integer_Value =>
return Left.I_Val <= Right.I_Val;
when Boolean_Value =>
return Left.B_Val <= Right.B_Val;
when Float_Value =>
return Left.F_Val <= Right.F_Val;
when Character_Value =>
return Left.C_Val <= Right.C_Val;
when String_Value =>
return String_Operators."<=" (Left.S_Val, Right.S_Val);
when others =>
raise Others_Error;
end case;
return Left <= Right;
else
raise Incompatible_Type;
end if;
exception
when Incompatible_Type =>
Text_Io.Put_Line ("<= interdit avec deux types non identique");
when Others_Error =>
Text_Io.Put_Line
(" erreur- <= est permis seulement avec des " &
"variables de types entier, reel ou boolean");
end "<=";
---------------------
function ">" (Left, Right : Object) return Boolean is
Incompatible_Type : exception;
Others_Error : exception;
begin
if Left.Kind = Right.Kind then
case Left.Kind is
when Integer_Value =>
return Left.I_Val > Right.I_Val;
when Boolean_Value =>
return Left.B_Val > Right.B_Val;
when Float_Value =>
return Left.F_Val > Right.F_Val;
when Character_Value =>
return Left.C_Val > Right.C_Val;
when String_Value =>
return String_Operators.">" (Left.S_Val, Right.S_Val);
when others =>
raise Others_Error;
end case;
return Left > Right;
else
raise Incompatible_Type;
end if;
exception
when Incompatible_Type =>
Text_Io.Put_Line ("> interdit avec deux types non identique");
when Others_Error =>
Text_Io.Put_Line (" erreur- > est permis seulement avec des " &
"variables de types entier, reel ou boolean");
end ">";
---------------------
function ">=" (Left, Right : Object) return Boolean is
Incompatible_Type : exception;
Others_Error : exception;
begin
if Left.Kind = Right.Kind then
case Left.Kind is
when Integer_Value =>
return Left.I_Val >= Right.I_Val;
when Boolean_Value =>
return Left.B_Val >= Right.B_Val;
when Float_Value =>
return Left.F_Val >= Right.F_Val;
when Character_Value =>
return Left.C_Val >= Right.C_Val;
when String_Value =>
return String_Operators.">=" (Left.S_Val, Right.S_Val);
when others =>
raise Others_Error;
end case;
return Left >= Right;
else
raise Incompatible_Type;
end if;
exception
when Incompatible_Type =>
Text_Io.Put_Line (">= interdit avec deux types non identique");
when Others_Error =>
Text_Io.Put_Line (" erreur- >= est permis seulement avec des " &
"variables de types entier, reel ou boolean");
end ">=";
---------------------
end Operators;
--============================================================
function Image (O : Object) return String is
begin
case O.Kind is
when Integer_Value =>
return Integer'Image (O.I_Val);
when Float_Value =>
null;
when Boolean_Value =>
return Boolean'Image (O.B_Val);
when Character_Value =>
return Character'Image (O.C_Val);
when String_Value =>
return Constant_String.Image (O.S_Val);
when Class_Value =>
return Instance.Image (O.O_Val);
when Checked_Enumeration_Value =>
return Constant_String.Image (O.S_Val);
when Unchecked_Enumeration_Value =>
return Integer'Image (O.Ue_Val);
end case;
end Image;
--============================================================
package body Enumeration_Facilities is
function Value (E : Values) return Object is
begin
case Checked is
when False =>
return Object'(Kind => Unchecked_Enumeration_Value,
Ue_Val => Values'Pos (E));
when True =>
return Object'(Kind => Checked_Enumeration_Value,
Ce_Val => Constant_String.Value
(Values'Image (E)));
end case;
end Value;
function Get (O : Object) return Values is
begin
if not Checked and then O.Kind = Unchecked_Enumeration_Value then
return Values'Val (O.Ue_Val);
elsif Checked and then O.Kind = Checked_Enumeration_Value then
return Values'Value (Constant_String.Image (O.Ce_Val));
end if;
end Get;
function Image (O : Object) return String is
begin
return Constant_String.Image
(Constant_String.Value
(Values'Image (Enumeration_Facilities.Get (O))));
end Image;
procedure Set (O : in out Object;
To : Values;
Changed_Kind : Boolean := False) is
Incompatible_Type : exception;
begin
if Checked then
if O.Kind = Checked_Enumeration_Value then
O.Ce_Val := Constant_String.Value (Values'Image (To));
else
if Changed_Kind then
O := Object'(Kind => Checked_Enumeration_Value,
Ce_Val => Constant_String.Value
(Values'Image (To)));
else
raise Incompatible_Type;
end if;
end if;
else
if O.Kind = Unchecked_Enumeration_Value then
O.Ue_Val := Values'Pos (To);
else
if Changed_Kind then
O := Object'(Kind => Unchecked_Enumeration_Value,
Ue_Val => Values'Pos (To));
end if;
end if;
end if;
exception
when Incompatible_Type =>
Text_Io.Put_Line
("enumeration_facilities.set ... incompatibles type");
end Set;
end Enumeration_Facilities;
--============================================================
end Slot_Bak;
nblk1=15
nid=2
hdr6=28
[0x00] rec0=26 rec1=00 rec2=01 rec3=022
[0x01] rec0=00 rec1=00 rec2=0e rec3=038
[0x02] rec0=23 rec1=00 rec2=06 rec3=01a
[0x03] rec0=22 rec1=00 rec2=04 rec3=026
[0x04] rec0=20 rec1=00 rec2=0d rec3=006
[0x05] rec0=1e rec1=00 rec2=07 rec3=044
[0x06] rec0=21 rec1=00 rec2=0a rec3=00a
[0x07] rec0=1e rec1=00 rec2=03 rec3=05e
[0x08] rec0=1f rec1=00 rec2=0c rec3=04e
[0x09] rec0=17 rec1=00 rec2=15 rec3=05c
[0x0a] rec0=1a rec1=00 rec2=0f rec3=010
[0x0b] rec0=16 rec1=00 rec2=14 rec3=034
[0x0c] rec0=18 rec1=00 rec2=08 rec3=08c
[0x0d] rec0=1b rec1=00 rec2=12 rec3=024
[0x0e] rec0=0d rec1=00 rec2=10 rec3=050
[0x0f] rec0=1e rec1=00 rec2=11 rec3=062
[0x10] rec0=19 rec1=00 rec2=05 rec3=020
[0x11] rec0=15 rec1=00 rec2=13 rec3=010
[0x12] rec0=17 rec1=00 rec2=09 rec3=036
[0x13] rec0=0c rec1=00 rec2=0b rec3=000
[0x14] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x2150c8582823783c29448 0x42a00088462060003
Free Block Chain:
0x2: 0000 00 00 00 04 80 01 68 01 5f 03 39 2d 2d 20 20 20 ┆ h _ 9-- ┆