Skip to content

R
riscv-gcc-1
Commit 4f18d860 by Bob Duff Committed by Arnaud Charlet
Options

sem.adb (Semantics, [...]): Include dependents of bodies that are not included. 

2009-04-20  Bob Duff  <duff@adacore.com>

	* sem.adb (Semantics, Walk_Library_Items): Include dependents of bodies
	that are not included. This is necessary if the main unit is a generic
	instantiation.

	* gnat1drv.adb (Gnat1drv): Comment out the call to Check_Library_Items,
	because it doesn't work if -gnatn is used.

From-SVN: r146408
parent 451800a0
Showing with 123 additions and 37 deletions
gcc/ada/ChangeLog
2009-04-20 Bob Duff <duff@adacore.com>
* sem.adb (Semantics, Walk_Library_Items): Include dependents of bodies
that are not included. This is necessary if the main unit is a generic
instantiation.
* gnat1drv.adb (Gnat1drv): Comment out the call to Check_Library_Items,
because it doesn't work if -gnatn is used.
2009-04-20 Ed Schonberg <schonberg@adacore.com>
* rtsfind.adb (RTE, RTE_Record_Component): In
gcc/ada/gnat1drv.adb
......@@ -92,6 +92,8 @@ procedure Gnat1drv is
procedure Check_Library_Items;
-- For debugging -- checks the behavior of Walk_Library_Items
pragma Warnings (Off, Check_Library_Items);
-- In case the call below is commented out
--------------------
-- Check_Bad_Body --
......@@ -738,7 +740,9 @@ begin
Namet.Lock;
Stringt.Lock;
pragma Debug (Check_Library_Items);
-- ???pragma Debug (Check_Library_Items);
-- Commented out, because it currently does not work if the -gnatn
-- switch (back end inlining) is used.
-- Here we call the back end to generate the output code
......
gcc/ada/sem.adb
......@@ -63,6 +63,9 @@ pragma Warnings (Off, Sem_Util);
package body Sem is
Debug_Unit_Walk : constant Boolean := False;
-- Set to True to print out debugging information for Walk_Library_Items
Outer_Generic_Scope : Entity_Id := Empty;
-- Global reference to the outer scope that is generic. In a non
-- generic context, it is empty. At the moment, it is only used
......@@ -78,6 +81,12 @@ package body Sem is
-- If True, we suppress appending compilation units onto the
-- Comp_Unit_List.
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "");
-- Print out debugging information about the unit
-------------
-- Analyze --
-------------
......@@ -1345,9 +1354,18 @@ package body Sem is
Restore_Scope_Stack;
end Do_Analyze;
Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
-- Start of processing for Semantics
begin
if Debug_Unit_Walk and then Already_Analyzed then
Write_Str ("(done)");
Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit),
Prefix => "--> ");
Indent;
end if;
Compiler_State := Analyzing;
Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
......@@ -1400,35 +1418,34 @@ package body Sem is
-- Do analysis, and then append the compilation unit onto the
-- Comp_Unit_List, if appropriate. This is done after analysis, so if
-- this unit depends on some others, they have already been
-- appended. We ignore bodies, except for the main unit itself, and
-- everything those bodies depend upon. We have also to guard against
-- ill-formed subunits that have an improper context.
-- appended. We ignore bodies, except for the main unit itself. We
-- have also to guard against ill-formed subunits that have an
-- improper context.
Do_Analyze;
if Ignore_Comp_Units then
Do_Analyze;
pragma Assert (Ignore_Comp_Units); -- still
null;
elsif Present (Comp_Unit)
and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
and then not In_Extended_Main_Source_Unit (Comp_Unit)
then
Ignore_Comp_Units := True;
Do_Analyze;
pragma Assert (Ignore_Comp_Units);
Ignore_Comp_Units := False;
null;
else
Do_Analyze;
-- pragma Assert (not Ignore_Comp_Units);
-- The above assertion is *almost* true. It fails only when a
-- subunit with's its parent procedure body, which has no explicit
-- spec.
pragma Assert (not Ignore_Comp_Units);
if No (Comp_Unit_List) then -- Initialize if first time
Comp_Unit_List := New_Elmt_List;
end if;
if not Ignore_Comp_Units then -- See above commented-out Assert
Append_Elmt (Comp_Unit, Comp_Unit_List);
Append_Elmt (Comp_Unit, Comp_Unit_List);
if Debug_Unit_Walk then
Write_Str ("Appending ");
Write_Unit_Info
(Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
end if;
-- Ignore all units after main unit
......@@ -1456,6 +1473,13 @@ package body Sem is
Restore_Opt_Config_Switches (Save_Config_Switches);
Expander_Mode_Restore;
if Debug_Unit_Walk and then Already_Analyzed then
Outdent;
Write_Str ("(done)");
Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit),
Prefix => "<-- ");
end if;
end Semantics;
------------------------
......@@ -1463,8 +1487,8 @@ package body Sem is
------------------------
procedure Walk_Library_Items is
Enable_Output : constant Boolean := False;
-- Set to True to print out the items as we go (for debugging)
type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
Seen : Unit_Number_Set := (others => False);
procedure Do_Action (CU : Node_Id; Item : Node_Id);
-- Calls Action, with some validity checks
......@@ -1478,6 +1502,8 @@ package body Sem is
-- This calls Action at the end. All the preceding code is just
-- assertions and debugging output.
pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
case Nkind (Item) is
when N_Generic_Subprogram_Declaration |
N_Generic_Package_Declaration |
......@@ -1515,28 +1541,24 @@ package body Sem is
if Present (CU) then
pragma Assert (Item /= Stand.Standard_Package_Node);
pragma Assert (Item = Unit (CU));
if Enable_Output then
Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (CU)));
Write_Str (", Unit_Number = ");
Write_Int (Int (Get_Cunit_Unit_Number (CU)));
Write_Str (", ");
Write_Str (Node_Kind'Image (Nkind (Item)));
declare
Unit_Num : constant Unit_Number_Type :=
Get_Cunit_Unit_Number (CU);
begin
Write_Unit_Info (Unit_Num, Item);
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
Write_Eol;
end if;
pragma Assert (not Seen (Unit_Num));
Seen (Unit_Num) := True;
end;
else
-- Must be Standard
pragma Assert (Item = Stand.Standard_Package_Node);
if Enable_Output then
if Debug_Unit_Walk then
Write_Line ("Standard");
end if;
end if;
......@@ -1551,7 +1573,7 @@ package body Sem is
-- Start of processing for Walk_Library_Items
begin
if Enable_Output then
if Debug_Unit_Walk then
Write_Line ("Walk_Library_Items:");
Indent;
end if;
......@@ -1572,7 +1594,8 @@ package body Sem is
-- If it's a body, then ignore it, unless it's an instance (in
-- which case we do the spec), or it's the main unit (in which
-- case we do it). Note that it could be both.
-- case we do it). Note that it could be both, in which case we
-- do the spec first.
when N_Package_Body | N_Subprogram_Body =>
declare
......@@ -1593,7 +1616,11 @@ package body Sem is
end if;
if Is_Generic_Instance (Entity) then
Do_Action (CU, Unit (Library_Unit (CU)));
declare
Spec_Unit : constant Node_Id := Library_Unit (CU);
begin
Do_Action (Spec_Unit, Unit (Spec_Unit));
end;
end if;
end;
......@@ -1616,10 +1643,56 @@ package body Sem is
Next_Elmt (Cur);
end loop;
if Enable_Output then
if Debug_Unit_Walk then
if Seen /= (Seen'Range => True) then
Write_Eol;
Write_Line ("Ignored units:");
Indent;
for Unit_Num in Seen'Range loop
if not Seen (Unit_Num) then
Write_Unit_Info (Unit_Num, Unit (Cunit (Unit_Num)));
end if;
end loop;
Outdent;
end if;
end if;
if Debug_Unit_Walk then
Outdent;
Write_Line ("end Walk_Library_Items.");
end if;
end Walk_Library_Items;
---------------------
-- Write_Unit_Info --
---------------------
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "")
is
begin
if Debug_Unit_Walk then
Write_Str (Prefix);
Write_Unit_Name (Unit_Name (Unit_Num));
Write_Str (", unit ");
Write_Int (Int (Unit_Num));
Write_Str (", ");
Write_Int (Int (Item));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Item)));
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Int (Int (Original_Node (Item)));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
Write_Eol;
end if;
end Write_Unit_Info;
end Sem;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment