|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 17093 (0x42c5)
Types: TextFile
Names: »B«
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─⟦6f12a12be⟧ »DATA«
└─⟦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;