DataMuseum.dk

top - metrics - download

    Length: 18099 (0x46b3)
    Types: TextFile
    Names: »B«

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

TextFile

with Boolean_Class;
with Bounded_String;  
with Errors;
with Pen_Class;  
with String_Class;
with Trace;
with Turtle_Class;
with Unparser;

package body Block_Class is

    type Unary_Message is (Nul, Valeur, En_Texte);
    type One_Argument_Message is (Nul, Tant_Que_Vrai, Tant_Que_Faux);

    procedure Create_Program_Block is
    begin
        Trace.Display ("block_class.create_program_block");
        Blocks (0).Free := False;
        Blocks (0).Enclosing := 0;  
        Current_Block := 0;
    end Create_Program_Block;

    function Create return Object.Reference is
        Class_Id : Object.Class := Object.Bloc;
        Obj : Object.Reference := Object.Void_Reference;
    begin
        Trace.Display ("block_class.create");
        for I in Block_Map'Range loop
            if Blocks (I).Free then
                Blocks (I).Free := False;
                Blocks (I).Enclosing := Current_Block;
                Current_Block := I;
                Obj := (Object.Create (Class_Id, Integer (I)));
                exit;
            end if;
        end loop;
        if Object.Equal (Obj, Object.Void_Reference) then
            raise Errors.Max_Block_Number_Exceeded;
        else
            return Obj;
        end if;
    end Create;

    procedure Unparse (The_Block : Object.Reference) is
        Index : Size := Size (Object.Get_Id (The_Block));
    begin
        if not Message.Is_Empty (Blocks (Index).Keywords) then
            Unparser.Put ("Avec ");
            Message.Init (Blocks (Index).Keywords);
            Message.Init (Blocks (Index).Arguments);
            while not Message.Done (Blocks (Index).Keywords) loop
                Unparser.Put (Message.Value (Blocks (Index).Keywords));
                Unparser.Put (" ");
                Unparser.Put (Message.Value (Blocks (Index).Arguments));
                Unparser.Put (" ");
                Message.Next (Blocks (Index).Keywords);
                Message.Next (Blocks (Index).Arguments);
            end loop;
            Unparser.Put (".");
            Unparser.New_Line;
        end if;
        Trace.Display ("fin unparse block_class");
    end Unparse;

    procedure Close is
    begin
        Trace.Display ("block_class.close");
        Current_Block := Blocks (Current_Block).Enclosing;
    end Close;

    procedure New_Symbols_Table is
    begin
        Trace.Display ("block_class.new_symbols_table");
        Symbols.Create_Map (Blocks (Current_Block).Local_Symb);
    end New_Symbols_Table;

    function Table_Created return Boolean is
    begin
        Trace.Display ("block_class.table_created");
        return (not Symbols.Is_Nil (Blocks (Current_Block).Local_Symb));
    end Table_Created;

    procedure Set_Predefined_Identifiers is
        Iterator : Custom.Predefined_Id;  
        Predef_Id : Scanner.Lexeme;
        use Custom;
    begin
        Iterator := Custom.Predefined_Id'First;
        loop  
            Predef_Id := Bounded_String.Value
                            (Custom.Predefined_Id'Image (Iterator),
                             Custom.String_Max_Length);
            case Iterator is
                when Custom.Tortue =>
                    Symbols.Insert (Predef_Id,
                                    Blocks (Current_Block).Local_Symb,
                                    Turtle_Class.Create);
                when Custom.Stylo =>
                    Symbols.Insert (Predef_Id,
                                    Blocks (Current_Block).Local_Symb,
                                    Pen_Class.Create);
                when Custom.Vrai =>
                    Symbols.Insert (Predef_Id,
                                    Blocks (Current_Block).Local_Symb,
                                    Boolean_Class.True);
                when Custom.Faux =>
                    Symbols.Insert (Predef_Id,
                                    Blocks (Current_Block).Local_Symb,
                                    Boolean_Class.False);
                when Custom.Vide =>
                    Symbols.Insert (Predef_Id,
                                    Blocks (Current_Block).Local_Symb,
                                    Object.Void_Reference);
                when Custom.Valeur =>
                    null;
            end case;
            exit when Iterator = (Custom.Predefined_Id'Last);
            Iterator := Custom.Predefined_Id'Succ (Iterator);
        end loop;
    end Set_Predefined_Identifiers;

    procedure Init_Symbol (The_Symbol : Scanner.Lexeme) is
        Seek_Block : Size;
        Found : Boolean := False;
        Obj : Object.Reference;
    begin
        Trace.Display ("block_class.init_symbol");
        Seek_Block := Current_Block;
        loop
            if not Symbols.Is_Nil (Blocks (Seek_Block).Local_Symb) then
                Symbols.Find
                   (The_Symbol, Blocks (Seek_Block).Local_Symb, Obj, Found);
            end if;
            exit when Found or Seek_Block = 0;  
            Seek_Block := Blocks (Seek_Block).Enclosing;
        end loop;
        if not Found then
            Symbols.Insert (The_Symbol, Blocks (Current_Block).Local_Symb,
                            Object.Void_Reference);
        end if;
    end Init_Symbol;

    procedure Set_Value (The_Symbol : Scanner.Lexeme;
                         The_Value : Object.Reference) is
        Seek_Block : Size;
        Found : Boolean := False;
        Obj : Object.Reference;
    begin  
        Trace.Display ("block_class.set_value");
        Seek_Block := Current_Block;
        loop
            if not Symbols.Is_Nil (Blocks (Seek_Block).Local_Symb) then
                Symbols.Find
                   (The_Symbol, Blocks (Seek_Block).Local_Symb, Obj, Found);
                if Found then
                    Symbols.Insert
                       (The_Symbol, Blocks (Seek_Block).Local_Symb, The_Value);
                    exit;
                end if;
            end if;
            if Seek_Block = 0 then
                raise Errors.Set_Value_To_Undefined_Identifier;
            else
                Seek_Block := Blocks (Seek_Block).Enclosing;
            end if;
        end loop;
    end Set_Value;

    procedure Set_Argument_Value (The_Symbol : Scanner.Lexeme;
                                  The_Value : Object.Reference;  
                                  In_Block : in out Block_Def) is
    begin
        Trace.Display ("block_class.set_argument_value");
        Symbols.Insert (The_Symbol, In_Block.Local_Symb, The_Value);
    end Set_Argument_Value;

    function Get_Value (The_Symbol : Scanner.Lexeme) return Object.Reference is
        Seek_Block : Size;
        Found : Boolean := False;
        Obj : Object.Reference;
    begin
        Trace.Display ("block_class.get_value");
        Seek_Block := Current_Block;
        loop
            if not Symbols.Is_Nil (Blocks (Seek_Block).Local_Symb) then
                Symbols.Find
                   (The_Symbol, Blocks (Seek_Block).Local_Symb, Obj, Found);
                if Found then
                    return Obj;
                    exit;
                end if;  
            end if;
            if Seek_Block = 0 then
                raise Errors.Get_Value_Of_Undefined_Identifier;
            else
                Seek_Block := Blocks (Seek_Block).Enclosing;
            end if;
        end loop;
    end Get_Value;

    procedure New_Arg_List is
    begin
        Trace.Display ("block_class.new_arg_list");
        Message.Free (Blocks (Current_Block).Keywords);
        Message.Free (Blocks (Current_Block).Arguments);
    end New_Arg_List;

    procedure Set_Node (For_Block : Object.Reference; The_Node : Block.Node) is
        Index : Size;
    begin
        Index := Size (Object.Get_Id (For_Block));
        Blocks (Index).Parse_Node := The_Node;
    end Set_Node;

    procedure Set_Keyword (The_Keyword : Scanner.Lexeme) is
    begin
        Trace.Display ("block_class.set_keyword");
        Message.Init (Blocks (Current_Block).Keywords);
        while not Message.Done (Blocks (Current_Block).Keywords) loop
            if (Bounded_String.Image
                   (Message.Value (Blocks (Current_Block).Keywords)) =
                Bounded_String.Image (The_Keyword)) and
               (Bounded_String.Image
                   (Message.Value (Blocks (Current_Block).Keywords)) /=
                "VALEUR:") then
                raise Errors.Several_Arguments_With_Same_Name;
            else
                Message.Next (Blocks (Current_Block).Keywords);
            end if;
        end loop;
        Message.Insert (The_Keyword, Blocks (Current_Block).Keywords);
    end Set_Keyword;

    procedure Set_Argument (The_Argument : Scanner.Lexeme) is
    begin
        Trace.Display ("block_class.set_argument");
        Message.Init (Blocks (Current_Block).Arguments);
        while not Message.Done (Blocks (Current_Block).Arguments) loop
            if (Bounded_String.Image (Message.Value
                                         (Blocks (Current_Block).Arguments)) =
                Bounded_String.Image (The_Argument)) then
                raise Errors.Multiply_Defined_Argument;
            else
                Message.Next (Blocks (Current_Block).Arguments);
            end if;
        end loop;
        Message.Insert (The_Argument, Blocks (Current_Block).Arguments);
        Symbols.Insert (The_Argument, Blocks (Current_Block).Local_Symb,
                        Object.Void_Reference);
    end Set_Argument;

    function Convert_To_Unary
                (The_Message : Scanner.Lexeme) return Unary_Message is
    begin
        if Bounded_String.Image (The_Message) = "VALEUR" then
            return Valeur;
        elsif Bounded_String.Image (The_Message) = "EN_TEXTE" then
            return En_Texte;
        else
            return Nul;
        end if;
    end Convert_To_Unary;

    function Convert_To_One_Arg_Msg
                (The_Message : Scanner.Lexeme) return One_Argument_Message is
    begin
        if Bounded_String.Image (The_Message) = "TANT_QUE_VRAI:" then
            return Tant_Que_Vrai;
        elsif Bounded_String.Image (The_Message) = "TANT_QUE_FAUX:" then
            return Tant_Que_Faux;
        else
            return Nul;
        end if;
    end Convert_To_One_Arg_Msg;

    function Matching_Keyword
                (Msg_Kw : Message.Selector; Check_Block : Block_Def)
                return Boolean is
    begin
        return (Bounded_String.Image (Message.Value (Msg_Kw)) =
                Bounded_String.Image (Message.Value (Check_Block.Keywords))) or
               (Bounded_String.Image (Message.Value (Msg_Kw)) = "VALEUR:");
    end Matching_Keyword;

    function Same_Selector_Length
                (Msg_Kw : Message.Selector; Check_Block : Block_Def)
                return Boolean is
    begin
        return Message.Arg_Number (Msg_Kw) =
                  Message.Arg_Number (Check_Block.Keywords);
    end Same_Selector_Length;

    procedure Invalid_Arg_Number
                 (Msg_Kw : Message.Selector; Check_Block : Block_Def) is
    begin
        if Message.Arg_Number (Msg_Kw) <
           Message.Arg_Number (Check_Block.Keywords) then
            raise Errors.Bloc_Msg_With_Not_Enough_Arguments;
        else
            raise Errors.Bloc_Msg_With_Too_Many_Arguments;
        end if;
    end Invalid_Arg_Number;

    procedure Get_First_Keyword (Msg_Kw : in out Message.Selector;
                                 Msg_Arg : in out Parameters.List;
                                 Check_Block : in out Block_Def) is
    begin
        Message.Init (Msg_Kw);
        Parameters.Init (Msg_Arg);
        Message.Init (Check_Block.Keywords);
        Message.Init (Check_Block.Arguments);
    end Get_First_Keyword;

    procedure Get_Next_Keyword (Msg_Kw : in out Message.Selector;
                                Msg_Arg : in out Parameters.List;
                                Check_Block : in out Block_Def) is
    begin
        Message.Next (Msg_Kw);
        Parameters.Next (Msg_Arg);
        Message.Next (Check_Block.Keywords);
        Message.Next (Check_Block.Arguments);
    end Get_Next_Keyword;

    procedure Check_Tantque_Msg (Msg_Kw : in out Message.Selector;
                                 Msg_Arg : in out Parameters.List;
                                 Check_Block : in out Size;
                                 Is_It : in out Boolean;
                                 Back_Object : out Object.Reference) is
        One_Arg_Selector : One_Argument_Message;
        Interpret_Yourself : Scanner.Lexeme :=
           Bounded_String.Value ("VALEUR", Custom.String_Max_Length);
        Result : Object.Reference;
        Is_Tqvrai : Boolean;
        Save_Current_Block : Size;
    begin  
        Trace.Display ("block_class.Check_Tantque_Msg");
        Is_It := False;
        if Message.Arg_Number (Msg_Kw) = 1 then
            One_Arg_Selector := Convert_To_One_Arg_Msg (Message.Value (Msg_Kw));
            case One_Arg_Selector is
                when Tant_Que_Vrai =>
                    Is_It := True;
                    Is_Tqvrai := True;
                when Tant_Que_Faux =>
                    Is_It := True;
                    Is_Tqvrai := False;
                when Nul =>
                    null;
            end case;
            if Is_It then
                loop  
                    Save_Current_Block := Current_Block;  
                    Current_Block := Check_Block;
                    Result := Block.Interpret (Blocks (Check_Block).Parse_Node);
                    Current_Block := Save_Current_Block;
                    case Object.Get_Class (Result) is
                        when Object.Booleen =>
                            exit when (Is_Tqvrai and
                                       Object.Equal (Result,
                                                     Boolean_Class.False)) or
                                      ((not Is_Tqvrai) and
                                       Object.Equal (Result,
                                                     Boolean_Class.True));
                            case Object.Get_Class
                                    (Parameters.Value (Msg_Arg)) is
                                when Object.Bloc =>
                                    Back_Object :=
                                       Send (Parameters.Value (Msg_Arg),
                                             Interpret_Yourself);
                                when others =>
                                    raise
                                       Errors.
                                          Block_Argument_Required_For_Tantque_Msg;
                            end case;
                        when others =>
                            raise Errors.Tantque_Msg_To_Non_Boolean_Block;
                    end case;
                end loop;
            end if;
        else
            Is_It := False;
        end if;
    end Check_Tantque_Msg;


    function Send (To_Object : Object.Reference; The_Message : Scanner.Lexeme)
                  return Object.Reference is
        Current_Message : Unary_Message := Nul;
        Index, Save_Current_Block : Size;
        Current_Entexte : Scanner.Lexeme;
    begin
        Trace.Display ("block_class.send (message unaire)");
        Current_Message := Convert_To_Unary (The_Message);
        case Current_Message is
            when Nul =>
                raise Errors.Unknown_Message_For_Block;
            when Valeur =>
                Index := Size (Object.Get_Id (To_Object));
                if (Message.Is_Empty (Blocks (Index).Keywords)) then
                    Save_Current_Block := Current_Block;
                    Current_Block := Index;
                    return Block.Interpret (Blocks (Index).Parse_Node);
                    Current_Block := Save_Current_Block;
                else
                    raise Errors.Unary_Message_To_Block_With_Arguments;
                end if;
            when En_Texte =>
                Bounded_String.Append
                   (Current_Entexte, Bounded_String.Value
                                        ("Bloc no", Custom.String_Max_Length));
                Bounded_String.Append
                   (Current_Entexte, Integer'Image (Object.Get_Id (To_Object)));
                return String_Class.Create (Current_Entexte);
        end case;
        return To_Object;
    end Send;

    procedure Send (To_Object : Object.Reference;
                    The_Message : in out Message.Selector;
                    With_Arguments : in out Parameters.List;
                    Back_Object : out Object.Reference) is
        Index, Save_Current_Block : Size;
        Result : Object.Reference;
        It_Is : Boolean;
    begin
        Trace.Display ("block_class.send (message a mots cles)");
        Index := Size (Object.Get_Id (To_Object));
        Get_First_Keyword (The_Message, With_Arguments, Blocks (Index));
        Check_Tantque_Msg (The_Message, With_Arguments, Index, It_Is, Result);
        if It_Is then
            Back_Object := Result;
        else
            if Same_Selector_Length (The_Message, Blocks (Index)) then
                while not Message.Done (The_Message) loop  
                    if Matching_Keyword (The_Message, Blocks (Index)) then
                        Set_Argument_Value
                           (Message.Value (Blocks (Index).Arguments),
                            Parameters.Value (With_Arguments), Blocks (Index));
                    else
                        raise Errors.Inconsistent_Msg_Selector_For_Block;
                    end if;
                    Get_Next_Keyword
                       (The_Message, With_Arguments, Blocks (Index));
                end loop;
                Save_Current_Block := Current_Block;
                Current_Block := Index;
                Back_Object := Block.Interpret (Blocks (Index).Parse_Node);
                Current_Block := Save_Current_Block;
            else
                Invalid_Arg_Number (The_Message, Blocks (Index));
            end if;
        end if;
    end Send;


end Block_Class;