⟦0e896cedf⟧

TextFile

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;
DataMuseum.dk

Rational R1000/400 Tapes

⟦0e896cedf⟧ TextFile

Derivation

TextFile
