Skip to content

R
riscv-gcc-1
Commit aca53298 by Arnaud Charlet
Options

[multiple changes] 

2009-04-24  Emmanuel Briot  <briot@adacore.com>

	* prj.adb, prj.ads, prj-nmsc.adb (Check_File, Record_Ada_Source,
	Add_Source): merge some code between those. In particular change where
	file normalization is done to avoid a few extra calls to
	Canonicalize_File_Name. This also removes the need for passing
	Current_Dir in a number of subprograms.

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

	* lib-load.adb (Make_Instance_Unit): In the case where In_Main is
	False, assign the correct unit to the Cunit field of the new table
	entry. We want the spec unit, not the body unit.

	* rtsfind.adb (Make_Unit_Name, Maybe_Add_With): Simplify calling
	interface for these.
	(Maybe_Add_With): Check whether we're trying to a with on the current
	unit, and avoid creating such directly self-referential with clauses.
	(Text_IO_Kludge): Add implicit with's for the generic pseudo-children of
	[[Wide_]Wide_]Text_IO. These are needed for Walk_Library_Items,
	and matches existing comments in the spec.

	* sem.adb (Walk_Library_Items): Add various special cases to make the
	assertions pass.

	* sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): Use Body_Cunit
	instead of Parent (N), for uniformity.

From-SVN: r146724
parent e211f859
Showing with 426 additions and 398 deletions
gcc/ada/ChangeLog
2009-04-24 Emmanuel Briot <briot@adacore.com>
* prj.adb, prj.ads, prj-nmsc.adb (Check_File, Record_Ada_Source,
Add_Source): merge some code between those. In particular change where
file normalization is done to avoid a few extra calls to
Canonicalize_File_Name. This also removes the need for passing
Current_Dir in a number of subprograms.
2009-04-24 Bob Duff <duff@adacore.com>
* lib-load.adb (Make_Instance_Unit): In the case where In_Main is
False, assign the correct unit to the Cunit field of the new table
entry. We want the spec unit, not the body unit.
* rtsfind.adb (Make_Unit_Name, Maybe_Add_With): Simplify calling
interface for these.
(Maybe_Add_With): Check whether we're trying to a with on the current
unit, and avoid creating such directly self-referential with clauses.
(Text_IO_Kludge): Add implicit with's for the generic pseudo-children of
[[Wide_]Wide_]Text_IO. These are needed for Walk_Library_Items,
and matches existing comments in the spec.
* sem.adb (Walk_Library_Items): Add various special cases to make the
assertions pass.
* sem_ch12.adb (Build_Instance_Compilation_Unit_Nodes): Use Body_Cunit
instead of Parent (N), for uniformity.
2009-04-24 Robert Dewar <dewar@adacore.com> 2009-04-24 Robert Dewar <dewar@adacore.com>
* errout.ads: Minor reformatting * errout.ads: Minor reformatting
......
gcc/ada/lib-load.adb
...@@ -812,7 +812,16 @@ package body Lib.Load is ...@@ -812,7 +812,16 @@ package body Lib.Load is
-- units table when first loaded as a declaration. -- units table when first loaded as a declaration.
Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N)); Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N));
Units.Table (Units.Last).Cunit := N;
-- The correct Cunit is the spec -- Library_Unit (N). But that causes
-- gnatmake to fail in certain cases, so this is under control of
-- Inspector_Mode for now. ???
if Inspector_Mode then
Units.Table (Units.Last).Cunit := Library_Unit (N);
else
Units.Table (Units.Last).Cunit := N;
end if;
end if; end if;
end Make_Instance_Unit; end Make_Instance_Unit;
......
gcc/ada/prj-nmsc.adb
...@@ -205,6 +205,9 @@ package body Prj.Nmsc is ...@@ -205,6 +205,9 @@ package body Prj.Nmsc is
end record; end record;
No_Name_And_Index : constant Name_And_Index := No_Name_And_Index : constant Name_And_Index :=
(Name => No_Name, Index => 0); (Name => No_Name, Index => 0);
-- Name of a unit, and its index inside the source file. The first unit has
-- index 1 (see doc for pragma Source_File_Name), but the index might be
-- set to 0 when the source file contains a single unit.
package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num, (Header_Num => Header_Num,
...@@ -233,8 +236,7 @@ package body Prj.Nmsc is ...@@ -233,8 +236,7 @@ package body Prj.Nmsc is
Display_File : File_Name_Type; Display_File : File_Name_Type;
Lang_Kind : Language_Kind; Lang_Kind : Language_Kind;
Naming_Exception : Boolean := False; Naming_Exception : Boolean := False;
Path : Path_Name_Type := No_Path; Path : Path_Information := No_Path_Information;
Display_Path : Path_Name_Type := No_Path;
Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; Alternate_Languages : Alternate_Language_Id := No_Alternate_Language;
Other_Part : Source_Id := No_Source; Other_Part : Source_Id := No_Source;
Unit : Name_Id := No_Name; Unit : Name_Id := No_Name;
...@@ -355,7 +357,6 @@ package body Prj.Nmsc is ...@@ -355,7 +357,6 @@ package body Prj.Nmsc is
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Current_Dir : String;
Explicit_Sources_Only : Boolean); Explicit_Sources_Only : Boolean);
-- Find all Ada sources by traversing all source directories. -- Find all Ada sources by traversing all source directories.
-- If Explicit_Sources_Only is True, then the sources found must belong to -- If Explicit_Sources_Only is True, then the sources found must belong to
...@@ -390,10 +391,9 @@ package body Prj.Nmsc is ...@@ -390,10 +391,9 @@ package body Prj.Nmsc is
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Name : String; Path : Path_Name_Type;
File_Name : File_Name_Type; File_Name : File_Name_Type;
Display_File_Name : File_Name_Type; Display_File_Name : File_Name_Type;
Source_Directory : String;
For_All_Sources : Boolean); For_All_Sources : Boolean);
-- Check if file File_Name is a valid source of the project. This is used -- Check if file File_Name is a valid source of the project. This is used
-- in multi-language mode only. -- in multi-language mode only.
...@@ -464,8 +464,7 @@ package body Prj.Nmsc is ...@@ -464,8 +464,7 @@ package body Prj.Nmsc is
-- Source_Names. -- Source_Names.
procedure Find_Sources procedure Find_Sources
(Current_Dir : String; (Project : Project_Id;
Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data); Data : in out Project_Data);
-- Process the Source_Files and Source_List_File attributes, and store -- Process the Source_Files and Source_List_File attributes, and store
...@@ -499,7 +498,7 @@ package body Prj.Nmsc is ...@@ -499,7 +498,7 @@ package body Prj.Nmsc is
-- specific SFN pragma is needed. If the file name corresponds to no unit, -- specific SFN pragma is needed. If the file name corresponds to no unit,
-- then Unit_Name will be No_Name. If the file is a multi-unit source or an -- then Unit_Name will be No_Name. If the file is a multi-unit source or an
-- exception to the naming scheme, then Exception_Id is set to the unit or -- exception to the naming scheme, then Exception_Id is set to the unit or
-- units that the source contains. -- units that the source contains, and the other information are not set.
function Is_Illegal_Suffix function Is_Illegal_Suffix
(Suffix : File_Name_Type; (Suffix : File_Name_Type;
...@@ -532,15 +531,11 @@ package body Prj.Nmsc is ...@@ -532,15 +531,11 @@ package body Prj.Nmsc is
procedure Look_For_Sources procedure Look_For_Sources
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data);
Current_Dir : String);
-- Find all the sources of project Project in project tree In_Tree and -- Find all the sources of project Project in project tree In_Tree and
-- update its Data accordingly. This assumes that Data.First_Source has -- update its Data accordingly. This assumes that Data.First_Source has
-- been initialized with the list of excluded sources and special naming -- been initialized with the list of excluded sources and special naming
-- exceptions. -- exceptions.
--
-- Current_Dir should represent the current directory, and is passed for
-- efficiency to avoid system calls to recompute it.
function Path_Name_Of function Path_Name_Of
(File_Name : File_Name_Type; (File_Name : File_Name_Type;
...@@ -561,15 +556,12 @@ package body Prj.Nmsc is ...@@ -561,15 +556,12 @@ package body Prj.Nmsc is
Project : Project_Id; Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Ada_Language : Language_Ptr;
Location : Source_Ptr; Location : Source_Ptr;
Current_Source : in out String_List_Id; Source_Recorded : in out Boolean);
Source_Recorded : in out Boolean;
Current_Dir : String);
-- Put a unit in the list of units of a project, if the file name -- Put a unit in the list of units of a project, if the file name
-- corresponds to a valid unit name. -- corresponds to a valid unit name.
-- -- Ada_Language is a pointer to the Language_Data for "Ada" in Project.
-- Current_Dir should represent the current directory, and is passed for
-- efficiency to avoid system calls to recompute it.
procedure Remove_Source procedure Remove_Source
(Id : Source_Id; (Id : Source_Id;
...@@ -684,8 +676,7 @@ package body Prj.Nmsc is ...@@ -684,8 +676,7 @@ package body Prj.Nmsc is
Display_File : File_Name_Type; Display_File : File_Name_Type;
Lang_Kind : Language_Kind; Lang_Kind : Language_Kind;
Naming_Exception : Boolean := False; Naming_Exception : Boolean := False;
Path : Path_Name_Type := No_Path; Path : Path_Information := No_Path_Information;
Display_Path : Path_Name_Type := No_Path;
Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; Alternate_Languages : Alternate_Language_Id := No_Alternate_Language;
Other_Part : Source_Id := No_Source; Other_Part : Source_Id := No_Source;
Unit : Name_Id := No_Name; Unit : Name_Id := No_Name;
...@@ -744,9 +735,9 @@ package body Prj.Nmsc is ...@@ -744,9 +735,9 @@ package body Prj.Nmsc is
Id.Switches := Switches_Name (File_Name); Id.Switches := Switches_Name (File_Name);
end if; end if;
if Path /= No_Path then if Path /= No_Path_Information then
Id.Path := (Path, Display_Path); Id.Path := Path;
Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path, Id); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path.Name, Id);
end if; end if;
-- Add the source id to the Unit_Sources_HT hash table, if the unit name -- Add the source id to the Unit_Sources_HT hash table, if the unit name
...@@ -870,7 +861,7 @@ package body Prj.Nmsc is ...@@ -870,7 +861,7 @@ package body Prj.Nmsc is
-- Find the sources -- Find the sources
if Data.Source_Dirs /= Nil_String then if Data.Source_Dirs /= Nil_String then
Look_For_Sources (Project, In_Tree, Data, Current_Dir); Look_For_Sources (Project, In_Tree, Data);
if Get_Mode = Ada_Only then if Get_Mode = Ada_Only then
...@@ -6895,8 +6886,7 @@ package body Prj.Nmsc is ...@@ -6895,8 +6886,7 @@ package body Prj.Nmsc is
------------------ ------------------
procedure Find_Sources procedure Find_Sources
(Current_Dir : String; (Project : Project_Id;
Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data) Data : in out Project_Data)
is is
...@@ -7056,7 +7046,7 @@ package body Prj.Nmsc is ...@@ -7056,7 +7046,7 @@ package body Prj.Nmsc is
if Get_Mode = Ada_Only then if Get_Mode = Ada_Only then
Find_Ada_Sources Find_Ada_Sources
(Project, In_Tree, Data, Current_Dir, (Project, In_Tree, Data,
Explicit_Sources_Only => Has_Explicit_Sources); Explicit_Sources_Only => Has_Explicit_Sources);
else else
...@@ -7152,21 +7142,27 @@ package body Prj.Nmsc is ...@@ -7152,21 +7142,27 @@ package body Prj.Nmsc is
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Current_Dir : String;
Explicit_Sources_Only : Boolean) Explicit_Sources_Only : Boolean)
is is
Source_Dir : String_List_Id; Source_Dir : String_List_Id;
Element : String_Element; Element : String_Element;
Dir : Dir_Type; Dir : Dir_Type;
Current_Source : String_List_Id := Nil_String;
Dir_Has_Source : Boolean := False; Dir_Has_Source : Boolean := False;
NL : Name_Location; NL : Name_Location;
Ada_Language : Language_Ptr;
begin begin
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Line ("Looking for Ada sources:"); Write_Line ("Looking for Ada sources:");
end if; end if;
Ada_Language := Data.Languages;
while Ada_Language /= No_Language_Index
and then Ada_Language.Name /= Name_Ada
loop
Ada_Language := Ada_Language.Next;
end loop;
-- We look in all source directories for the file names in the hash -- We look in all source directories for the file names in the hash
-- table Source_Names. -- table Source_Names.
...@@ -7213,7 +7209,7 @@ package body Prj.Nmsc is ...@@ -7213,7 +7209,7 @@ package body Prj.Nmsc is
(Name => Name_Buffer (1 .. Name_Len), (Name => Name_Buffer (1 .. Name_Len),
Directory => Dir_Path (Dir_Path'First .. Dir_Last), Directory => Dir_Path (Dir_Path'First .. Dir_Last),
Resolve_Links => Opt.Follow_Links_For_Files, Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True); Case_Sensitive => True); -- no case folding
Path_Name : Path_Name_Type; Path_Name : Path_Name_Type;
To_Record : Boolean := False; To_Record : Boolean := False;
...@@ -7257,10 +7253,9 @@ package body Prj.Nmsc is ...@@ -7257,10 +7253,9 @@ package body Prj.Nmsc is
Project => Project, Project => Project,
In_Tree => In_Tree, In_Tree => In_Tree,
Data => Data, Data => Data,
Ada_Language => Ada_Language,
Location => Location, Location => Location,
Current_Source => Current_Source, Source_Recorded => Dir_Has_Source);
Source_Recorded => Dir_Has_Source,
Current_Dir => Current_Dir);
end if; end if;
end; end;
end loop; end loop;
...@@ -7435,22 +7430,14 @@ package body Prj.Nmsc is ...@@ -7435,22 +7430,14 @@ package body Prj.Nmsc is
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Name : String; Path : Path_Name_Type;
File_Name : File_Name_Type; File_Name : File_Name_Type;
Display_File_Name : File_Name_Type; Display_File_Name : File_Name_Type;
Source_Directory : String;
For_All_Sources : Boolean) For_All_Sources : Boolean)
is is
Display_Path : constant String := Canonical_Path : constant Path_Name_Type :=
Normalize_Pathname Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path)));
(Name => Name,
Directory => Source_Directory,
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True);
Name_Loc : Name_Location := Source_Names.Get (File_Name); Name_Loc : Name_Location := Source_Names.Get (File_Name);
Path_Id : Path_Name_Type;
Display_Path_Id : Path_Name_Type;
Check_Name : Boolean := False; Check_Name : Boolean := False;
Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; Alternate_Languages : Alternate_Language_Id := No_Alternate_Language;
Language : Language_Ptr; Language : Language_Ptr;
...@@ -7468,17 +7455,6 @@ package body Prj.Nmsc is ...@@ -7468,17 +7455,6 @@ package body Prj.Nmsc is
Iter : Source_Iterator; Iter : Source_Iterator;
begin begin
Name_Len := Display_Path'Length;
Name_Buffer (1 .. Name_Len) := Display_Path;
Display_Path_Id := Name_Find;
if Osint.File_Names_Case_Sensitive then
Path_Id := Display_Path_Id;
else
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Path_Id := Name_Find;
end if;
if Name_Loc = No_Name_Location then if Name_Loc = No_Name_Location then
Check_Name := For_All_Sources; Check_Name := For_All_Sources;
...@@ -7505,11 +7481,11 @@ package body Prj.Nmsc is ...@@ -7505,11 +7481,11 @@ package body Prj.Nmsc is
Check_Name := True; Check_Name := True;
else else
Name_Loc.Source.Path := (Path_Id, Display_Path_Id); Name_Loc.Source.Path := (Canonical_Path, Path);
Source_Paths_Htable.Set Source_Paths_Htable.Set
(In_Tree.Source_Paths_HT, (In_Tree.Source_Paths_HT,
Path_Id, Canonical_Path,
Name_Loc.Source); Name_Loc.Source);
-- Check if this is a subunit -- Check if this is a subunit
...@@ -7518,7 +7494,7 @@ package body Prj.Nmsc is ...@@ -7518,7 +7494,7 @@ package body Prj.Nmsc is
and then Name_Loc.Source.Kind = Impl and then Name_Loc.Source.Kind = Impl
then then
Src_Ind := Sinput.P.Load_Project_File Src_Ind := Sinput.P.Load_Project_File
(Get_Name_String (Path_Id)); (Get_Name_String (Canonical_Path));
if Sinput.P.Source_File_Is_Subunit (Src_Ind) then if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
Name_Loc.Source.Kind := Sep; Name_Loc.Source.Kind := Sep;
...@@ -7631,7 +7607,7 @@ package body Prj.Nmsc is ...@@ -7631,7 +7607,7 @@ package body Prj.Nmsc is
Error_Msg_Name_1 := Error_Msg_Name_1 :=
In_Tree.Projects.Table (Project).Name; In_Tree.Projects.Table (Project).Name;
Error_Msg_Name_2 := Name_Id (Display_Path_Id); Error_Msg_Name_2 := Name_Id (Path);
Error_Msg Error_Msg
(Project, In_Tree, "\ project %%, %%", No_Location); (Project, In_Tree, "\ project %%, %%", No_Location);
...@@ -7661,8 +7637,7 @@ package body Prj.Nmsc is ...@@ -7661,8 +7637,7 @@ package body Prj.Nmsc is
Display_File => Display_File_Name, Display_File => Display_File_Name,
Other_Part => Other_Part, Other_Part => Other_Part,
Unit => Unit, Unit => Unit,
Path => Path_Id, Path => (Canonical_Path, Path),
Display_Path => Display_Path_Id,
Source_To_Replace => Source_To_Replace); Source_To_Replace => Source_To_Replace);
end if; end if;
end if; end if;
...@@ -7749,10 +7724,23 @@ package body Prj.Nmsc is ...@@ -7749,10 +7724,23 @@ package body Prj.Nmsc is
end if; end if;
declare declare
Path_Name : constant String :=
Normalize_Pathname
(Name (1 .. Last),
Directory => Source_Directory
(Source_Directory'First .. Dir_Last),
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True); -- no folding
Path : Path_Name_Type;
FF : File_Found := FF : File_Found :=
Excluded_Sources_Htable.Get (File_Name); Excluded_Sources_Htable.Get (File_Name);
begin begin
Name_Len := Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Path_Name;
Path := Name_Find;
if FF /= No_File_Found then if FF /= No_File_Found then
if not FF.Found then if not FF.Found then
FF.Found := True; FF.Found := True;
...@@ -7771,11 +7759,9 @@ package body Prj.Nmsc is ...@@ -7771,11 +7759,9 @@ package body Prj.Nmsc is
(Project => Project, (Project => Project,
In_Tree => In_Tree, In_Tree => In_Tree,
Data => Data, Data => Data,
Name => Name (1 .. Last), Path => Path,
File_Name => File_Name, File_Name => File_Name,
Display_File_Name => Display_File_Name, Display_File_Name => Display_File_Name,
Source_Directory => Source_Directory
(Source_Directory'First .. Dir_Last),
For_All_Sources => For_All_Sources); For_All_Sources => For_All_Sources);
end if; end if;
end; end;
...@@ -7874,8 +7860,7 @@ package body Prj.Nmsc is ...@@ -7874,8 +7860,7 @@ package body Prj.Nmsc is
procedure Look_For_Sources procedure Look_For_Sources
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data)
Current_Dir : String)
is is
Iter : Source_Iterator; Iter : Source_Iterator;
...@@ -8113,7 +8098,7 @@ package body Prj.Nmsc is ...@@ -8113,7 +8098,7 @@ package body Prj.Nmsc is
Load_Naming_Exceptions (Project, In_Tree); Load_Naming_Exceptions (Project, In_Tree);
end if; end if;
Find_Sources (Current_Dir, Project, In_Tree, Data); Find_Sources (Project, In_Tree, Data);
Mark_Excluded_Sources; Mark_Excluded_Sources;
if Get_Mode = Multi_Language then if Get_Mode = Multi_Language then
...@@ -8204,287 +8189,276 @@ package body Prj.Nmsc is ...@@ -8204,287 +8189,276 @@ package body Prj.Nmsc is
Project : Project_Id; Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Ada_Language : Language_Ptr;
Location : Source_Ptr; Location : Source_Ptr;
Current_Source : in out String_List_Id; Source_Recorded : in out Boolean)
Source_Recorded : in out Boolean;
Current_Dir : String)
is is
Canonical_File_Name : File_Name_Type; Canonical_File : File_Name_Type;
Canonical_Path_Name : Path_Name_Type; Canonical_Path : Path_Name_Type;
Exception_Id : Ada_Naming_Exception_Id;
Unit_Name : Name_Id;
Unit_Kind : Spec_Or_Body;
Unit_Ind : Int := 0;
Info : Unit_Info;
Name_Index : Name_And_Index;
Needs_Pragma : Boolean;
The_Location : Source_Ptr := Location; File_Recorded : Boolean := False;
Previous_Source : constant String_List_Id := Current_Source; -- True when at least one file has been recorded
Except_Name : Name_And_Index := No_Name_And_Index;
Unit_Prj : Unit_Project; procedure Record_Unit
(Unit_Name : Name_Id;
Unit_Ind : Int := 0;
Unit_Kind : Spec_Or_Body;
Needs_Pragma : Boolean);
-- Register of the units contained in the source file (there is in
-- general a single such unit except when exceptions to the naming
-- scheme indicate there are several such units)
File_Name_Recorded : Boolean := False; -----------------
-- Record_Unit --
-----------------
begin procedure Record_Unit
Canonical_File_Name := Canonical_Case_File_Name (Name_Id (File_Name)); (Unit_Name : Name_Id;
Unit_Ind : Int := 0;
Unit_Kind : Spec_Or_Body;
Needs_Pragma : Boolean)
is
The_Unit : Unit_Index :=
Units_Htable.Get (In_Tree.Units_HT, Unit_Name);
UData : Unit_Data;
Kind : Source_Kind;
Source : Source_Id;
Unit_Prj : Unit_Project;
To_Record : Boolean := False;
The_Location : Source_Ptr := Location;
if Osint.File_Names_Case_Sensitive then begin
Canonical_Path_Name := Path_Name; if Current_Verbosity = High then
else Write_Str (" Putting ");
declare Write_Str (Get_Name_String (Unit_Name));
Canonical_Path : constant String := Write_Line (" in the unit list.");
Normalize_Pathname end if;
(Get_Name_String (Path_Name),
Directory => Current_Dir,
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => False);
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Canonical_Path);
Canonical_Path_Name := Name_Find;
end;
end if;
-- Find out the unit name, the unit kind and if it needs -- The unit is already in the list, but may be it is only the other
-- a specific SFN pragma. -- unit kind (spec or body), or what is in the unit list is a unit of
-- a project we are extending.
Get_Unit if The_Unit /= No_Unit_Index then
(In_Tree => In_Tree, UData := In_Tree.Units.Table (The_Unit);
Canonical_File_Name => Canonical_File_Name,
Naming => Data.Naming,
Exception_Id => Exception_Id,
Unit_Name => Unit_Name,
Unit_Kind => Unit_Kind,
Needs_Pragma => Needs_Pragma);
if Exception_Id = No_Ada_Naming_Exception if (UData.File_Names (Unit_Kind).Name = Canonical_File
and then Unit_Name = No_Name and then UData.File_Names (Unit_Kind).Path.Name = Slash)
then or else UData.File_Names (Unit_Kind).Name = No_File
if Current_Verbosity = High then or else Is_Extending
Write_Str (" """); (Data.Extends,
Write_Str (Get_Name_String (Canonical_File_Name)); UData.File_Names (Unit_Kind).Project,
Write_Line (""" is not a valid source file name (ignored)."); In_Tree)
end if; then
if UData.File_Names (Unit_Kind).Path.Name = Slash then
Remove_Forbidden_File_Name
(UData.File_Names (Unit_Kind).Name);
end if;
else -- Record the file name in the hash table Files_Htable
-- Check to see if the source has been hidden by an exception,
-- but only if it is not an exception. Unit_Prj := (Unit => The_Unit, Project => Project);
Files_Htable.Set
(In_Tree.Files_HT,
Canonical_File,
Unit_Prj);
UData.File_Names (Unit_Kind) :=
(Name => Canonical_File,
Index => Unit_Ind,
Display_Name => File_Name,
Path => (Canonical_Path, Path_Name),
Project => Project,
Needs_Pragma => Needs_Pragma);
In_Tree.Units.Table (The_Unit) := UData;
To_Record := True;
Source_Recorded := True;
-- If the same file is already in the list, do not add it again
elsif UData.File_Names (Unit_Kind).Project = Project
and then
(Data.Known_Order_Of_Source_Dirs
or else
UData.File_Names (Unit_Kind).Path.Name = Canonical_Path)
then
To_Record := False;
if not Needs_Pragma then -- Else, same unit but not same file => It is an error to have two
Except_Name := -- units with the same name and the same kind (spec or body).
Reverse_Ada_Naming_Exceptions.Get
((Unit_Kind, Unit_Name, No_Ada_Naming_Exception));
if Except_Name /= No_Name_And_Index then else
if Current_Verbosity = High then if The_Location = No_Location then
Write_Str (" """); The_Location := In_Tree.Projects.Table (Project).Location;
Write_Str (Get_Name_String (Canonical_File_Name));
Write_Str (""" contains a unit that is found in """);
Write_Str (Get_Name_String (Except_Name.Name));
Write_Line (""" (ignored).");
end if; end if;
-- The file is not included in the source of the project since Err_Vars.Error_Msg_Name_1 := Unit_Name;
-- it is hidden by the exception. So, nothing else to do. Error_Msg
(Project, In_Tree, "duplicate unit %%", The_Location);
return; Err_Vars.Error_Msg_Name_1 :=
end if; In_Tree.Projects.Table
end if; (UData.File_Names (Unit_Kind).Project).Name;
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (UData.File_Names (Unit_Kind).Path.Name);
Error_Msg
(Project, In_Tree,
"\ project file %%, {", The_Location);
loop Err_Vars.Error_Msg_Name_1 :=
if Exception_Id /= No_Ada_Naming_Exception then In_Tree.Projects.Table (Project).Name;
Info := Ada_Naming_Exception_Table.Table (Exception_Id); Err_Vars.Error_Msg_File_1 := File_Name_Type (Canonical_Path);
Exception_Id := Info.Next; Error_Msg
Info.Next := No_Ada_Naming_Exception; (Project, In_Tree, "\ project file %%, {", The_Location);
Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info);
Unit_Name := Info.Unit;
Unit_Ind := Name_Index.Index;
Unit_Kind := Info.Kind;
end if;
-- Put the file name in the list of sources of the project To_Record := False;
String_Element_Table.Increment_Last (In_Tree.String_Elements);
In_Tree.String_Elements.Table
(String_Element_Table.Last (In_Tree.String_Elements)) :=
(Value => Name_Id (Canonical_File_Name),
Display_Value => Name_Id (File_Name),
Location => No_Location,
Flag => False,
Next => Nil_String,
Index => Unit_Ind);
if Current_Source = Nil_String then
Data.Ada_Sources :=
String_Element_Table.Last (In_Tree.String_Elements);
else
In_Tree.String_Elements.Table (Current_Source).Next :=
String_Element_Table.Last (In_Tree.String_Elements);
end if; end if;
Current_Source := -- It is a new unit, create a new record
String_Element_Table.Last (In_Tree.String_Elements);
-- Put the unit in unit list else
-- First, check if there is no other unit with this file name in
-- another project. If it is, report error but note we do that
-- only for the first unit in the source file.
declare Unit_Prj := Files_Htable.Get (In_Tree.Files_HT, Canonical_File);
The_Unit : Unit_Index :=
Units_Htable.Get (In_Tree.Units_HT, Unit_Name);
The_Unit_Data : Unit_Data; if not File_Recorded
and then Unit_Prj /= No_Unit_Project
then
Error_Msg_File_1 := File_Name;
Error_Msg_Name_1 :=
In_Tree.Projects.Table (Unit_Prj.Project).Name;
Error_Msg
(Project, In_Tree,
"{ is already a source of project %%",
Location);
begin else
if Current_Verbosity = High then Unit_Table.Increment_Last (In_Tree.Units);
Write_Str (" Putting "); The_Unit := Unit_Table.Last (In_Tree.Units);
Write_Str (Get_Name_String (Unit_Name)); Units_Htable.Set (In_Tree.Units_HT, Unit_Name, The_Unit);
Write_Line (" in the unit list.");
end if; Unit_Prj := (Unit => The_Unit, Project => Project);
Files_Htable.Set (In_Tree.Files_HT, Canonical_File, Unit_Prj);
UData.Name := Unit_Name;
UData.File_Names (Unit_Kind) :=
(Name => Canonical_File,
Index => Unit_Ind,
Display_Name => File_Name,
Path => (Canonical_Path, Path_Name),
Project => Project,
Needs_Pragma => Needs_Pragma);
In_Tree.Units.Table (The_Unit) := UData;
Source_Recorded := True;
To_Record := True;
end if;
end if;
-- The unit is already in the list, but may be it is if To_Record then
-- only the other unit kind (spec or body), or what is case Unit_Kind is
-- in the unit list is a unit of a project we are extending. when Body_Part => Kind := Impl;
when Specification => Kind := Spec;
end case;
if The_Unit /= No_Unit_Index then Add_Source
The_Unit_Data := In_Tree.Units.Table (The_Unit); (Id => Source,
In_Tree => In_Tree,
Project => Project,
Lang_Id => Ada_Language,
Lang_Kind => Unit_Based,
File_Name => Canonical_File,
Display_File => File_Name,
Unit => Unit_Name,
Path => (Canonical_Path, Path_Name),
Kind => Kind,
Other_Part => No_Source); -- ??? Can we find file ?
end if;
end Record_Unit;
if (The_Unit_Data.File_Names (Unit_Kind).Name = Exception_Id : Ada_Naming_Exception_Id;
Canonical_File_Name Unit_Name : Name_Id;
and then Unit_Kind : Spec_Or_Body;
The_Unit_Data.File_Names Unit_Ind : Int := 0;
(Unit_Kind).Path.Name = Slash) Info : Unit_Info;
or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File Name_Index : Name_And_Index;
or else Is_Extending Except_Name : Name_And_Index := No_Name_And_Index;
(Data.Extends, Needs_Pragma : Boolean;
The_Unit_Data.File_Names (Unit_Kind).Project,
In_Tree)
then
if
The_Unit_Data.File_Names (Unit_Kind).Path.Name = Slash
then
Remove_Forbidden_File_Name
(The_Unit_Data.File_Names (Unit_Kind).Name);
end if;
-- Record the file name in the hash table Files_Htable begin
Canonical_File := Canonical_Case_File_Name (Name_Id (File_Name));
Unit_Prj := (Unit => The_Unit, Project => Project); Canonical_Path :=
Files_Htable.Set Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path_Name)));
(In_Tree.Files_HT,
Canonical_File_Name,
Unit_Prj);
The_Unit_Data.File_Names (Unit_Kind) :=
(Name => Canonical_File_Name,
Index => Unit_Ind,
Display_Name => File_Name,
Path => (Canonical_Path_Name, Path_Name),
Project => Project,
Needs_Pragma => Needs_Pragma);
In_Tree.Units.Table (The_Unit) := The_Unit_Data;
Source_Recorded := True;
elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project
and then (Data.Known_Order_Of_Source_Dirs
or else
The_Unit_Data.File_Names
(Unit_Kind).Path.Name = Canonical_Path_Name)
then
if Previous_Source = Nil_String then
Data.Ada_Sources := Nil_String;
else
In_Tree.String_Elements.Table (Previous_Source).Next :=
Nil_String;
String_Element_Table.Decrement_Last
(In_Tree.String_Elements);
end if;
Current_Source := Previous_Source; -- Check the naming scheme to get extra file properties
else Get_Unit
-- It is an error to have two units with the same name (In_Tree => In_Tree,
-- and the same kind (spec or body). Canonical_File_Name => Canonical_File,
Naming => Data.Naming,
Exception_Id => Exception_Id,
Unit_Name => Unit_Name,
Unit_Kind => Unit_Kind,
Needs_Pragma => Needs_Pragma);
if The_Location = No_Location then if Exception_Id = No_Ada_Naming_Exception
The_Location := and then Unit_Name = No_Name
In_Tree.Projects.Table (Project).Location; then
end if; if Current_Verbosity = High then
Write_Str (" """);
Write_Str (Get_Name_String (Canonical_File));
Write_Line (""" is not a valid source file name (ignored).");
end if;
return;
end if;
Err_Vars.Error_Msg_Name_1 := Unit_Name; -- Check to see if the source has been hidden by an exception,
Error_Msg -- but only if it is not an exception.
(Project, In_Tree, "duplicate unit %%", The_Location);
Err_Vars.Error_Msg_Name_1 := if not Needs_Pragma then
In_Tree.Projects.Table Except_Name :=
(The_Unit_Data.File_Names (Unit_Kind).Project).Name; Reverse_Ada_Naming_Exceptions.Get
Err_Vars.Error_Msg_File_1 := ((Unit_Kind, Unit_Name, No_Ada_Naming_Exception));
File_Name_Type
(The_Unit_Data.File_Names (Unit_Kind).Path.Name);
Error_Msg
(Project, In_Tree,
"\ project file %%, {", The_Location);
Err_Vars.Error_Msg_Name_1 := if Except_Name /= No_Name_And_Index then
In_Tree.Projects.Table (Project).Name; if Current_Verbosity = High then
Err_Vars.Error_Msg_File_1 := Write_Str (" """);
File_Name_Type (Canonical_Path_Name); Write_Str (Get_Name_String (Canonical_File));
Error_Msg Write_Str (""" contains a unit that is found in """);
(Project, In_Tree, Write_Str (Get_Name_String (Except_Name.Name));
"\ project file %%, {", The_Location); Write_Line (""" (ignored).");
end if; end if;
-- It is a new unit, create a new record -- The file is not included in the source of the project since
-- it is hidden by the exception. So, nothing else to do.
else return;
-- First, check if there is no other unit with this file end if;
-- name in another project. If it is, report error but note end if;
-- we do that only for the first unit in the source file.
Unit_Prj := -- The following loop registers the unit in the appropriate table. It
Files_Htable.Get (In_Tree.Files_HT, Canonical_File_Name); -- will be executed multiple times when the file is a multi-unit file,
-- in which case Exception_Id initially points to the first file and
-- then to each other unit in the file.
if not File_Name_Recorded and then loop
Unit_Prj /= No_Unit_Project if Exception_Id /= No_Ada_Naming_Exception then
then Info := Ada_Naming_Exception_Table.Table (Exception_Id);
Error_Msg_File_1 := File_Name; Exception_Id := Info.Next;
Error_Msg_Name_1 := Info.Next := No_Ada_Naming_Exception;
In_Tree.Projects.Table (Unit_Prj.Project).Name; Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info);
Error_Msg
(Project, In_Tree, Unit_Name := Info.Unit;
"{ is already a source of project %%", Unit_Ind := Name_Index.Index;
Location); Unit_Kind := Info.Kind;
end if;
else Record_Unit (Unit_Name, Unit_Ind, Unit_Kind, Needs_Pragma);
Unit_Table.Increment_Last (In_Tree.Units); File_Recorded := True;
The_Unit := Unit_Table.Last (In_Tree.Units);
Units_Htable.Set
(In_Tree.Units_HT, Unit_Name, The_Unit);
Unit_Prj := (Unit => The_Unit, Project => Project);
Files_Htable.Set
(In_Tree.Files_HT,
Canonical_File_Name,
Unit_Prj);
The_Unit_Data.Name := Unit_Name;
The_Unit_Data.File_Names (Unit_Kind) :=
(Name => Canonical_File_Name,
Index => Unit_Ind,
Display_Name => File_Name,
Path => (Canonical_Path_Name, Path_Name),
Project => Project,
Needs_Pragma => Needs_Pragma);
In_Tree.Units.Table (The_Unit) := The_Unit_Data;
Source_Recorded := True;
end if;
end if;
end;
exit when Exception_Id = No_Ada_Naming_Exception; exit when Exception_Id = No_Ada_Naming_Exception;
File_Name_Recorded := True; end loop;
end loop;
end if;
end Record_Ada_Source; end Record_Ada_Source;
------------------- -------------------
......
gcc/ada/prj.adb
...@@ -105,7 +105,6 @@ package body Prj is ...@@ -105,7 +105,6 @@ package body Prj is
Lib_Auto_Init => False, Lib_Auto_Init => False,
Libgnarl_Needed => Unknown, Libgnarl_Needed => Unknown,
Symbol_Data => No_Symbols, Symbol_Data => No_Symbols,
Ada_Sources => Nil_String,
Interfaces_Defined => False, Interfaces_Defined => False,
Include_Path => null, Include_Path => null,
Include_Data_Set => False, Include_Data_Set => False,
...@@ -1205,10 +1204,6 @@ package body Prj is ...@@ -1205,10 +1204,6 @@ package body Prj is
Lang : Language_Ptr; Lang : Language_Ptr;
begin begin
if Data.Ada_Sources /= Nil_String then
return True;
end if;
Lang := Data.Languages; Lang := Data.Languages;
while Lang /= No_Language_Index loop while Lang /= No_Language_Index loop
if Lang.Name = Name_Ada then if Lang.Name = Name_Ada then
......
gcc/ada/prj.ads
...@@ -1256,11 +1256,8 @@ package Prj is ...@@ -1256,11 +1256,8 @@ package Prj is
------------- -------------
-- Sources -- -- Sources --
------------- -------------
-- In multi-language mode, the sources for all languages including Ada -- The sources for all languages including Ada are accessible through
-- are accessible through the Source_Iterator type -- the Source_Iterator type
Ada_Sources : String_List_Id := Nil_String;
-- The list of all the Ada source file names (gnatmake only).
Interfaces_Defined : Boolean := False; Interfaces_Defined : Boolean := False;
-- True if attribute Interfaces is declared for the project or any -- True if attribute Interfaces is declared for the project or any
......
gcc/ada/rtsfind.adb
...@@ -164,25 +164,26 @@ package body Rtsfind is ...@@ -164,25 +164,26 @@ package body Rtsfind is
Id : RE_Id := RE_Null; Id : RE_Id := RE_Null;
Use_Setting : Boolean := False); Use_Setting : Boolean := False);
-- Load the unit whose Id is given if not already loaded. The unit is -- Load the unit whose Id is given if not already loaded. The unit is
-- loaded, analyzed, and added to the WITH list, and the entry in -- loaded and analyzed, and the entry in RT_Unit_Table is updated to
-- RT_Unit_Table is updated to reflect the load. Use_Setting is used to -- reflect the load. Use_Setting is used to indicate the initial setting
-- indicate the initial setting for the Is_Potentially_Use_Visible flag of -- for the Is_Potentially_Use_Visible flag of the entity for the loaded
-- the entity for the loaded unit (if it is indeed loaded). A value of -- unit (if it is indeed loaded). A value of False means nothing special
-- False means nothing special need be done. A value of True indicates that -- need be done. A value of True indicates that this flag must be set to
-- this flag must be set to True. It is needed only in the Text_IO_Kludge -- True. It is needed only in the Text_IO_Kludge procedure, which may
-- procedure, which may materialize an entity of Text_IO (or -- materialize an entity of Text_IO (or [Wide_]Wide_Text_IO) that was
-- [Wide_]Wide_Text_IO) that was previously unknown. Id is the RE_Id value -- previously unknown. Id is the RE_Id value of the entity which was
-- of the entity which was originally requested. Id is used only for error -- originally requested. Id is used only for error message detail, and if
-- message detail, and if it is RE_Null, then the attempt to output the -- it is RE_Null, then the attempt to output the entity name is ignored.
-- entity name is ignored.
function Make_Unit_Name
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id; (U : RT_Unit_Table_Record;
N : Node_Id) return Node_Id;
-- If the unit is a child unit, build fully qualified name for use in -- If the unit is a child unit, build fully qualified name for use in
-- With_Clause. -- With_Clause.
procedure Maybe_Add_With (E : RE_Id; U : in out RT_Unit_Table_Record); procedure Maybe_Add_With (U : in out RT_Unit_Table_Record);
-- If necessary, add an implicit with_clause from the current unit to the -- If necessary, add an implicit with_clause from the current unit to the
-- one represented by E and U. -- one represented by U.
procedure Output_Entity_Name (Id : RE_Id; Msg : String); procedure Output_Entity_Name (Id : RE_Id; Msg : String);
-- Output continuation error message giving qualified name of entity -- Output continuation error message giving qualified name of entity
...@@ -765,9 +766,10 @@ package body Rtsfind is ...@@ -765,9 +766,10 @@ package body Rtsfind is
-- Make_Unit_Name -- -- Make_Unit_Name --
-------------------- --------------------
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id is function Make_Unit_Name
U_Id : constant RTU_Id := RE_Unit_Table (E); (U : RT_Unit_Table_Record;
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); N : Node_Id) return Node_Id is
Nam : Node_Id; Nam : Node_Id;
Scop : Entity_Id; Scop : Entity_Id;
...@@ -795,15 +797,24 @@ package body Rtsfind is ...@@ -795,15 +797,24 @@ package body Rtsfind is
-- Maybe_Add_With -- -- Maybe_Add_With --
-------------------- --------------------
procedure Maybe_Add_With (E : RE_Id; U : in out RT_Unit_Table_Record) is procedure Maybe_Add_With (U : in out RT_Unit_Table_Record) is
Is_Main : constant Boolean := Is_Main : constant Boolean :=
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit)); In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit));
begin begin
-- We do not need to generate a with_clause for a call issued from -- We do not need to generate a with_clause for a call issued from
-- RTE_Component_Available. -- RTE_Component_Available. However, for Inspector, we need these
-- additional with's, because for a sequence like "if RTE_Available (X)
-- then ... RTE (X)" the RTE call fails to create some necessary
-- with's.
if RTE_Available_Call then if RTE_Available_Call and then not Inspector_Mode then
return;
end if;
-- Avoid creating directly self-referential with clauses
if Current_Sem_Unit = U.Unum then
return; return;
end if; end if;
...@@ -836,7 +847,7 @@ package body Rtsfind is ...@@ -836,7 +847,7 @@ package body Rtsfind is
Make_With_Clause (Standard_Location, Make_With_Clause (Standard_Location,
Name => Name =>
Make_Unit_Name Make_Unit_Name
(E, Defining_Unit_Name (Specification (LibUnit)))); (U, Defining_Unit_Name (Specification (LibUnit))));
begin begin
Set_Library_Unit (Withn, Cunit (U.Unum)); Set_Library_Unit (Withn, Cunit (U.Unum));
...@@ -1127,7 +1138,7 @@ package body Rtsfind is ...@@ -1127,7 +1138,7 @@ package body Rtsfind is
end if; end if;
<<Found>> <<Found>>
Maybe_Add_With (E, U); Maybe_Add_With (U);
Front_End_Inlining := Save_Front_End_Inlining; Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, RE_Table (E)); return Check_CRT (E, RE_Table (E));
...@@ -1229,7 +1240,7 @@ package body Rtsfind is ...@@ -1229,7 +1240,7 @@ package body Rtsfind is
-- If we didn't find the entity we want, something is wrong. The -- If we didn't find the entity we want, something is wrong. The
-- appropriate action will be taken by Check_CRT when we exit. -- appropriate action will be taken by Check_CRT when we exit.
Maybe_Add_With (E, U); Maybe_Add_With (U);
Front_End_Inlining := Save_Front_End_Inlining; Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, Found_E); return Check_CRT (E, Found_E);
...@@ -1380,6 +1391,9 @@ package body Rtsfind is ...@@ -1380,6 +1391,9 @@ package body Rtsfind is
Name_Integer_IO => Ada_Wide_Wide_Text_IO_Integer_IO, Name_Integer_IO => Ada_Wide_Wide_Text_IO_Integer_IO,
Name_Modular_IO => Ada_Wide_Wide_Text_IO_Modular_IO); Name_Modular_IO => Ada_Wide_Wide_Text_IO_Modular_IO);
To_Load : RTU_Id;
-- Unit to be loaded, from one of the above maps
begin begin
-- Nothing to do if name is not an identifier or a selected component -- Nothing to do if name is not an identifier or a selected component
-- whose selector_name is not an identifier. -- whose selector_name is not an identifier.
...@@ -1419,27 +1433,27 @@ package body Rtsfind is ...@@ -1419,27 +1433,27 @@ package body Rtsfind is
-- they are visible. -- they are visible.
if Name_Buffer (1 .. 12) = "a-textio.ads" then if Name_Buffer (1 .. 12) = "a-textio.ads" then
Load_RTU To_Load := Name_Map (Chrs);
(Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Name_Map (Chrs)).Entity);
elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
Load_RTU To_Load := Wide_Name_Map (Chrs);
(Wide_Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
elsif Name_Buffer (1 .. 12) = "a-ztexio.ads" then elsif Name_Buffer (1 .. 12) = "a-ztexio.ads" then
Load_RTU To_Load := Wide_Wide_Name_Map (Chrs);
(Wide_Wide_Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U))); else
Set_Is_Visible_Child_Unit goto Continue;
(RT_Unit_Table (Wide_Wide_Name_Map (Chrs)).Entity);
end if; end if;
Load_RTU
(To_Load,
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (To_Load).Entity);
Maybe_Add_With (RT_Unit_Table (To_Load));
end if; end if;
<<Continue>> null;
end loop; end loop;
end if; end if;
......
gcc/ada/sem.adb
...@@ -1544,7 +1544,8 @@ package body Sem is ...@@ -1544,7 +1544,8 @@ package body Sem is
when N_Package_Body | N_Subprogram_Body => when N_Package_Body | N_Subprogram_Body =>
-- A body must be the main unit -- A body must be the main unit
pragma Assert (CU = Cunit (Main_Unit)); pragma Assert (Acts_As_Spec (CU)
or else CU = Cunit (Main_Unit));
null; null;
-- All other cases cannot happen -- All other cases cannot happen
...@@ -1573,29 +1574,32 @@ package body Sem is ...@@ -1573,29 +1574,32 @@ package body Sem is
Get_Cunit_Unit_Number (CU); Get_Cunit_Unit_Number (CU);
procedure Assert_Done (Withed_Unit : Node_Id); procedure Assert_Done (Withed_Unit : Node_Id);
-- Assert Withed_Unit is already Done -- Assert Withed_Unit is already Done, unless it's a body. It
-- might seem strange for a with_clause to refer to a body, but
-- this happens in the case of a generic instantiation, which
-- gets transformed into the instance body (and the instance
-- spec is also created). With clauses pointing to the
-- instantiation end up pointing to the instance body.
procedure Assert_Done (Withed_Unit : Node_Id) is procedure Assert_Done (Withed_Unit : Node_Id) is
begin begin
if not Done if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
(Get_Cunit_Unit_Number if not Nkind_In
(Withed_Unit)) (Unit (Withed_Unit), N_Package_Body, N_Subprogram_Body)
then then
Write_Unit_Name
(Unit_Name Write_Unit_Name
(Get_Cunit_Unit_Number (Unit_Name
(Withed_Unit))); (Get_Cunit_Unit_Number
Write_Str (" not yet walked!"); (Withed_Unit)));
Write_Eol; Write_Str (" not yet walked!");
end if; if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
Write_Str (" (self-ref)");
if False then end if;
-- This assertion is disabled because it fails in the Write_Eol;
-- presence of subunits.
pragma Assert -- ??? pragma Assert (False);
(Done end if;
(Get_Cunit_Unit_Number (Withed_Unit)));
null;
end if; end if;
end Assert_Done; end Assert_Done;
...@@ -1608,15 +1612,7 @@ package body Sem is ...@@ -1608,15 +1612,7 @@ package body Sem is
-- Main unit should come last -- Main unit should come last
if Done (Main_Unit) then pragma Assert (not Done (Main_Unit));
Write_Line ("Main unit is done!");
end if;
if False then -- ???
-- This assertion is disabled because it fails in the
-- presence of subunits.
pragma Assert (not Done (Main_Unit));
null;
end if;
-- We shouldn't do the same thing twice -- We shouldn't do the same thing twice
...@@ -1624,7 +1620,8 @@ package body Sem is ...@@ -1624,7 +1620,8 @@ package body Sem is
-- Everything we depend upon should already be done -- Everything we depend upon should already be done
Assert_Withed_Units_Done (CU, Include_Limited => False); pragma Debug
(Assert_Withed_Units_Done (CU, Include_Limited => False));
end; end;
else else
...@@ -1645,8 +1642,8 @@ package body Sem is ...@@ -1645,8 +1642,8 @@ package body Sem is
---------------------------- ----------------------------
procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
Unit_Num : constant Unit_Number_Type := Unit_Num : constant Unit_Number_Type :=
Get_Cunit_Unit_Number (CU); Get_Cunit_Unit_Number (CU);
procedure Do_Withed_Unit (Withed_Unit : Node_Id); procedure Do_Withed_Unit (Withed_Unit : Node_Id);
-- Pass the buck to Do_Unit_And_Dependents -- Pass the buck to Do_Unit_And_Dependents
...@@ -1670,7 +1667,13 @@ package body Sem is ...@@ -1670,7 +1667,13 @@ package body Sem is
declare declare
Spec_Unit : constant Node_Id := Library_Unit (CU); Spec_Unit : constant Node_Id := Library_Unit (CU);
begin begin
Do_Unit_And_Dependents (Spec_Unit, Unit (Spec_Unit)); if Spec_Unit = CU then -- ???Why needed?
pragma Assert (Acts_As_Spec (CU));
null;
else
Do_Unit_And_Dependents (Spec_Unit, Unit (Spec_Unit));
end if;
end; end;
end if; end if;
...@@ -1681,6 +1684,7 @@ package body Sem is ...@@ -1681,6 +1684,7 @@ package body Sem is
-- Process the unit itself -- Process the unit itself
if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
or else Acts_As_Spec (CU)
or else CU = Cunit (Main_Unit) or else CU = Cunit (Main_Unit)
then then
...@@ -1689,13 +1693,20 @@ package body Sem is ...@@ -1689,13 +1693,20 @@ package body Sem is
Done (Unit_Num) := True; Done (Unit_Num) := True;
end if; end if;
-- Process the corresponding body last -- Process corresponding body of spec last. However, if this body is
-- the main unit (because some dependent of the main unit depends on
-- the main unit's spec), we don't process it now. We also skip
-- processing of the body of a unit named by pragma Extend_System,
-- because it has cyclic dependences in some cases.
if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) then if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) then
declare declare
Body_Unit : constant Node_Id := Library_Unit (CU); Body_Unit : constant Node_Id := Library_Unit (CU);
begin begin
if Present (Body_Unit) then if Present (Body_Unit)
and then Body_Unit /= Cunit (Main_Unit)
and then Unit_Num /= Get_Source_Unit (System_Aux_Id)
then
Do_Unit_And_Dependents (Body_Unit, Unit (Body_Unit)); Do_Unit_And_Dependents (Body_Unit, Unit (Body_Unit));
end if; end if;
end; end;
...@@ -1738,7 +1749,7 @@ package body Sem is ...@@ -1738,7 +1749,7 @@ package body Sem is
Entity : Node_Id := N; Entity : Node_Id := N;
begin begin
if Nkind (N) = N_Subprogram_Body then if Nkind (Entity) = N_Subprogram_Body then
Entity := Specification (Entity); Entity := Specification (Entity);
end if; end if;
...@@ -1910,7 +1921,7 @@ package body Sem is ...@@ -1910,7 +1921,7 @@ package body Sem is
-- Skip the rest if we're not supposed to print the withs -- Skip the rest if we're not supposed to print the withs
if False and then not Withs then -- ??? if not Withs then
return; return;
end if; end if;
......
gcc/ada/sem_ch12.adb
...@@ -4392,7 +4392,7 @@ package body Sem_Ch12 is ...@@ -4392,7 +4392,7 @@ package body Sem_Ch12 is
-- If the instance is not the main unit, its context, categorization, -- If the instance is not the main unit, its context, categorization,
-- and elaboration entity are not relevant to the compilation. -- and elaboration entity are not relevant to the compilation.
if Parent (N) /= Cunit (Main_Unit) then if Body_Cunit /= Cunit (Main_Unit) then
Make_Instance_Unit (Body_Cunit, In_Main => False); Make_Instance_Unit (Body_Cunit, In_Main => False);
return; return;
end if; end if;
......
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