DataMuseum.dk

top - download

    Length: 7757 (0x1e4d)
    Types: TextFile
    Names: »B«

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

TextFile

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

package body Class_Block is

    function Send (This_Message : Message.Keyword; To : Object.Reference)
                  return Object.Reference is
        Mess : Message.Keyword := This_Message;
        Ident : Message.Unary :=
           Block.Get_Ident (Table (Object.Get (Index_From => To)).Node);
        Kwd : Message.Unary := Block.Get_Kwd
                                  (Table (Object.Get (Index_From => To)).Node);
        package Bs renames Bounded_String;
        package Su renames String_Utilities;
        Result : Object.Reference;
        use Object;

    begin
        Message.Init (This => Mess);
        Message.Init (This => Ident);
        if Su.Equal (Bs.Image (Message.Get (Name_From => Mess)),
                     "tantquevrai", True) then
            Result := Block.Interpret
                         (N => Table (Object.Get (Index_From => To)).Node);
            if Object.Get (Class_From => Result) = Object.Boolean_Class and then
               Object.Get (Class_From =>
                              (Message.Get (Argument_From => Mess))) =
               Object.Block_Class then
                while Object.Get (Index_From => Result) = 1 loop
                    Result :=
                       Block.Interpret
                          (N => Table (Object.Get
                                          (Index_From =>
                                              (Message.Get
                                                  (Argument_From => Mess)))).
                                Node);
                    Result := Block.Interpret (N =>
                                                  Table (Object.Get (To)).Node);
                end loop;
            else
                raise Bug_Report.Block_Bad_Type;
            end if;  
            Message.Next (Mess);
            if Message.Is_Done (Mess) then
                return Result;
            else
                raise Bug_Report.Mismatch_Parameters;
            end if;
        elsif Su.Equal (Bs.Image (Message.Get (Mess)), "tantquefaux", True) then

            Result := Block.Interpret
                         (N => Table (Object.Get (Index_From => To)).Node);
            if Object.Get (Class_From => Result) = Object.Boolean_Class and then
               Object.Get (Class_From =>
                              (Message.Get (Argument_From => Mess))) =
               Object.Block_Class then
                while Object.Get (Class_From => Result) =
                         Object.Boolean_Class and
                      Object.Get (Index_From => Result) = 0 loop
                    Result :=
                       Block.Interpret
                          (N => Table
                                   (Object.Get (Index_From =>
                                                   Message.Get
                                                      (Argument_From => Mess))).
                                Node);
                    Result := Block.Interpret (N =>
                                                  Table (Object.Get (To)).Node);
                end loop;
            else
                raise Bug_Report.Block_Bad_Type;
            end if;
            Message.Next (Mess);
            if Message.Is_Done (Mess) then
                return Result;
            else
                raise Bug_Report.Mismatch_Parameters;
            end if;
        else
            if not Message.Is_Done (Kwd) then
                while not Message.Is_Done_Name (Mess) loop
                    if Su.Equal (Bs.Image (Message.Get (Name_From => Mess)),
                                 Bs.Image (Message.Get (Name_From => Kwd)),
                                 True) or else
                       Su.Equal (Bs.Image (Message.Get (Name_From => Mess)),
                                 "valeur", True) then
                        Block.Put_Table (This_Object =>
                                            Message.Get (Argument_From => Mess),
                                         Named => Message.Get
                                                     (Name_From => Ident),
                                         Into => Table (Object.Get (To)).Node);
                        Message.Next (Mess);
                        Message.Next (Ident);  
                        Message.Next (Kwd);
                    else
                        raise Bug_Report.Mismatch_Parameters;
                    end if;
                end loop;
                if Message.Is_Done (Kwd) then
                    return Block.Interpret (N => Table (Object.Get (To)).Node);
                else
                    raise Bug_Report.Mismatch_Parameters;
                end if;
            else
                while not Message.Is_Done_Argument (Mess) and
                         not Message.Is_Done (Ident) loop
                    Block.Put_Table (This_Object =>
                                        Message.Get (Argument_From => Mess),
                                     Named => Message.Get (Name_From => Ident),
                                     Into => Table (Object.Get (To)).Node);
                    Message.Next (Mess);
                    Message.Next (Ident);
                end loop;
                if not Message.Is_Done (Ident) or
                   not Message.Is_Done_Argument (Mess) then
                    raise Bug_Report.Mismatch_Parameters;
                else
                    return Block.Interpret
                              (N => Table (Object.Get (Index_From => To)).Node);
                end if;
            end if;
        end if;
    end Send;


    function Send (This_Message : Message.Binary; To : Object.Reference)
                  return Object.Reference is
    begin
        raise Bug_Report.Unknown_Binary_Message;
        return Object.Void_Reference;
    end Send;

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

        Token : E_Message;

        package Bs renames Bounded_String;

    begin
        Token := E_Message'Value (Bs.Image (Message.Get (This_Message)));
        case Token is
            when Entexte =>
                Put (To);
                return To;
            when Valeur =>
                return Block.Interpret (N => Table (Object.Get (To)).Node);
        end case;
    exception
        when Constraint_Error =>
            raise Bug_Report.Unknown_Unary_Message;
    end Send;

    function Create (Node : Block.Node := Block.Empty_Node)
                    return Object.Reference is
        use Object;
    begin
        Last := Last + 1;
        Table (Last).Node := Node;
        return Object.Create (Class => Object.Block_Class, Object => Last);
    exception
        when Constraint_Error =>
            raise Bug_Report.Full_Block_Table;
    end Create;


    function How_Many return Object.Index is
    begin
        return Last;
    end How_Many;


    procedure Put (An_Object : Object.Reference) is
    begin
        Class_Printer.Put ("Objet Bloc {");
        Class_Printer.Forward (4);
        Class_Printer.New_Line;
        Class_Printer.Put ("Numero => " &
                           Object.Index'Image (Object.Get (An_Object)));
        Class_Printer.New_Line;
        Class_Printer.Put ("Contenu => ");
        Class_Printer.Forward (4);
        Class_Printer.New_Line;
        Block.Unparse (Table (Object.Get (Index_From => An_Object)).Node);
        Class_Printer.New_Line;
        Class_Printer.Backward (8);
        Class_Printer.Put_Tab ("}");
        Class_Printer.New_Line (2);
    end Put;

end Class_Block;