OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2009-04-24 15:59:23 +02:00
parent e211f8596d
commit aca5329845
8 changed files with 428 additions and 400 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/ada/ChangeLog
View File

@ -1,3 +1,31 @@
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>
* errout.ads: Minor reformatting

11
gcc/ada/lib-load.adb
View File

@ -812,7 +812,16 @@ package body Lib.Load is
-- units table when first loaded as a declaration.
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 Make_Instance_Unit;

600
gcc/ada/prj-nmsc.adb
View File

@ -205,6 +205,9 @@ package body Prj.Nmsc is
end record;
No_Name_And_Index : constant Name_And_Index :=
(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
(Header_Num => Header_Num,
@ -233,8 +236,7 @@ package body Prj.Nmsc is
Display_File : File_Name_Type;
Lang_Kind : Language_Kind;
Naming_Exception : Boolean := False;
Path : Path_Name_Type := No_Path;
Display_Path : Path_Name_Type := No_Path;
Path : Path_Information := No_Path_Information;
Alternate_Languages : Alternate_Language_Id := No_Alternate_Language;
Other_Part : Source_Id := No_Source;
Unit : Name_Id := No_Name;
@ -355,7 +357,6 @@ package body Prj.Nmsc is
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Current_Dir : String;
Explicit_Sources_Only : Boolean);
-- Find all Ada sources by traversing all source directories.
-- If Explicit_Sources_Only is True, then the sources found must belong to
@ -390,10 +391,9 @@ package body Prj.Nmsc is
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Name : String;
Path : Path_Name_Type;
File_Name : File_Name_Type;
Display_File_Name : File_Name_Type;
Source_Directory : String;
For_All_Sources : Boolean);
-- Check if file File_Name is a valid source of the project. This is used
-- in multi-language mode only.
@ -464,8 +464,7 @@ package body Prj.Nmsc is
-- Source_Names.
procedure Find_Sources
(Current_Dir : String;
Project : Project_Id;
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data);
-- Process the Source_Files and Source_List_File attributes, and store
@ -499,7 +498,7 @@ package body Prj.Nmsc is
-- 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
-- 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
(Suffix : File_Name_Type;
@ -532,15 +531,11 @@ package body Prj.Nmsc is
procedure Look_For_Sources
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Current_Dir : String);
Data : in out Project_Data);
-- Find all the sources of project Project in project tree In_Tree and
-- update its Data accordingly. This assumes that Data.First_Source has
-- been initialized with the list of excluded sources and special naming
-- exceptions.
--
-- Current_Dir should represent the current directory, and is passed for
-- efficiency to avoid system calls to recompute it.
function Path_Name_Of
(File_Name : File_Name_Type;
@ -561,15 +556,12 @@ package body Prj.Nmsc is
Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Ada_Language : Language_Ptr;
Location : Source_Ptr;
Current_Source : in out String_List_Id;
Source_Recorded : in out Boolean;
Current_Dir : String);
Source_Recorded : in out Boolean);
-- Put a unit in the list of units of a project, if the file name
-- corresponds to a valid unit name.
--
-- Current_Dir should represent the current directory, and is passed for
-- efficiency to avoid system calls to recompute it.
-- Ada_Language is a pointer to the Language_Data for "Ada" in Project.
procedure Remove_Source
(Id : Source_Id;
@ -684,8 +676,7 @@ package body Prj.Nmsc is
Display_File : File_Name_Type;
Lang_Kind : Language_Kind;
Naming_Exception : Boolean := False;
Path : Path_Name_Type := No_Path;
Display_Path : Path_Name_Type := No_Path;
Path : Path_Information := No_Path_Information;
Alternate_Languages : Alternate_Language_Id := No_Alternate_Language;
Other_Part : Source_Id := No_Source;
Unit : Name_Id := No_Name;
@ -744,9 +735,9 @@ package body Prj.Nmsc is
Id.Switches := Switches_Name (File_Name);
end if;
if Path /= No_Path then
Id.Path := (Path, Display_Path);
Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path, Id);
if Path /= No_Path_Information then
Id.Path := Path;
Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path.Name, Id);
end if;
-- Add the source id to the Unit_Sources_HT hash table, if the unit name
@ -870,7 +861,7 @@ package body Prj.Nmsc is
-- Find the sources
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
@ -6895,8 +6886,7 @@ package body Prj.Nmsc is
------------------
procedure Find_Sources
(Current_Dir : String;
Project : Project_Id;
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data)
is
@ -7056,7 +7046,7 @@ package body Prj.Nmsc is
if Get_Mode = Ada_Only then
Find_Ada_Sources
(Project, In_Tree, Data, Current_Dir,
(Project, In_Tree, Data,
Explicit_Sources_Only => Has_Explicit_Sources);
else
@ -7152,21 +7142,27 @@ package body Prj.Nmsc is
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Current_Dir : String;
Explicit_Sources_Only : Boolean)
is
Source_Dir : String_List_Id;
Element : String_Element;
Dir : Dir_Type;
Current_Source : String_List_Id := Nil_String;
Dir_Has_Source : Boolean := False;
NL : Name_Location;
Ada_Language : Language_Ptr;
begin
if Current_Verbosity = High then
Write_Line ("Looking for Ada sources:");
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
-- table Source_Names.
@ -7213,7 +7209,7 @@ package body Prj.Nmsc is
(Name => Name_Buffer (1 .. Name_Len),
Directory => Dir_Path (Dir_Path'First .. Dir_Last),
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True);
Case_Sensitive => True); -- no case folding
Path_Name : Path_Name_Type;
To_Record : Boolean := False;
@ -7257,10 +7253,9 @@ package body Prj.Nmsc is
Project => Project,
In_Tree => In_Tree,
Data => Data,
Ada_Language => Ada_Language,
Location => Location,
Current_Source => Current_Source,
Source_Recorded => Dir_Has_Source,
Current_Dir => Current_Dir);
Source_Recorded => Dir_Has_Source);
end if;
end;
end loop;
@ -7435,22 +7430,14 @@ package body Prj.Nmsc is
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Name : String;
Path : Path_Name_Type;
File_Name : File_Name_Type;
Display_File_Name : File_Name_Type;
Source_Directory : String;
For_All_Sources : Boolean)
is
Display_Path : constant String :=
Normalize_Pathname
(Name => Name,
Directory => Source_Directory,
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True);
Canonical_Path : constant Path_Name_Type :=
Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path)));
Name_Loc : Name_Location := Source_Names.Get (File_Name);
Path_Id : Path_Name_Type;
Display_Path_Id : Path_Name_Type;
Check_Name : Boolean := False;
Alternate_Languages : Alternate_Language_Id := No_Alternate_Language;
Language : Language_Ptr;
@ -7468,17 +7455,6 @@ package body Prj.Nmsc is
Iter : Source_Iterator;
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
Check_Name := For_All_Sources;
@ -7505,11 +7481,11 @@ package body Prj.Nmsc is
Check_Name := True;
else
Name_Loc.Source.Path := (Path_Id, Display_Path_Id);
Name_Loc.Source.Path := (Canonical_Path, Path);
Source_Paths_Htable.Set
(In_Tree.Source_Paths_HT,
Path_Id,
Canonical_Path,
Name_Loc.Source);
-- Check if this is a subunit
@ -7518,7 +7494,7 @@ package body Prj.Nmsc is
and then Name_Loc.Source.Kind = Impl
then
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
Name_Loc.Source.Kind := Sep;
@ -7631,7 +7607,7 @@ package body Prj.Nmsc is
Error_Msg_Name_1 :=
In_Tree.Projects.Table (Project).Name;
Error_Msg_Name_2 := Name_Id (Display_Path_Id);
Error_Msg_Name_2 := Name_Id (Path);
Error_Msg
(Project, In_Tree, "\ project %%, %%", No_Location);
@ -7661,8 +7637,7 @@ package body Prj.Nmsc is
Display_File => Display_File_Name,
Other_Part => Other_Part,
Unit => Unit,
Path => Path_Id,
Display_Path => Display_Path_Id,
Path => (Canonical_Path, Path),
Source_To_Replace => Source_To_Replace);
end if;
end if;
@ -7749,10 +7724,23 @@ package body Prj.Nmsc is
end if;
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 :=
Excluded_Sources_Htable.Get (File_Name);
begin
Name_Len := Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Path_Name;
Path := Name_Find;
if FF /= No_File_Found then
if not FF.Found then
FF.Found := True;
@ -7771,11 +7759,9 @@ package body Prj.Nmsc is
(Project => Project,
In_Tree => In_Tree,
Data => Data,
Name => Name (1 .. Last),
Path => Path,
File_Name => File_Name,
Display_File_Name => Display_File_Name,
Source_Directory => Source_Directory
(Source_Directory'First .. Dir_Last),
For_All_Sources => For_All_Sources);
end if;
end;
@ -7874,8 +7860,7 @@ package body Prj.Nmsc is
procedure Look_For_Sources
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Current_Dir : String)
Data : in out Project_Data)
is
Iter : Source_Iterator;
@ -8113,7 +8098,7 @@ package body Prj.Nmsc is
Load_Naming_Exceptions (Project, In_Tree);
end if;
Find_Sources (Current_Dir, Project, In_Tree, Data);
Find_Sources (Project, In_Tree, Data);
Mark_Excluded_Sources;
if Get_Mode = Multi_Language then
@ -8204,13 +8189,193 @@ package body Prj.Nmsc is
Project : Project_Id;
In_Tree : Project_Tree_Ref;
Data : in out Project_Data;
Ada_Language : Language_Ptr;
Location : Source_Ptr;
Current_Source : in out String_List_Id;
Source_Recorded : in out Boolean;
Current_Dir : String)
Source_Recorded : in out Boolean)
is
Canonical_File_Name : File_Name_Type;
Canonical_Path_Name : Path_Name_Type;
Canonical_File : File_Name_Type;
Canonical_Path : Path_Name_Type;
File_Recorded : Boolean := False;
-- True when at least one file has been recorded
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)
-----------------
-- Record_Unit --
-----------------
procedure Record_Unit
(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;
begin
if Current_Verbosity = High then
Write_Str (" Putting ");
Write_Str (Get_Name_String (Unit_Name));
Write_Line (" in the unit list.");
end if;
-- The unit is already in the list, but may be it is only the other
-- unit kind (spec or body), or what is in the unit list is a unit of
-- a project we are extending.
if The_Unit /= No_Unit_Index then
UData := In_Tree.Units.Table (The_Unit);
if (UData.File_Names (Unit_Kind).Name = Canonical_File
and then UData.File_Names (Unit_Kind).Path.Name = Slash)
or else UData.File_Names (Unit_Kind).Name = No_File
or else Is_Extending
(Data.Extends,
UData.File_Names (Unit_Kind).Project,
In_Tree)
then
if UData.File_Names (Unit_Kind).Path.Name = Slash then
Remove_Forbidden_File_Name
(UData.File_Names (Unit_Kind).Name);
end if;
-- Record the file name in the hash table Files_Htable
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;
-- Else, same unit but not same file => It is an error to have two
-- units with the same name and the same kind (spec or body).
else
if The_Location = No_Location then
The_Location := In_Tree.Projects.Table (Project).Location;
end if;
Err_Vars.Error_Msg_Name_1 := Unit_Name;
Error_Msg
(Project, In_Tree, "duplicate unit %%", The_Location);
Err_Vars.Error_Msg_Name_1 :=
In_Tree.Projects.Table
(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);
Err_Vars.Error_Msg_Name_1 :=
In_Tree.Projects.Table (Project).Name;
Err_Vars.Error_Msg_File_1 := File_Name_Type (Canonical_Path);
Error_Msg
(Project, In_Tree, "\ project file %%, {", The_Location);
To_Record := False;
end if;
-- It is a new unit, create a new record
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.
Unit_Prj := Files_Htable.Get (In_Tree.Files_HT, Canonical_File);
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);
else
Unit_Table.Increment_Last (In_Tree.Units);
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, 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;
if To_Record then
case Unit_Kind is
when Body_Part => Kind := Impl;
when Specification => Kind := Spec;
end case;
Add_Source
(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;
Exception_Id : Ada_Naming_Exception_Id;
Unit_Name : Name_Id;
@ -8218,42 +8383,19 @@ package body Prj.Nmsc is
Unit_Ind : Int := 0;
Info : Unit_Info;
Name_Index : Name_And_Index;
Except_Name : Name_And_Index := No_Name_And_Index;
Needs_Pragma : Boolean;
The_Location : Source_Ptr := Location;
Previous_Source : constant String_List_Id := Current_Source;
Except_Name : Name_And_Index := No_Name_And_Index;
Unit_Prj : Unit_Project;
File_Name_Recorded : Boolean := False;
begin
Canonical_File_Name := Canonical_Case_File_Name (Name_Id (File_Name));
Canonical_File := Canonical_Case_File_Name (Name_Id (File_Name));
Canonical_Path :=
Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path_Name)));
if Osint.File_Names_Case_Sensitive then
Canonical_Path_Name := Path_Name;
else
declare
Canonical_Path : constant String :=
Normalize_Pathname
(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
-- a specific SFN pragma.
-- Check the naming scheme to get extra file properties
Get_Unit
(In_Tree => In_Tree,
Canonical_File_Name => Canonical_File_Name,
Canonical_File_Name => Canonical_File,
Naming => Data.Naming,
Exception_Id => Exception_Id,
Unit_Name => Unit_Name,
@ -8265,226 +8407,58 @@ package body Prj.Nmsc is
then
if Current_Verbosity = High then
Write_Str (" """);
Write_Str (Get_Name_String (Canonical_File_Name));
Write_Str (Get_Name_String (Canonical_File));
Write_Line (""" is not a valid source file name (ignored).");
end if;
return;
end if;
else
-- Check to see if the source has been hidden by an exception,
-- but only if it is not an exception.
-- Check to see if the source has been hidden by an exception,
-- but only if it is not an exception.
if not Needs_Pragma then
Except_Name :=
Reverse_Ada_Naming_Exceptions.Get
((Unit_Kind, Unit_Name, No_Ada_Naming_Exception));
if not Needs_Pragma then
Except_Name :=
Reverse_Ada_Naming_Exceptions.Get
((Unit_Kind, Unit_Name, No_Ada_Naming_Exception));
if Except_Name /= No_Name_And_Index then
if Current_Verbosity = High then
Write_Str (" """);
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;
-- The file is not included in the source of the project since
-- it is hidden by the exception. So, nothing else to do.
return;
if Except_Name /= No_Name_And_Index then
if Current_Verbosity = High then
Write_Str (" """);
Write_Str (Get_Name_String (Canonical_File));
Write_Str (""" contains a unit that is found in """);
Write_Str (Get_Name_String (Except_Name.Name));
Write_Line (""" (ignored).");
end if;
-- The file is not included in the source of the project since
-- it is hidden by the exception. So, nothing else to do.
return;
end if;
end if;
-- The following loop registers the unit in the appropriate table. It
-- 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.
loop
if Exception_Id /= No_Ada_Naming_Exception then
Info := Ada_Naming_Exception_Table.Table (Exception_Id);
Exception_Id := Info.Next;
Info.Next := No_Ada_Naming_Exception;
Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info);
Unit_Name := Info.Unit;
Unit_Ind := Name_Index.Index;
Unit_Kind := Info.Kind;
end if;
loop
if Exception_Id /= No_Ada_Naming_Exception then
Info := Ada_Naming_Exception_Table.Table (Exception_Id);
Exception_Id := Info.Next;
Info.Next := No_Ada_Naming_Exception;
Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info);
Record_Unit (Unit_Name, Unit_Ind, Unit_Kind, Needs_Pragma);
File_Recorded := True;
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
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;
Current_Source :=
String_Element_Table.Last (In_Tree.String_Elements);
-- Put the unit in unit list
declare
The_Unit : Unit_Index :=
Units_Htable.Get (In_Tree.Units_HT, Unit_Name);
The_Unit_Data : Unit_Data;
begin
if Current_Verbosity = High then
Write_Str (" Putting ");
Write_Str (Get_Name_String (Unit_Name));
Write_Line (" in the unit list.");
end if;
-- The unit is already in the list, but may be it is
-- only the other unit kind (spec or body), or what is
-- in the unit list is a unit of a project we are extending.
if The_Unit /= No_Unit_Index then
The_Unit_Data := In_Tree.Units.Table (The_Unit);
if (The_Unit_Data.File_Names (Unit_Kind).Name =
Canonical_File_Name
and then
The_Unit_Data.File_Names
(Unit_Kind).Path.Name = Slash)
or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File
or else Is_Extending
(Data.Extends,
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
Unit_Prj := (Unit => The_Unit, Project => Project);
Files_Htable.Set
(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;
else
-- It is an error to have two units with the same name
-- and the same kind (spec or body).
if The_Location = No_Location then
The_Location :=
In_Tree.Projects.Table (Project).Location;
end if;
Err_Vars.Error_Msg_Name_1 := Unit_Name;
Error_Msg
(Project, In_Tree, "duplicate unit %%", The_Location);
Err_Vars.Error_Msg_Name_1 :=
In_Tree.Projects.Table
(The_Unit_Data.File_Names (Unit_Kind).Project).Name;
Err_Vars.Error_Msg_File_1 :=
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 :=
In_Tree.Projects.Table (Project).Name;
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (Canonical_Path_Name);
Error_Msg
(Project, In_Tree,
"\ project file %%, {", The_Location);
end if;
-- It is a new unit, create a new record
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.
Unit_Prj :=
Files_Htable.Get (In_Tree.Files_HT, Canonical_File_Name);
if not File_Name_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);
else
Unit_Table.Increment_Last (In_Tree.Units);
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;
File_Name_Recorded := True;
end loop;
end if;
exit when Exception_Id = No_Ada_Naming_Exception;
end loop;
end Record_Ada_Source;
-------------------

5
gcc/ada/prj.adb
View File

@ -105,7 +105,6 @@ package body Prj is
Lib_Auto_Init => False,
Libgnarl_Needed => Unknown,
Symbol_Data => No_Symbols,
Ada_Sources => Nil_String,
Interfaces_Defined => False,
Include_Path => null,
Include_Data_Set => False,
@ -1205,10 +1204,6 @@ package body Prj is
Lang : Language_Ptr;
begin
if Data.Ada_Sources /= Nil_String then
return True;
end if;
Lang := Data.Languages;
while Lang /= No_Language_Index loop
if Lang.Name = Name_Ada then

7
gcc/ada/prj.ads
View File

@ -1256,11 +1256,8 @@ package Prj is
-------------
-- Sources --
-------------
-- In multi-language mode, the sources for all languages including Ada
-- are accessible through the Source_Iterator type
Ada_Sources : String_List_Id := Nil_String;
-- The list of all the Ada source file names (gnatmake only).
-- The sources for all languages including Ada are accessible through
-- the Source_Iterator type
Interfaces_Defined : Boolean := False;
-- True if attribute Interfaces is declared for the project or any

90
gcc/ada/rtsfind.adb
View File

@ -164,25 +164,26 @@ package body Rtsfind is
Id : RE_Id := RE_Null;
Use_Setting : Boolean := False);
-- 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
-- RT_Unit_Table is updated to reflect the load. Use_Setting is used to
-- indicate the initial setting for the Is_Potentially_Use_Visible flag of
-- the entity for the loaded unit (if it is indeed loaded). A value of
-- False means nothing special need be done. A value of True indicates that
-- this flag must be set to True. It is needed only in the Text_IO_Kludge
-- procedure, which may materialize an entity of Text_IO (or
-- [Wide_]Wide_Text_IO) that was previously unknown. Id is the RE_Id value
-- of the entity which was originally requested. Id is used only for error
-- message detail, and if it is RE_Null, then the attempt to output the
-- entity name is ignored.
-- loaded and analyzed, and the entry in RT_Unit_Table is updated to
-- reflect the load. Use_Setting is used to indicate the initial setting
-- for the Is_Potentially_Use_Visible flag of the entity for the loaded
-- unit (if it is indeed loaded). A value of False means nothing special
-- need be done. A value of True indicates that this flag must be set to
-- True. It is needed only in the Text_IO_Kludge procedure, which may
-- materialize an entity of Text_IO (or [Wide_]Wide_Text_IO) that was
-- previously unknown. Id is the RE_Id value of the entity which was
-- originally requested. Id is used only for error message detail, and if
-- it is RE_Null, then the attempt to output the entity name is ignored.
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id;
function Make_Unit_Name
(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
-- 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
-- one represented by E and U.
-- one represented by U.
procedure Output_Entity_Name (Id : RE_Id; Msg : String);
-- Output continuation error message giving qualified name of entity
@ -765,9 +766,10 @@ package body Rtsfind is
-- Make_Unit_Name --
--------------------
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
function Make_Unit_Name
(U : RT_Unit_Table_Record;
N : Node_Id) return Node_Id is
Nam : Node_Id;
Scop : Entity_Id;
@ -795,15 +797,24 @@ package body Rtsfind is
-- 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 :=
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit));
begin
-- 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;
end if;
@ -836,7 +847,7 @@ package body Rtsfind is
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(E, Defining_Unit_Name (Specification (LibUnit))));
(U, Defining_Unit_Name (Specification (LibUnit))));
begin
Set_Library_Unit (Withn, Cunit (U.Unum));
@ -1127,7 +1138,7 @@ package body Rtsfind is
end if;
<<Found>>
Maybe_Add_With (E, U);
Maybe_Add_With (U);
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, RE_Table (E));
@ -1229,7 +1240,7 @@ package body Rtsfind is
-- If we didn't find the entity we want, something is wrong. The
-- 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;
return Check_CRT (E, Found_E);
@ -1380,6 +1391,9 @@ package body Rtsfind is
Name_Integer_IO => Ada_Wide_Wide_Text_IO_Integer_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
-- Nothing to do if name is not an identifier or a selected component
-- whose selector_name is not an identifier.
@ -1419,27 +1433,27 @@ package body Rtsfind is
-- they are visible.
if Name_Buffer (1 .. 12) = "a-textio.ads" then
Load_RTU
(Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Name_Map (Chrs)).Entity);
To_Load := Name_Map (Chrs);
elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
Load_RTU
(Wide_Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
To_Load := Wide_Name_Map (Chrs);
elsif Name_Buffer (1 .. 12) = "a-ztexio.ads" then
Load_RTU
(Wide_Wide_Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Wide_Wide_Name_Map (Chrs)).Entity);
To_Load := Wide_Wide_Name_Map (Chrs);
else
goto Continue;
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;
<<Continue>> null;
end loop;
end if;

85
gcc/ada/sem.adb
View File

@ -1544,7 +1544,8 @@ package body Sem is
when N_Package_Body | N_Subprogram_Body =>
-- 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;
-- All other cases cannot happen
@ -1573,29 +1574,32 @@ package body Sem is
Get_Cunit_Unit_Number (CU);
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
begin
if not Done
(Get_Cunit_Unit_Number
(Withed_Unit))
then
Write_Unit_Name
(Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit)));
Write_Str (" not yet walked!");
Write_Eol;
end if;
if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
if not Nkind_In
(Unit (Withed_Unit), N_Package_Body, N_Subprogram_Body)
then
if False then
-- This assertion is disabled because it fails in the
-- presence of subunits.
pragma Assert -- ???
(Done
(Get_Cunit_Unit_Number (Withed_Unit)));
null;
Write_Unit_Name
(Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit)));
Write_Str (" not yet walked!");
if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
Write_Str (" (self-ref)");
end if;
Write_Eol;
pragma Assert (False);
end if;
end if;
end Assert_Done;
@ -1608,15 +1612,7 @@ package body Sem is
-- Main unit should come last
if Done (Main_Unit) then
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;
pragma Assert (not Done (Main_Unit));
-- We shouldn't do the same thing twice
@ -1624,7 +1620,8 @@ package body Sem is
-- 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;
else
@ -1645,8 +1642,8 @@ package body Sem is
----------------------------
procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
Unit_Num : constant Unit_Number_Type :=
Get_Cunit_Unit_Number (CU);
Unit_Num : constant Unit_Number_Type :=
Get_Cunit_Unit_Number (CU);
procedure Do_Withed_Unit (Withed_Unit : Node_Id);
-- Pass the buck to Do_Unit_And_Dependents
@ -1670,7 +1667,13 @@ package body Sem is
declare
Spec_Unit : constant Node_Id := Library_Unit (CU);
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 if;
@ -1681,6 +1684,7 @@ package body Sem is
-- Process the unit itself
if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
or else Acts_As_Spec (CU)
or else CU = Cunit (Main_Unit)
then
@ -1689,13 +1693,20 @@ package body Sem is
Done (Unit_Num) := True;
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
declare
Body_Unit : constant Node_Id := Library_Unit (CU);
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));
end if;
end;
@ -1738,7 +1749,7 @@ package body Sem is
Entity : Node_Id := N;
begin
if Nkind (N) = N_Subprogram_Body then
if Nkind (Entity) = N_Subprogram_Body then
Entity := Specification (Entity);
end if;
@ -1910,7 +1921,7 @@ package body Sem is
-- Skip the rest if we're not supposed to print the withs
if False and then not Withs then -- ???
if not Withs then
return;
end if;

2
gcc/ada/sem_ch12.adb
View File

@ -4392,7 +4392,7 @@ package body Sem_Ch12 is
-- If the instance is not the main unit, its context, categorization,
-- 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);
return;
end if;