⟦1805d91e6⟧

E3 Source Code



with Io;
with Compilation_Units;
with Declarations;
with Statements;
with Names_And_Expressions;
package body Call_Tree_Queues is

    package Ap   renames Ada_Program;
    package Decl renames Declarations;
    package Stmt renames Statements;
    package Conv renames Ap.Conversion;
    package Expr renames Names_And_Expressions;
    function "=" (L, R : Decl.Declaration_Kinds) return Boolean
        renames Decl."=";

    type State_Record is
        record
            Transitive_Call_Tree : Queues.Queue;
            Current_Level        : Natural := 1;
        end record;

    procedure Clear_State (State : in out State_Record)  
                  is
    begin
        Queues.Make_Empty (State.Transitive_Call_Tree);
        State.Current_Level := 0;
    end Clear_State;

    function Is_In_State (State         :    State_Record;  
                          Subprogram_Id : in Ap.Element) return Boolean is
        function "=" (L, R : Ap.Element) return Boolean renames Ap."=";
        Subprograms_It : Queues.Iterator;
    begin
        Queues.Init (Subprograms_It, State.Transitive_Call_Tree);
        while not Queues.Done (Subprograms_It) loop
            if Subprogram_Id = Queues.Value (Subprograms_It).Subprogram_Id then
                return True;
            end if;
            Queues.Next (Subprograms_It);
        end loop;
        return False;
    end Is_In_State;

    procedure Push_Level (State : in out State_Record) is
    begin
        State.Current_Level := State.Current_Level + 1;
    end Push_Level;

    procedure Pop_Level (State : in out State_Record) is
    begin
        State.Current_Level := State.Current_Level - 1;
    end Pop_Level;

    procedure Append_State (Subprogram_Id : in Ap.Element;
                            To : in out State_Record;
                            Id_Previously_Existed : out Boolean) is

        In_Call_Tree : Boolean := Is_In_State (To, Subprogram_Id);

    begin
        Id_Previously_Existed := In_Call_Tree;
        Queues.Add (To.Transitive_Call_Tree,
                    Referenced_Subprogram'
                       (Subprogram_Id, not In_Call_Tree, To.Current_Level));
    end Append_State;

    function Normalize_Subprogram_Body
                (Element_That_Is_Close : Ap.Element) return Ap.Element is
        Result : Ap.Element;
    begin
        begin
            Result := Decl.Unit_Body (Element_That_Is_Close);
        exception
            when Ap.Inappropriate_Program_Element =>
                return Ap.Nil_Element;
        end;

        if not Ap.Is_Nil (Result) then
            case Decl.Kind (Result) is
                when Decl.A_Procedure_Body_Declaration |
                     Decl.A_Function_Body_Declaration =>
                    null;
                when others =>
                    Result := Ap.Nil_Element;
            end case;
        end if;
        return Result;
    end Normalize_Subprogram_Body;

    -- Loop through renames to obtain real declaration
    -- returns Spec declaration if it exists, otherwise returns Body decl
    function Resolve_Rename (Program_Element : Ap.Element)
                            return Ap.Element is separate;

    procedure Call_Tree_For_Iterator (Iter      : in     Ap.Element_Iterator;
                                      The_State : in out State_Record);


    procedure Recurse_Through_Subprogram (Called_Subprogram_Decl : Ap.Element;
                                          The_State : in out State_Record);


    procedure Pre_Op  (Program_Element :        Ap.Element;
                       State           : in out State_Record;
                       Control         : in out Ap.Traversal_Control);
    procedure Post_Op (Program_Element :        Ap.Element;
                       State           : in out State_Record;
                       Control         : in out Ap.Traversal_Control)

    procedure Construct_Call_Tree is
       new Ap.Depth_First_Traversal (State_Record, Pre_Op, Post_Op);


    procedure Pre_Op (Program_Element : Ap.Element;
                      State : in out State_Record;
                      Control : in out Ap.Traversal_Control) is separate;
    procedure Post_Op (Program_Element : Ap.Element;
                       State : in out State_Record;
                       Control : in out Ap.Traversal_Control) is separate;

    procedure Recurse_Through_Subprogram
                 (Called_Subprogram_Decl :        Ap.Element;
                  The_State              : in out State_Record) is separate;


    procedure Call_Tree_For_Iterator (Iter      : in     Ap.Element_Iterator;
                                      The_State : in out State_Record) is
        Local_Iter : Ap.Element_Iterator := Iter;
    begin
        while not Ap.Done (Local_Iter) loop
            declare
                Current : Ap.Element := Ap.Value (Local_Iter);
            begin
                Construct_Call_Tree (Root_Element => Ap.Value ((Local_Iter)),
                                     State => The_State,
                                     Major_Elements_Only => False);

            end;
            Ap.Next (Local_Iter);
        end loop;
    end Call_Tree_For_Iterator;


    function Tree_For (This_Subprogram_Body : Ada_Program.Element)
                      return Queue is separate;
end Call_Tree_Queues;
DataMuseum.dk

Rational R1000/400

⟦1805d91e6⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
