⟦34a2fa421⟧

TextFile

with Object;
with Argument;
with Message;
with Bounded_String;
with String_Utilities;
with Random;
with Block_Class;
with Boolean_Class;
with String_Class;
with Counter;
with Bug;
package body Integer_Class is

    package Bs renames Bounded_String;

    type Integer_Keyword_Message is (Fois, Repeter, A);
    type Integer_Unary_Message is
       (Entexte, Image, Aucube, Moins, Aleatoire, Attend);

    function Create (Value : Integer) return Object.Reference is
        Obj : Object.Reference;
    begin
        Obj := Object.Create (Object.Integer_Class, Value);
        return (Obj);
    end Create;


    function Fois (Indice, Blk : Object.Reference) return Object.Reference is
        Obj : Object.Reference;  
        The_Message_Valeur : Message.Tiny_String;
        use Object;
    begin  
        if (Object.Get_Class (Blk) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
        for I in 1 .. Object.Get_Value (Indice) loop
            Obj := Block_Class.Send (Blk, The_Message_Valeur);
        end loop;
        return (Obj);
    end Fois;

    function Repeter (Min, Max, Blk : Object.Reference)
                     return Object.Reference is
        Obj : Object.Reference;
        Arg : Argument.List;  
        Mess : Message.List;  
        The_Value_Message : Message.Tiny_String;
        use Object;
    begin  
        if (Object.Get_Class (Blk) /= Object.Block_Class) or
           (Object.Get_Class (Min) /= Object.Integer_Class) or
           (Object.Get_Class (Max) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Bs.Copy (The_Value_Message, Block_Class.Message_Valeur);
        if (Object.Get_Value (Min) > Object.Get_Value (Max)) then
            for I in reverse Object.Get_Value (Max) ..
                                Object.Get_Value (Min) loop
                Message.Init (Mess);
                Mess := Message.Put (Mess, The_Value_Message);
                Obj := Create (I);
                Argument.Init (Arg);
                Arg := Argument.Put (Arg, Obj);
                Obj := Block_Class.Send (Blk, Mess, Arg);
            end loop;
        else
            for I in Object.Get_Value (Min) .. Object.Get_Value (Max) loop
                Message.Init (Mess);
                Mess := Message.Put (Mess, The_Value_Message);
                Obj := Create (I);  
                Argument.Init (Arg);
                Arg := Argument.Put (Arg, Obj);
                Obj := Block_Class.Send (Blk, Mess, Arg);
            end loop;
        end if;
        return (Obj);
    end Repeter;


    function "+" (A, B : Object.Reference) return Object.Reference is  
        Obj : Object.Reference;
        use Object;
    begin  
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Obj := Create (Object.Get_Value (A) + Object.Get_Value (B));
        return (Obj);
    end "+";

    function "-" (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin  
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Obj := Create (Object.Get_Value (A) - Object.Get_Value (B));
        return (Obj);
    end "-";

    function "*" (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin  
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Obj := Create (Object.Get_Value (A) * Object.Get_Value (B));
        return (Obj);
    end "*";

    function "/" (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin  
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Obj := Create (Object.Get_Value (A) / Object.Get_Value (B));
        return (Obj);
    end "/";

    function Randomize (A : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        A_Handle : Random.Handle;
        Value : Integer;
    begin
        Random.Initialize (A_Handle);
        Value := Object.Get_Value (A);
        if (Value > 0) then
            Obj := Create (Random.Natural_Value (A_Handle, Natural (Value)));
        else
            Obj := Create (Random.Natural_Value
                              (A_Handle, Natural (-1 * Value)));
        end if;
        return (Obj);
    end Randomize;

    function Wait (A : Object.Reference) return Object.Reference is
    begin
        if Object.Get_Value (A) > 0 then
            delay (Duration (Object.Get_Value (A)));
        end if;  
        return (A);
    end Wait;

    function Au_Cube (A : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        Value : Integer;
    begin  
        Value := Object.Get_Value (A);
        Obj := Create (Value * Value * Value);
        return (Obj);
    end Au_Cube;

    function Greater_Than (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Get_Value (A) > Object.Get_Value (B) then
            Obj := Boolean_Class.True;
        else
            Obj := Boolean_Class.False;
        end if;
        return (Obj);
    end Greater_Than;

    function Lower_Than (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Get_Value (A) < Object.Get_Value (B) then
            Obj := Boolean_Class.True;
        else
            Obj := Boolean_Class.False;
        end if;
        return (Obj);
    end Lower_Than;

    function Greater_Or_Equal (A, B : Object.Reference)
                              return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Get_Value (A) >= Object.Get_Value (B) then
            Obj := Boolean_Class.True;
        else
            Obj := Boolean_Class.False;
        end if;
        return (Obj);
    end Greater_Or_Equal;

    function Lower_Or_Equal (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin  
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Get_Value (A) <= Object.Get_Value (B) then
            Obj := Boolean_Class.True;
        else
            Obj := Boolean_Class.False;
        end if;
        return (Obj);
    end Lower_Or_Equal;

    function Equal (A, B : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin  
        if (Object.Get_Class (A) /= Object.Integer_Class) or
           (Object.Get_Class (B) /= Object.Integer_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Get_Value (A) = Object.Get_Value (B) then
            Obj := Boolean_Class.True;
        else
            Obj := Boolean_Class.False;
        end if;
        return (Obj);
    end Equal;

    function Minus (I : Object.Reference) return Object.Reference is
    begin
        return Create (-Object.Get_Value (I));
    end Minus;

    function Image (I : Object.Reference) return Object.Reference is
        Valeur : Message.Tiny_String;
        Result : Object.Reference;
    begin  
        Bs.Copy (Valeur, Bs.Value (String_Utilities.Number_To_String
                                      (Value => Object.Get_Value (I))));
        Result := String_Class.Create (Valeur);
        return (Result);
    end Image;

    procedure In_Text (I : Object.Reference) is
    begin
        Object.In_Text (I);
    end In_Text;

    function Send (To_Object : Object.Reference;
                   The_Message : Message.Selector;
                   With_Arguments : Argument.List) return Object.Reference is
        Obj, Arg1 : Object.Reference;
        Args : Argument.List;
    begin  
        Args := With_Arguments;
        Arg1 := Argument.Get (Args);
        Counter.Increase (Object.Integer_Class);
        case The_Message is
            when Message.Plus =>
                Obj := To_Object + Arg1;

            when Message.Moins =>
                Obj := To_Object - Arg1;

            when Message.Multiplier =>
                Obj := To_Object * Arg1;

            when Message.Diviser =>
                Obj := To_Object / Arg1;

            when Message.Inferieur =>
                Obj := Lower_Than (To_Object, Arg1);

            when Message.Superieur =>
                Obj := Greater_Than (To_Object, Arg1);

            when Message.Inferieur_Egal =>
                Obj := Lower_Or_Equal (To_Object, Arg1);

            when Message.Superieur_Egal =>
                Obj := Greater_Or_Equal (To_Object, Arg1);

            when Message.Egal =>
                Obj := Equal (To_Object, Arg1);

            when others =>
                raise Bug.Unknown_Integer_Message;
        end case;
        Counter.Stop_Time (Object.Integer_Class);
        return (Obj);
    end Send;


    function Send (To_Object : Object.Reference;
                   The_Messages : Message.List;
                   With_Arguments : Argument.List) return Object.Reference is
        Result, Arg1, Arg2 : Object.Reference := Object.Void_Reference;
        Args : Argument.List;
        Mess : Message.List;
        A_Message : Message.Tiny_String;
        Talk : Integer_Keyword_Message;
    begin
        Args := With_Arguments;
        Mess := The_Messages;  
        A_Message := Message.Get (Mess);
        Talk := Integer_Keyword_Message'Value (Bs.Image (V => A_Message));
        Counter.Increase (Object.Integer_Class);
        case Talk is

            when Fois =>  
                if Message.How_Many (Mess) > 1 then
                    raise Bug.Too_Many_Keywords;
                end if;
                Arg1 := Argument.Get (With_Arguments);  
                Result := Fois (To_Object, Arg1);

            when Repeter =>
                Message.Next (Mess, A_Message);
                if Integer_Keyword_Message'Value (Bs.Image (V => A_Message)) /=
                   A then
                    raise Bug.Unknown_Integer_Message;
                end if;
                Arg1 := Argument.Get (With_Arguments);  
                Argument.Next (L => Args, Obj => Arg2);
                Result := Repeter (To_Object, Arg2, Arg1);
            when others =>
                raise Bug.Unknown_Integer_Message;
        end case;
        Counter.Stop_Time (Object.Integer_Class);
        return (Result);

    exception  
        when Constraint_Error =>
            raise Bug.Unknown_Integer_Message;
    end Send;

    function Send (To_Object : Object.Reference;
                   The_Message : Message.Tiny_String) return Object.Reference is
        Result : Object.Reference := Object.Void_Reference;
        Talk : Integer_Unary_Message;
    begin  
        Talk := Integer_Unary_Message'Value (Bs.Image (V => The_Message));
        Counter.Increase (Object.Integer_Class);
        case Talk is

            when Entexte =>
                In_Text (To_Object);
                Result := To_Object;

            when Image =>
                Result := Image (To_Object);
            when Aucube =>  
                Result := Au_Cube (To_Object);

            when Moins =>
                Result := Minus (To_Object);

            when Aleatoire =>
                Result := Randomize (To_Object);

            when Attend =>
                Result := Wait (To_Object);
        end case;
        Counter.Stop_Time (Object.Integer_Class);
        return (Result);

    exception
        when Constraint_Error =>
            raise Bug.Unknown_Integer_Message;
    end Send;

end Integer_Class;
DataMuseum.dk

Rational R1000/400 Tapes

⟦34a2fa421⟧ TextFile

Derivation

TextFile
