⟦dd4f80529⟧

E3 Source Code



with Ada_Program;
with Declarations;
with Compilation_Units;
with Statements;
with Io;
with String_Utilities;
with Generic_List_Sorter;
procedure Glance (At_Unit          : String  := "<IMAGE>";
                  Show_Declaration : Boolean := False;
                  Subprograms      : Boolean := True;
                  Types            : Boolean := True;
                  Objects          : Boolean := True;
                  Containing       : String  := "";
                  Sorted           : Boolean := False) is

    package Ap   renames Ada_Program;
    package Decl renames Declarations;
    package Su   renames String_Utilities;

    Source      : Ap.Element;
    Die_Quietly : exception;

    procedure Error (Line : String);

    function  Discard (E : Ap.Element) return Boolean;
    procedure Filter_List is new Ap.Filter (Discard);

    function  "<=" (X, Y : Ap.Element) return Boolean;
    procedure Sort_List is new Generic_List_Sorter
                                  (Ap.Element, Ap.Element_List,
                                   Ap.Nil_List, Ap.Reset, Ap.Done,
                                   Ap.Value, Ap.Next, Ap.Append);

    procedure Process_Next_Level (E : Ap.Element);

    procedure Display (Dcl : Ap.Element) is
        It : Ap.Line_Iterator := Ap.Image (Dcl);
    begin  
        while Su.Strip_Leading (Ap.Value (It)) = "" loop
            Ap.Next (It);
        end loop;
        if Decl.Is_Package (Dcl) then
            Io.Put_Line (Ap.Value (It));
            Process_Next_Level (Dcl);
        elsif Show_Declaration then
            while not Ap.Done (It) loop
                Io.Put_Line (Ap.Value (It));
                Ap.Next (It);
            end loop;
        else
            Io.Put_Line (Ap.Value (It));
        end if;
    end Display;

    procedure Process_Next_Level (E : Ap.Element) is
        Entry_List : Ap.Element_List := Ap.Nil_List;
        Temp_List  : Ap.Element_ist := Ap.Nil_List;  
    begin

-- 1. Collect generic formal parameters
        if Decl.Is_Generic (E) then
            Ap.Copy (From_Iter => Decl.Generic_Parameters (E),
                     To_List   => Temp_List);
            Ap.Append (Temp_List, To_List => Entry_List);
        end if;

-- 2. Collect all declarations of visible part
        Temp_List := Ap.Nil_List;
        if Decl.Is_Subprogram (E) and then not Decl.Is_Visible (E) then
            Ap.Copy (From_Iter => Statements.Declarative_Items
                                     (Decl.Subprogram_Block (E)),
                     To_List   => Temp_List);
        elsif Decl.Is_Generic (E) then
            Error
               ("problem now with generic. wait for next release of LRM_interface");
        else
            Ap.Copy (From_Iter => Decl.Visible_Part_Declarations (E),
                     To_List   => Temp_List);
        end if;
        Ap.Append (Temp_List, To_List => Entry_List);

-- 3. Eliminate the noise (pragmas, context_clauses...)
        Temp_List := Ap.Nil_List;
        Filter_List (Entry_List, Temp_List);

-- 4. If user wants, sort the list alphabetically
        if Sorted then
            Sort_List (Temp_List);
        end if;
        Ap.Copy (Temp_List, Entry_List);

-- 5. And now, process all entries in the list
        while not Ap.Done (Entry_List) loop  
            Display (Ap.Value (Entry_List));
            Ap.Next (Entry_List);
        end loop;
    end Process_Next_Level;
--------------------------------------------------------------------------
--  This is the function used for sorting the list of declarations
    function "<=" (X, Y : Ap.Element) return Boolean is
    begin
        if Decl.Is_Package (X) xor Decl.Is_Package (Y) then
            return Decl.Is_Package (Y);
        else
            return String_Utilities.Less_Than (Decl.Name (X), Decl.Name (Y));
        end if;
    end "<=";

--  This is the function used to filter undesirable ada_program.elements
    function Discard (E : Ap.Element) return Boolean is
        function "=" (X, Y : Ap.Element_Kinds) return Boolean renames Ap."=";
    begin
        if Ap.Kind (E) = Ap.A_Declaration then  
            if Containing /= "" then
                if Su.Locate (Containing, Decl.Name (E)) = 0 then
                    return True;
                end if;
            end if;
            case Decl.Kind (E) is
                when Decl.A_Variable_Declaration ..
                        Decl.A_Real_Number_Declaration =>
                    return not Objects;
                when Decl.A_Type_Declaration .. Decl.A_Subtype_Declaration =>
                    return not Types;
                when Decl.A_Procedure_Declaration |
                     Decl.A_Function_Body_Declaration =>
                    return not Subprograms;
                when Decl.A_Package_Declaration ..
                        Decl.A_Package_Body_Declaration =>
                    return False;
                when others =>
                    return True;
            end case;
        else
            return True;
        end if;

    end Discard;

    procedure Error (Line : String) is
    begin
        Io.Put_Line (Io.Standard_Error, Line);
    end Error;

begin
    begin
        Source := Compilation_Units.Parent_Compilation_Unit
                     (Ap.Conversion.Resolve (At_Unit));
    exception
        when others =>
            Error ("unable to resolve: " & At_Unit);
            raise Die_Quietly;
    end;
    case Ap.Kind (Source) is
        when Ap.A_Compilation_Unit =>
            Source := Compilation_Units.Unit_Declaration (Source);
            if Decl.Is_Subprogram (Source) then  
                Display (Source);
                Process_Next_Level (Source);
            else  
                Display (Source);
            end if;
        when Ap.A_Declaration =>
            Display (Source);
        when others =>
            Error ("Cannot have a look at that");
    end case;  
exception  
    when Die_Quietly =>
        null;
    when others =>
        raise;  
end Glance;
DataMuseum.dk

Rational R1000/400

⟦dd4f80529⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
