DataMuseum.dk

top - download

    Length: 6500 (0x1964)
    Types: TextFile
    Names: »B«

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with Class_Block;
with Class_String;
with Class_Printer;
with Block;
with Bounded_String;  
with String_Utilities;
with Text_Io;
with Bug_Report;

package body Class_Boolean is

    function Send (This_Message : Message.Unary; To : Object.Reference)
                  return Object.Reference is
        type E_Message is (Entexte, Image, Non);

        Token : E_Message;

        Mess : Message.Unary := This_Message;

        package Bs renames Bounded_String;

    begin

        Message.Init (Mess);
        if not Message.Is_Done (Mess) then
            declare
                use Object;
            begin
                Token := E_Message'Value (Bs.Image (V => Message.Get (Mess)));
                case Token is
                    when Non =>
                        if Object.Get (Index_From => To) = 1 then
                            return False;
                        else
                            return True;
                        end if;
                    when Entexte =>
                        Put (To);
                        return To;
                    when Image =>
                        if Object.Get (Index_From => To) = 1 then
                            return Class_String.Create (Bs.Value ("VRAI"));
                        else
                            return Class_String.Create (Bs.Value ("FAUX"));
                        end if;  
                end case;
            exception
                when Constraint_Error =>
                    raise Bug_Report.Unknown_Unary_Message;
            end;
        end if;
    end Send;


    function Send (This_Message : Message.Binary; To : Object.Reference)
                  return Object.Reference is
        type E_Message is (Et, Ou, Eou);

        Token : E_Message;

        Mess : Message.Binary := This_Message;

        package Bs renames Bounded_String;

        use Object;

    begin
        if Object.Get (Class_From => Message.Get (Argument_From => Mess)) =
           Object.Boolean_Class then
            begin
                Token := E_Message'Value
                            (Bs.Image (V => Message.Get (Name_From => Mess)));
                case Token is
                    when Et =>
                        if Object.Get (To) = 1 and
                           Object.Get (Message.Get (Mess)) = 1 then
                            return True;
                        else
                            return False;
                        end if;
                    when Ou =>
                        if Object.Get (To) = 1 or
                           Object.Get (Message.Get (This_Message)) = 1 then
                            return True;
                        else
                            return False;
                        end if;
                    when Eou =>
                        if Object.Get (To) = 1 xor
                           Object.Get (Message.Get (This_Message)) = 1 then
                            return True;
                        else
                            return False;
                        end if;
                end case;  
            exception
                when Constraint_Error =>
                    raise Bug_Report.Unknown_Binary_Message;
            end;
        else
            raise Bug_Report.Boolean_Bad_Type;
        end if;
    end Send;


    function Send (This_Message : Message.Keyword; To : Object.Reference)
                  return Object.Reference is

        type E_Message is (Sivrai, Sifaux);

        Token : E_Message;

        Mess : Message.Keyword := This_Message;
        Run : Message.Unary;

        Result : Object.Reference;

        package Bs renames Bounded_String;
        Val : Object.Tiny_String;

        use Object;

    begin  
        Bs.Copy (Val, Bs.Value ("Valeur"));
        Message.Init (Mess);
        Message.Put (This_Name => Val, Into => Run);
        Message.Init (This => Run);
        while not Message.Is_Done (Mess) loop
            if Object.Get (Class_From => Message.Get (Argument_From => Mess)) =
               Object.Block_Class then

                Token := E_Message'Value
                            (Bs.Image (V => Message.Get (Name_From => Mess)));
                case Token is
                    when Sivrai =>
                        if Object.Get (Index_From => To) = 1 then
                            return Class_Block.Send
                                      (Run, Message.Get
                                               (Argument_From => Mess));
                        end if;
                    when Sifaux =>
                        if Object.Get (Index_From => To) = 0 then
                            return Class_Block.Send
                                      (Run, Message.Get
                                               (Argument_From => Mess));
                        end if;
                end case;
            else
                raise Bug_Report.Boolean_Bad_Type;
            end if;  
            Message.Next (Mess);
        end loop;
        return To;
    exception
        when Constraint_Error =>
            raise Bug_Report.Unknown_Keyword_Message;
    end Send;


    function Create (Value : Object.Index := 0) return Object.Reference is  
    begin
        return Object.Create (Class => Object.Boolean_Class, Object => Value);
    end Create;

    procedure Create is
        Node : Block.Node := Block.Get_Current_Node;
    begin
        Block.Put_Into_Table (This_Object => Class_Boolean.True,
                              Named => Bounded_String.Value ("Vrai", 80),
                              Into_Block => Node);
        Block.Put_Into_Table (This_Object => Class_Boolean.False,
                              Named => Bounded_String.Value ("Faux", 80),
                              Into_Block => Node);
    end Create;

    function True return Object.Reference is
    begin
        return Object.Create (Class => Object.Boolean_Class, Object => 1);
    end True;


    function False return Object.Reference is
    begin
        return Object.Create (Class => Object.Boolean_Class, Object => 0);
    end False;


    procedure Put (An_Object : Object.Reference) is
        use Object;
    begin
        Class_Printer.Put ("Objet Booleen { Valeur => ");
        if Object.Get (Index_From => An_Object) = 1 then
            Class_Printer.Put ("Vrai }");
        else
            Class_Printer.Put ("Faux }");
        end if;
        Class_Printer.New_Line (2);
    end Put;

end Class_Boolean;