-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
- Max_Line_Length : constant := 255;
- -- Maximum length of a line. This is chosen to be compatible with older
- -- versions of GNAT that had a strict limit on the maximum line length.
-
- Column : Natural := 0;
- -- Column number of the last character in the line. Used to avoid
- -- outputting lines longer than Max_Line_Length.
-
- First_With_In_List : Boolean := True;
- -- Indicate that the next with clause is first in a list such as
- -- with "A", "B";
- -- First_With_In_List will be True for "A", but not for "B".
-
procedure Indicate_Tested (Kind : Project_Node_Kind);
-- Set the corresponding component of array Not_Tested to False.
-- Only called by pragmas Debug.
procedure Pretty_Print
(Project : Prj.Tree.Project_Node_Id;
In_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Increment : Positive := 3;
- Eliminate_Empty_Case_Constructions : Boolean := False;
- Minimize_Empty_Lines : Boolean := False;
- W_Char : Write_Char_Ap := null;
- W_Eol : Write_Eol_Ap := null;
- W_Str : Write_Str_Ap := null;
+ Increment : Positive := 3;
+ Eliminate_Empty_Case_Constructions : Boolean := False;
+ Minimize_Empty_Lines : Boolean := False;
+ W_Char : Write_Char_Ap := null;
+ W_Eol : Write_Eol_Ap := null;
+ W_Str : Write_Str_Ap := null;
Backward_Compatibility : Boolean;
- Id : Prj.Project_Id := Prj.No_Project)
+ Id : Prj.Project_Id := Prj.No_Project;
+ Max_Line_Length : Max_Length_Of_Line :=
+ Max_Length_Of_Line'Last)
is
procedure Print (Node : Project_Node_Id; Indent : Natural);
-- A recursive procedure that traverses a project file tree and outputs
-- is used when printing attributes, since in nested packages they
-- need to use a fully qualified name.
- procedure Output_Attribute_Name (Name : Name_Id);
+ procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural);
-- Outputs an attribute name, taking into account the value of
-- Backward_Compatibility.
- procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
+ procedure Output_Name
+ (Name : Name_Id;
+ Indent : Natural;
+ Capitalize : Boolean := True);
-- Outputs a name
procedure Start_Line (Indent : Natural);
-- Outputs the indentation at the beginning of the line
- procedure Output_String (S : Name_Id);
- procedure Output_String (S : Path_Name_Type);
+ procedure Output_String (S : Name_Id; Indent : Natural);
+ procedure Output_String (S : Path_Name_Type; Indent : Natural);
-- Outputs a string using the default output procedures
procedure Write_Empty_Line (Always : Boolean := False);
-- Outputs an empty line, only if the previous line was not empty
- -- already and either Always is True or Minimize_Empty_Lines is False.
+ -- already and either Always is True or Minimize_Empty_Lines is
+ -- False.
procedure Write_Line (S : String);
-- Outputs S followed by a new line
- procedure Write_String (S : String; Truncated : Boolean := False);
+ procedure Write_String
+ (S : String;
+ Indent : Natural;
+ Truncated : Boolean := False);
-- Outputs S using Write_Str, starting a new line if line would
-- become too long, when Truncated = False.
-- When Truncated = True, only the part of the string that can fit on
procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
Write_Char : Write_Char_Ap := Output.Write_Char'Access;
- Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
- Write_Str : Write_Str_Ap := Output.Write_Str'Access;
+ Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
+ Write_Str : Write_Str_Ap := Output.Write_Str'Access;
-- These three access to procedure values are used for the output
Last_Line_Is_Empty : Boolean := False;
-- Used to avoid two consecutive empty lines
+ Column : Natural := 0;
+ -- Column number of the last character in the line. Used to avoid
+ -- outputting lines longer than Max_Line_Length.
+
+ First_With_In_List : Boolean := True;
+ -- Indicate that the next with clause is first in a list such as
+ -- with "A", "B";
+ -- First_With_In_List will be True for "A", but not for "B".
+
---------------------------
-- Output_Attribute_Name --
---------------------------
- procedure Output_Attribute_Name (Name : Name_Id) is
+ procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural) is
begin
if Backward_Compatibility then
case Name is
when Snames.Name_Spec =>
- Output_Name (Snames.Name_Specification);
+ Output_Name (Snames.Name_Specification, Indent);
when Snames.Name_Spec_Suffix =>
- Output_Name (Snames.Name_Specification_Suffix);
+ Output_Name (Snames.Name_Specification_Suffix, Indent);
when Snames.Name_Body =>
- Output_Name (Snames.Name_Implementation);
+ Output_Name (Snames.Name_Implementation, Indent);
when Snames.Name_Body_Suffix =>
- Output_Name (Snames.Name_Implementation_Suffix);
+ Output_Name (Snames.Name_Implementation_Suffix, Indent);
when others =>
- Output_Name (Name);
+ Output_Name (Name, Indent);
end case;
else
- Output_Name (Name);
+ Output_Name (Name, Indent);
end if;
end Output_Attribute_Name;
-- Output_Name --
-----------------
- procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
+ procedure Output_Name
+ (Name : Name_Id;
+ Indent : Natural;
+ Capitalize : Boolean := True)
+ is
Capital : Boolean := Capitalize;
begin
+ if Column = 0 and then Indent /= 0 then
+ Start_Line (Indent + Increment);
+ end if;
+
Get_Name_String (Name);
-- If line would become too long, create new line
if Column + Name_Len > Max_Line_Length then
Write_Eol.all;
Column := 0;
+
+ if Indent /= 0 then
+ Start_Line (Indent + Increment);
+ end if;
end if;
for J in 1 .. Name_Len loop
-- Output_String --
-------------------
- procedure Output_String (S : Name_Id) is
+ procedure Output_String (S : Name_Id; Indent : Natural) is
begin
+ if Column = 0 and then Indent /= 0 then
+ Start_Line (Indent + Increment);
+ end if;
+
Get_Name_String (S);
- -- If line could become too long, create new line.
- -- Note that the number of characters on the line could be
- -- twice the number of character in the string (if every
- -- character is a '"') plus two (the initial and final '"').
+ -- If line could become too long, create new line. Note that the
+ -- number of characters on the line could be twice the number of
+ -- character in the string (if every character is a '"') plus two
+ -- (the initial and final '"').
if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
Write_Eol.all;
Column := 0;
+
+ if Indent /= 0 then
+ Start_Line (Indent + Increment);
+ end if;
end if;
Write_Char ('"');
Column := Column + 1;
end if;
- -- If the string does not fit on one line, cut it in parts
- -- and concatenate.
+ -- If the string does not fit on one line, cut it in parts and
+ -- concatenate.
if J < Name_Len and then Column >= Max_Line_Length then
Write_Str (""" &");
Write_Eol.all;
+ Column := 0;
+ Start_Line (Indent + Increment);
Write_Char ('"');
- Column := 1;
+ Column := Column + 1;
end if;
end loop;
Column := Column + 1;
end Output_String;
- procedure Output_String (S : Path_Name_Type) is
+ procedure Output_String (S : Path_Name_Type; Indent : Natural) is
begin
- Output_String (Name_Id (S));
+ Output_String (Name_Id (S), Indent);
end Output_String;
----------------
begin
if Value /= No_Name then
- Write_String (" --");
- Write_String (Get_Name_String (Value), Truncated => True);
+ Write_String (" --", 0);
+ Write_String (Get_Name_String (Value), 0, Truncated => True);
end if;
Write_Line ("");
procedure Write_Line (S : String) is
begin
- Write_String (S);
+ Write_String (S, 0);
Last_Line_Is_Empty := False;
Write_Eol.all;
Column := 0;
-- Write_String --
------------------
- procedure Write_String (S : String; Truncated : Boolean := False) is
+ procedure Write_String
+ (S : String;
+ Indent : Natural;
+ Truncated : Boolean := False) is
Length : Natural := S'Length;
begin
+ if Column = 0 and then Indent /= 0 then
+ Start_Line (Indent + Increment);
+ end if;
+
-- If the string would not fit on the line,
-- start a new line.
else
Write_Eol.all;
Column := 0;
+
+ if Indent /= 0 then
+ Start_Line (Indent + Increment);
+ end if;
end if;
end if;
-- Print --
-----------
- procedure Print (Node : Project_Node_Id; Indent : Natural) is
+ procedure Print (Node : Project_Node_Id; Indent : Natural) is
begin
if Present (Node) then
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Write_String ("project ");
+ Write_String ("project ", Indent);
if Id /= Prj.No_Project then
- Output_Name (Id.Display_Name);
+ Output_Name (Id.Display_Name, Indent);
else
- Output_Name (Name_Of (Node, In_Tree));
+ Output_Name (Name_Of (Node, In_Tree), Indent);
end if;
-- Check if this project extends another project
if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
- Write_String (" extends ");
+ Write_String (" extends ", Indent);
if Is_Extending_All (Node, In_Tree) then
- Write_String ("all ");
+ Write_String ("all ", Indent);
end if;
- Output_String (Extended_Project_Path_Of (Node, In_Tree));
+ Output_String
+ (Extended_Project_Path_Of (Node, In_Tree),
+ Indent);
end if;
- Write_String (" is");
+ Write_String (" is", Indent);
Write_End_Of_Line_Comment (Node);
Print
(First_Comment_After (Node, In_Tree), Indent + Increment);
(First_Comment_Before_End (Node, In_Tree),
Indent + Increment);
Start_Line (Indent);
- Write_String ("end ");
+ Write_String ("end ", Indent);
if Id /= Prj.No_Project then
- Output_Name (Id.Display_Name);
+ Output_Name (Id.Display_Name, Indent);
else
- Output_Name (Name_Of (Node, In_Tree));
+ Output_Name (Name_Of (Node, In_Tree), Indent);
end if;
Write_Line (";");
if Non_Limited_Project_Node_Of (Node, In_Tree) =
Empty_Node
then
- Write_String ("limited ");
+ Write_String ("limited ", Indent);
end if;
- Write_String ("with ");
+ Write_String ("with ", Indent);
end if;
- Output_String (String_Value_Of (Node, In_Tree));
+ Output_String (String_Value_Of (Node, In_Tree), Indent);
if Is_Not_Last_In_List (Node, In_Tree) then
- Write_String (", ");
+ Write_String (", ", Indent);
First_With_In_List := False;
else
- Write_String (";");
+ Write_String (";", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node, In_Tree), Indent);
First_With_In_List := True;
Write_Empty_Line (Always => True);
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Write_String ("package ");
- Output_Name (Name_Of (Node, In_Tree));
+ Write_String ("package ", Indent);
+ Output_Name (Name_Of (Node, In_Tree), Indent);
if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
Empty_Node
then
- Write_String (" renames ");
+ Write_String (" renames ", Indent);
Output_Name
(Name_Of
(Project_Of_Renamed_Package_Of (Node, In_Tree),
- In_Tree));
- Write_String (".");
- Output_Name (Name_Of (Node, In_Tree));
- Write_String (";");
+ In_Tree),
+ Indent);
+ Write_String (".", Indent);
+ Output_Name (Name_Of (Node, In_Tree), Indent);
+ Write_String (";", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After_End (Node, In_Tree), Indent);
else
- Write_String (" is");
+ Write_String (" is", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node, In_Tree),
Indent + Increment);
Print (First_Comment_Before_End (Node, In_Tree),
Indent + Increment);
Start_Line (Indent);
- Write_String ("end ");
- Output_Name (Name_Of (Node, In_Tree));
+ Write_String ("end ", Indent);
+ Output_Name (Name_Of (Node, In_Tree), Indent);
Write_Line (";");
Print (First_Comment_After_End (Node, In_Tree), Indent);
Write_Empty_Line;
pragma Debug (Indicate_Tested (N_String_Type_Declaration));
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Write_String ("type ");
- Output_Name (Name_Of (Node, In_Tree));
+ Write_String ("type ", Indent);
+ Output_Name (Name_Of (Node, In_Tree), Indent);
Write_Line (" is");
Start_Line (Indent + Increment);
- Write_String ("(");
+ Write_String ("(", Indent);
declare
String_Node : Project_Node_Id :=
begin
while Present (String_Node) loop
- Output_String (String_Value_Of (String_Node, In_Tree));
+ Output_String
+ (String_Value_Of (String_Node, In_Tree),
+ Indent);
String_Node :=
Next_Literal_String (String_Node, In_Tree);
if Present (String_Node) then
- Write_String (", ");
+ Write_String (", ", Indent);
end if;
end loop;
end;
- Write_String (");");
+ Write_String (");", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node, In_Tree), Indent);
when N_Literal_String =>
pragma Debug (Indicate_Tested (N_Literal_String));
- Output_String (String_Value_Of (Node, In_Tree));
+ Output_String (String_Value_Of (Node, In_Tree), Indent);
if Source_Index_Of (Node, In_Tree) /= 0 then
- Write_String (" at");
- Write_String (Source_Index_Of (Node, In_Tree)'Img);
+ Write_String (" at", Indent);
+ Write_String
+ (Source_Index_Of (Node, In_Tree)'Img,
+ Indent);
end if;
when N_Attribute_Declaration =>
pragma Debug (Indicate_Tested (N_Attribute_Declaration));
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Write_String ("for ");
- Output_Attribute_Name (Name_Of (Node, In_Tree));
+ Write_String ("for ", Indent);
+ Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
- Write_String (" (");
+ Write_String (" (", Indent);
Output_String
- (Associative_Array_Index_Of (Node, In_Tree));
+ (Associative_Array_Index_Of (Node, In_Tree),
+ Indent);
if Source_Index_Of (Node, In_Tree) /= 0 then
- Write_String (" at");
- Write_String (Source_Index_Of (Node, In_Tree)'Img);
+ Write_String (" at", Indent);
+ Write_String
+ (Source_Index_Of (Node, In_Tree)'Img,
+ Indent);
end if;
- Write_String (")");
+ Write_String (")", Indent);
end if;
- Write_String (" use ");
+ Write_String (" use ", Indent);
if Present (Expression_Of (Node, In_Tree)) then
Print (Expression_Of (Node, In_Tree), Indent);
Output_Name
(Name_Of
(Associative_Project_Of (Node, In_Tree),
- In_Tree));
+ In_Tree),
+ Indent);
if
Present (Associative_Package_Of (Node, In_Tree))
then
- Write_String (".");
+ Write_String (".", Indent);
Output_Name
(Name_Of
(Associative_Package_Of (Node, In_Tree),
- In_Tree));
+ In_Tree),
+ Indent);
end if;
elsif
Output_Name
(Name_Of
(Associative_Package_Of (Node, In_Tree),
- In_Tree));
+ In_Tree),
+ Indent);
end if;
- Write_String ("'");
- Output_Attribute_Name (Name_Of (Node, In_Tree));
+ Write_String ("'", Indent);
+ Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
end if;
- Write_String (";");
+ Write_String (";", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node, In_Tree), Indent);
(Indicate_Tested (N_Typed_Variable_Declaration));
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Output_Name (Name_Of (Node, In_Tree));
- Write_String (" : ");
+ Output_Name (Name_Of (Node, In_Tree), Indent);
+ Write_String (" : ", Indent);
Output_Name
- (Name_Of (String_Type_Of (Node, In_Tree), In_Tree));
- Write_String (" := ");
+ (Name_Of (String_Type_Of (Node, In_Tree), In_Tree),
+ Indent);
+ Write_String (" := ", Indent);
Print (Expression_Of (Node, In_Tree), Indent);
- Write_String (";");
+ Write_String (";", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node, In_Tree), Indent);
pragma Debug (Indicate_Tested (N_Variable_Declaration));
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Output_Name (Name_Of (Node, In_Tree));
- Write_String (" := ");
+ Output_Name (Name_Of (Node, In_Tree), Indent);
+ Write_String (" := ", Indent);
Print (Expression_Of (Node, In_Tree), Indent);
- Write_String (";");
+ Write_String (";", Indent);
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node, In_Tree), Indent);
Term := Next_Term (Term, In_Tree);
if Present (Term) then
- Write_String (" & ");
+ Write_String (" & ", Indent);
end if;
end loop;
end;
when N_Literal_String_List =>
pragma Debug (Indicate_Tested (N_Literal_String_List));
- Write_String ("(");
+ Write_String ("(", Indent);
declare
Expression : Project_Node_Id :=
Next_Expression_In_List (Expression, In_Tree);
if Present (Expression) then
- Write_String (", ");
+ Write_String (", ", Indent);
end if;
end loop;
end;
- Write_String (")");
+ Write_String (")", Indent);
when N_Variable_Reference =>
pragma Debug (Indicate_Tested (N_Variable_Reference));
if Present (Project_Node_Of (Node, In_Tree)) then
Output_Name
- (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
- Write_String (".");
+ (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree),
+ Indent);
+ Write_String (".", Indent);
end if;
if Present (Package_Node_Of (Node, In_Tree)) then
Output_Name
- (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
- Write_String (".");
+ (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
+ Indent);
+ Write_String (".", Indent);
end if;
- Output_Name (Name_Of (Node, In_Tree));
+ Output_Name (Name_Of (Node, In_Tree), Indent);
when N_External_Value =>
pragma Debug (Indicate_Tested (N_External_Value));
- Write_String ("external (");
+ Write_String ("external (", Indent);
Print (External_Reference_Of (Node, In_Tree), Indent);
if Present (External_Default_Of (Node, In_Tree)) then
- Write_String (", ");
+ Write_String (", ", Indent);
Print (External_Default_Of (Node, In_Tree), Indent);
end if;
- Write_String (")");
+ Write_String (")", Indent);
when N_Attribute_Reference =>
pragma Debug (Indicate_Tested (N_Attribute_Reference));
and then Project_Node_Of (Node, In_Tree) /= Project
then
Output_Name
- (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
+ (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree),
+ Indent);
if Present (Package_Node_Of (Node, In_Tree)) then
- Write_String (".");
+ Write_String (".", Indent);
Output_Name
- (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
+ (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
+ Indent);
end if;
elsif Present (Package_Node_Of (Node, In_Tree)) then
Output_Name
- (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
+ (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
+ Indent);
else
- Write_String ("project");
+ Write_String ("project", Indent);
end if;
- Write_String ("'");
- Output_Attribute_Name (Name_Of (Node, In_Tree));
+ Write_String ("'", Indent);
+ Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
declare
Index : constant Name_Id :=
begin
if Index /= No_Name then
- Write_String (" (");
- Output_String (Index);
- Write_String (")");
+ Write_String (" (", Indent);
+ Output_String (Index, Indent);
+ Write_String (")", Indent);
end if;
end;
Write_Empty_Line;
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Write_String ("case ");
+ Write_String ("case ", Indent);
Print
(Case_Variable_Reference_Of (Node, In_Tree),
Indent);
- Write_String (" is");
+ Write_String (" is", Indent);
Write_End_Of_Line_Comment (Node);
Print
(First_Comment_After (Node, In_Tree),
Write_Empty_Line;
Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (Indent);
- Write_String ("when ");
+ Write_String ("when ", Indent);
if No (First_Choice_Of (Node, In_Tree)) then
- Write_String ("others");
+ Write_String ("others", Indent);
else
declare
Label := Next_Literal_String (Label, In_Tree);
if Present (Label) then
- Write_String (" | ");
+ Write_String (" | ", Indent);
end if;
end loop;
end;
end if;
- Write_String (" =>");
+ Write_String (" =>", Indent);
Write_End_Of_Line_Comment (Node);
Print
(First_Comment_After (Node, In_Tree),
end if;
Start_Line (Indent);
- Write_String ("--");
+ Write_String ("--", Indent);
Write_String
(Get_Name_String (String_Value_Of (Node, In_Tree)),
+ Indent,
Truncated => True);
Write_Line ("");
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
-- is conservative and definitely correct.
-- We only do this at the outer (library) level non-generic packages.
- -- The reason is simply to cut down on the number of external symbols
- -- generated, so this is simply an optimization of the efficiency
- -- of the compilation process. It has no other effect.
+ -- The reason is simply to cut down on the number of global symbols
+ -- generated, which has a double effect: (1) to make the compilation
+ -- process more efficient and (2) to give the code generator more
+ -- freedom to optimize within each unit, especially subprograms.
if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
and then not Is_Generic_Unit (Spec_Id)
Outer : Boolean)
return Boolean;
-- Traverse the given list of declarations in reverse order.
- -- Return True as soon as a referencer is reached. Return False if
- -- none is found. The Outer parameter is True for the outer level
- -- call, and False for inner level calls for nested packages. If
- -- Outer is True, then any entities up to the point of hitting a
- -- referencer get their Is_Public flag cleared, so that the
- -- entities will be treated as static entities in the C sense, and
- -- need not have fully qualified names. For inner levels, we need
- -- all names to be fully qualified to deal with the same name
- -- appearing in parallel packages (right now this is tied to their
- -- being external).
+ -- Return True if a referencer is present. Return False if none is
+ -- found. The Outer parameter is True for the outer level call and
+ -- False for inner level calls for nested packages. If Outer is
+ -- True, then any entities up to the point of hitting a referencer
+ -- get their Is_Public flag cleared, so that the entities will be
+ -- treated as static entities in the C sense, and need not have
+ -- fully qualified names. Furthermore, if the referencer is an
+ -- inlined subprogram that doesn't reference other subprograms,
+ -- we keep clearing the Is_Public flag on subprograms. For inner
+ -- levels, we need all names to be fully qualified to deal with
+ -- the same name appearing in parallel packages (right now this
+ -- is tied to their being external).
--------------------
-- Has_Referencer --
Outer : Boolean)
return Boolean
is
+ Has_Referencer_Except_For_Subprograms : Boolean := False;
D : Node_Id;
E : Entity_Id;
K : Node_Kind;
S : Entity_Id;
+ function Check_Subprogram_Ref (N : Node_Id)
+ return Traverse_Result;
+ -- Look for references to subprograms
+
+ --------------------------
+ -- Check_Subprogram_Ref --
+ --------------------------
+
+ function Check_Subprogram_Ref (N : Node_Id)
+ return Traverse_Result
+ is
+ V : Node_Id;
+
+ begin
+
+ -- Check name of procedure or function calls
+
+ if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
+ and then Is_Entity_Name (Name (N))
+ then
+ return Abandon;
+ end if;
+
+ -- Check prefix of attribute references
+
+ if Nkind (N) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (N))
+ and then Present (Entity (Prefix (N)))
+ and then Ekind (Entity (Prefix (N))) in Subprogram_Kind
+ then
+ return Abandon;
+ end if;
+
+ -- Check value of constants
+
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) = E_Constant
+ then
+ V := Constant_Value (Entity (N));
+ if Present (V)
+ and then not Compile_Time_Known_Value_Or_Aggr (V)
+ then
+ return Abandon;
+ end if;
+ end if;
+
+ return OK;
+
+ end Check_Subprogram_Ref;
+
+ function Check_Subprogram_Refs is
+ new Traverse_Func (Check_Subprogram_Ref);
+
begin
if No (L) then
return False;
if K in N_Body_Stub then
return True;
+ -- Processing for subprogram bodies
+
elsif K = N_Subprogram_Body then
if Acts_As_Spec (D) then
E := Defining_Entity (D);
-- of accessing global entities.
if Has_Pragma_Inline (E) then
- return True;
+ if Outer
+ and then Check_Subprogram_Refs (D) = OK
+ then
+ Has_Referencer_Except_For_Subprograms := True;
+ else
+ return True;
+ end if;
else
Set_Is_Public (E, False);
end if;
else
E := Corresponding_Spec (D);
- if Present (E)
- and then (Is_Generic_Unit (E)
- or else Has_Pragma_Inline (E)
- or else Is_Inlined (E))
- then
- return True;
+ if Present (E) then
+
+ -- A generic subprogram body acts as a referencer
+
+ if Is_Generic_Unit (E) then
+ return True;
+ end if;
+
+ if Has_Pragma_Inline (E) or else Is_Inlined (E) then
+ if Outer
+ and then Check_Subprogram_Refs (D) = OK
+ then
+ Has_Referencer_Except_For_Subprograms := True;
+ else
+ return True;
+ end if;
+ end if;
end if;
end if;
-- Processing for package bodies
elsif K = N_Package_Body
+ and then not Has_Referencer_Except_For_Subprograms
and then Present (Corresponding_Spec (D))
then
E := Corresponding_Spec (D);
-- Processing for package specs, recurse into declarations.
-- Again we skip this for the case of generic instances.
- elsif K = N_Package_Declaration then
+ elsif K = N_Package_Declaration
+ and then not Has_Referencer_Except_For_Subprograms
+ then
S := Specification (D);
if not Is_Generic_Unit (Defining_Entity (S)) then
E := Defining_Entity (D);
if Outer
+ and then (not Has_Referencer_Except_For_Subprograms
+ or else K = N_Subprogram_Declaration)
and then not Is_Imported (E)
and then not Is_Exported (E)
and then No (Interface_Name (E))
Prev (D);
end loop;
- return False;
+ return Has_Referencer_Except_For_Subprograms;
end Has_Referencer;
-- Start of processing for Make_Non_Public_Where_Possible
OSDN Git Service
