⟦42948c4ad⟧

E3 Source Code



with Log;
with Profile;
with Common;
with Pragmas;
with Add_Hyper_Table;
with Create_Null_Document;
with Lrm_Utilities;
with Lrm_Renames;
use Lrm_Renames;
with Directory_Renames;
use Directory_Renames;
with Errors;
with Simple_Status;
package body Find_Pragmas is


    procedure Add (Units       :        String := "";
                   To_Document : in out Abstract_Document.Handle;
                   Response    :        String := "<PROFILE>") is

        Units_Iter       : Object.Iterator := Naming.Resolution (Units);
        Parent_Id        : Ada.Element;
        Arguments        : Ada.Element_Iterator;
        Current_Argument : Ada.Element;

        type Columns is (Pragma_Name, Argument1, Argument2, Parent_Unit);

        function Is_Integer_Column (C : Columns) return Boolean is
        begin
            return False;
        end Is_Integer_Column;

        procedure Step_Parameters is
        begin
            if Ada.Done (Arguments) then
                Current_Argument := Ada.Nil_Element;
            else
                Current_Argument := Ada.Value (Arguments);
                Ada.Next (Arguments);
            end if;

        end Step_Parameters;

        function Is_Included (Elem : Ada.Element) return Boolean is
        begin
            case Ada.Kind (Elem) is
                when Ada.A_Pragma =>
                    Parent_Id := Lrm_Utilities.Comp_Unit_Id (Elem);
                    Arguments := Pragmas.Arguments (Elem);
                    Step_Parameters;

                    return True;
                when others =>
                    return False;
            end case;
        end Is_Included;

        function Image (Argument : Ada.Element) return String is
        begin
            if Ada.Is_Nil (Argument) then
                return "";
            else
                return Ada.Image (Argument);
            end if;
        end Image;

        function Column_Image (C : Columns; Elem : Ada.Element) return String is
        begin
            case C is
                when Pragma_Name =>
                    return Pragmas.Name (Elem);
                when Argument1 .. Argument2 =>
                    declare
                        Col_Image : constant String := Image (Current_Argument);
                    begin
                        Step_Parameters;
                        return (Col_Image);
                    end;

                when Parent_Unit =>
                    return Decls.Name (Parent_Id);
            end case;
        end Column_Image;

        function Explanation (C : Columns; Elem : Ada.Element) return String is
        begin
            case C is
                when Pragma_Name =>
                    return "Name of the pragma";
                when Argument1 =>
                    if not Ada.Is_Nil (Current_Argument) then
                        return "First argument of the pragma";
                    else
                        return "The pragma has no arguments";
                    end if;
                when Argument2 =>
                    if not Ada.Is_Nil (Current_Argument) then
                        return "Second argument of the pragma";
                    else
                        return "The pragma has no second argument";
                    end if;
                when Parent_Unit =>
                    return "Name of the unit containing the pragma";
            end case;

        end Explanation;

        procedure Linkage (C                :     Columns;
                           Elem             :     Ada.Element;
                           Linkage_Element  : out Ada.Element;
                           Linkage_Elements : out Ada.Element_List) is
        begin
            -- default values changed within the case statement as necessary
            Linkage_Element  := Ada.Nil_Element;
            Linkage_Element := Ada.Nil_List;

            case C is
                when Pragma_Name =>
                    Linkage_Element := Elem;
                when Argument1 .. Argument2 =>
                    Linkage_Element := Current_Argument;
                when Parent_Unit =>
                    Linkage_Element := Parent_Id;
            end case;
        end Linkage;

        procedure Add_Hyper_Table_To_Doc is
           new Add_Hyper_Table (Is_Included,  
                                Columns,  
                                Is_Integer_Column,  
                                Column_Image,  
                                Explanation,  
                                Linkage,  
                                Table_Title => "Pragmas");
    begin
        if Object.Is_Bad (Units_Iter) then
            Log.Put_Line (Units & " is not a valid pathname",
                          Profile.Error_Msg);
        else
            Add_Hyper_Table_To_Doc (Units_Iter, To_Document, Response);
        end if;
    end Add;

    procedure Display (Units             : String := "";
                       To_Preview_Object : String := "pragma_info";
                       Response          : String := "<PROFILE>") is
        Document  : Abstract_Document.Handle;
        Condition : Errors.Condition;
    begin

        Create_Null_Document (Named           => To_Preview_Object,
                              Error_Info      => Condition,
                              Document_Handle => Document);

        case Errors.Severity (Condition) is
            when Simple_Status.Problem | Simple_Status.Fatal =>
                Log.Put_Line ("Problem creating object " & To_Preview_Object &
                              ".  " & Errors.Info (Condition),
                              Profile.Error_Msg);
            when others =>

                Add (Units, Document, Response);

                Abstract_Document.Close (Document);

                Common.Definition (To_Preview_Object);

        end case;
    end Display;
end Find_Pragmas;
DataMuseum.dk

Rational R1000/400

⟦42948c4ad⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
