⟦65e2a261f⟧

TextFile

with Object, Argument, Message;
with String_Class;
with Integer_Class;
with Bounded_String;
with Block_Class;
with Counter;
with Bug;
with Symbol;
package body Boolean_Class is

    type Boolean_Unary_Message is (Entexte, Image, Valeur, Non);
    type Boolean_Keyword_Message is (Sivrai, Sifaux);

    package Bs renames Bounded_String;

    function Create (Value : Boolean) return Object.Reference is
        Obj : Object.Reference;  
        Val : Integer;

    begin  
        if Value = Standard.True then
            Val := 1;
        else
            Val := 0;
        end if;
        Obj := Object.Create (Ident_Class => Object.Boolean_Class,
                              Ident_Object => Val);
        return (Obj);
    end Create;

    function True return Object.Reference is
        Obj : Object.Reference;

    begin  
        Obj := Create (Standard.True);
        return (Obj);
    end True;

    function False return Object.Reference is
        Obj : Object.Reference;

    begin
        Obj := Create (Standard.False);
        return (Obj);
    end False;

    procedure Create_Default is
        Default_Boolean_Name : Message.Tiny_String;
    begin
        Bounded_String.Copy (Default_Boolean_Name, "Vrai");
        Symbol.Insert (Default_Boolean_Name, True);
        Bounded_String.Copy (Default_Boolean_Name, "Faux");
        Symbol.Insert (Default_Boolean_Name, False);
    end Create_Default;

    function "+" (Left, Right : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Left) /= Object.Boolean_Class) or
           (Object.Get_Class (Right) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if (Object.Get_Value (From_Object => Left) = 1) or
           (Object.Get_Value (From_Object => Right) = 1) then
            Obj := Create (Value => Standard.True);
        else
            Obj := Create (Value => Standard.False);
        end if;
        return Obj;
    end "+";

    function "&" (Left, Right : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Left) /= Object.Boolean_Class) or
           (Object.Get_Class (Right) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if (Object.Get_Value (From_Object => Left) = 1) and
           (Object.Get_Value (From_Object => Right) = 1) then  
            Obj := Create (Value => Standard.True);
        else
            Obj := Create (Value => Standard.False);
        end if;
        return Obj;
    end "&";

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

    function Image (Obj : Object.Reference) return Object.Reference is
        New_String : Message.Tiny_String;

    begin
        Bs.Free (V => New_String);
        if Object.Equal (A => Obj, B => True) then
            Bs.Copy (New_String, "vrai");
        elsif Object.Equal (A => Obj, B => False) then
            Bs.Copy (New_String, "faux");
        else
            null;
        end if;
        return String_Class.Create (Name => New_String);
    end Image;

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

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

    function Not_Value (Obj : Object.Reference) return Object.Reference is
        New_Object : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Obj) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Equal (A => Obj, B => True) then
            New_Object := Create (Standard.False);
        elsif Object.Equal (A => Obj, B => False) then
            New_Object := Create (Standard.True);
        else
            null;
        end if;
        return New_Object;
    end Not_Value;

    function If_True (Obj, Blk : Object.Reference) return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin  
        if (Object.Get_Class (Blk) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Equal (A => Obj, B => True) then
            Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
            New_Object := Block_Class.Send (Blk, The_Message_Valeur);
        end if;
        return New_Object;
    end If_True;

    function If_False (Obj, Blk : Object.Reference) return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin  
        if (Object.Get_Class (Blk) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Equal (A => Obj, B => False) then
            Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
            New_Object := Block_Class.Send (Blk, The_Message_Valeur);
        end if;
        return New_Object;
    end If_False;


    function If_True_If_False (Obj, Blk1, Blk2 : Object.Reference)
                              return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin
        if (Object.Get_Class (Blk2) /= Object.Block_Class) or
           (Object.Get_Class (Blk2) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
        if Object.Equal (A => Obj, B => True) then
            New_Object := Block_Class.Send (Blk1, The_Message_Valeur);
        elsif Object.Equal (A => Obj, B => False) then
            New_Object := Block_Class.Send (Blk2, The_Message_Valeur);
        end if;
        return New_Object;
    end If_True_If_False;

    function If_False_If_True (Obj, Blk1, Blk2 : Object.Reference)
                              return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin  
        if (Object.Get_Class (Blk2) /= Object.Block_Class) or
           (Object.Get_Class (Blk2) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
        if Object.Equal (A => Obj, B => False) then
            New_Object := Block_Class.Send (Blk1, The_Message_Valeur);
        elsif Object.Equal (A => Obj, B => True) then
            New_Object := Block_Class.Send (Blk2, The_Message_Valeur);
        end if;
        return New_Object;
    end If_False_If_True;


    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;
        Counter.Increase (Object.Boolean_Class);
        case The_Message is
            when Message.Ou =>
                Arg1 := Argument.Get (L => Args);
                Obj := To_Object + Arg1;
            when Message.Et =>
                Arg1 := Argument.Get (L => Args);
                Obj := To_Object & Arg1;
            when Message.Egal =>
                Arg1 := Argument.Get (L => Args);
                Obj := Equal (To_Object, Arg1);
            when others =>
                raise Bug.Unknown_Boolean_Message;
        end case;
        Counter.Stop_Time (Object.Boolean_Class);
        return (Obj);

    end Send;

    function Send (To_Object : Object.Reference;
                   The_Message : Message.Tiny_String) return Object.Reference is
        Result : Object.Reference := Object.Void_Reference;
        Talk : Boolean_Unary_Message;

    begin
        Talk := Boolean_Unary_Message'Value (Bs.Image (The_Message));
        Counter.Increase (Object.Boolean_Class);
        case Talk is
            when Entexte =>
                In_Text (To_Object);
                Result := To_Object;
            when Non =>
                Result := Not_Value (Obj => To_Object);  
            when Image =>
                Result := Image (Obj => To_Object);
            when Valeur =>
                Result := Value (Obj => To_Object);
        end case;
        Counter.Stop_Time (Object.Boolean_Class);
        return (Result);
    exception
        when Constraint_Error =>
            raise Bug.Unknown_Boolean_Message;

    end Send;


    function Send (To_Object : Object.Reference;
                   The_Message : Message.List;
                   With_Arguments : Argument.List) return Object.Reference is
        Result, Arg1, Arg2 : Object.Reference := Object.Void_Reference;
        Args : Argument.List;  
        Message_List : Message.List;
        Message_Receive : Message.Tiny_String;  
        Talk, Talk2 : Boolean_Keyword_Message;
        Nb_Message : Natural;

    begin
        Args := With_Arguments;  
        Message_List := The_Message;
        Message_Receive := Message.Get (L => Message_List);
        Nb_Message := Message.How_Many (L => Message_List);

        Talk := Boolean_Keyword_Message'Value (Bs.Image (V => Message_Receive));
        Counter.Increase (Object.Boolean_Class);
        case Talk is

            when Sivrai =>
                Arg1 := Argument.Get (L => With_Arguments);
                if Nb_Message = 2 then
                    Message.Next (L => Message_List, Mess => Message_Receive);
                    Talk2 := Boolean_Keyword_Message'Value
                                (Bs.Image (V => Message_Receive));
                    if Talk2 = Sifaux then
                        Argument.Next (L => Args, Obj => Arg2);
                        Result := If_True_If_False (Obj => To_Object,
                                                    Blk1 => Arg1,
                                                    Blk2 => Arg2);
                    end if;
                elsif Nb_Message = 1 then
                    Result := If_True (Obj => To_Object, Blk => Arg1);
                else
                    raise Bug.Unknown_Boolean_Message;
                end if;

            when Sifaux =>
                Arg1 := Argument.Get (L => With_Arguments);
                if Nb_Message = 2 then
                    Message.Next (L => Message_List, Mess => Message_Receive);
                    Talk2 := Boolean_Keyword_Message'Value
                                (Bs.Image (V => Message_Receive));
                    if Talk2 = Sivrai then
                        Argument.Next (L => Args, Obj => Arg2);
                        Result := If_False_If_True (Obj => To_Object,
                                                    Blk1 => Arg1,
                                                    Blk2 => Arg2);
                    end if;
                elsif Nb_Message = 1 then
                    Result := If_False (Obj => To_Object, Blk => Arg1);
                else
                    raise Bug.Unknown_Boolean_Message;
                end if;
        end case;
        Counter.Stop_Time (Object.Boolean_Class);
        return (Result);

    exception
        when Constraint_Error =>
            raise Bug.Unknown_Boolean_Message;

    end Send;


end Boolean_Class;
DataMuseum.dk

Rational R1000/400 Tapes

⟦65e2a261f⟧ TextFile

Derivation

TextFile
