Skip to content

R
riscv-gcc-1
Commit fc2c32e2 by Emmanuel Briot Committed by Arnaud Charlet
Options

gnatcmd.adb, [...] (Immediate_Directory_Of): Removed. 

2009-07-13  Emmanuel Briot  <briot@adacore.com>

	* gnatcmd.adb, make.adb, mlib-prj.adb, prj-part.adb, mlib.adb,
	prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb,
	prj-pars.ads, prj-conf.adb, prj-conf.ads, prj-tree.adb,
	prj-tree.ads (Immediate_Directory_Of): Removed.
	(Prj.Pars): Now parse the project simulating a default config file.
	(Add_Default_GNAT_Naming_Scheme): New subprogram
	(Check_Naming_Multi_Lang): Fix default value for Dot_Replacement.
	Remove gnatmake-specific parsing of source files.
	(Check_Illegal_Suffix): Renames Is_Illegal_Suffix, since it now raises
	the error itself to provide more precise diagnostics.
	(Process_Exceptions_Unit_Based): Avoid duplicate error message when
	a unit belongs to several projects.
	(Copy_Interface_Sources): Search the full path of files to copy in the
	list of sources of the application rather than in the list of units.
	(Parse_Project_And_Apply_Config): Do not reset the name of the main
 	project file.
	(Check_File): Use htables to find out whether a source is duplicated.
	(Add_Source): check whether the source or unit were already seen earlier

	* gcc-interface/Makefile.in: Update gnatmake dependencies.

From-SVN: r149557
parent 1629f700
Showing with 695 additions and 1218 deletions
gcc/ada/ChangeLog
2009-07-13 Emmanuel Briot <briot@adacore.com>
* gnatcmd.adb, make.adb, mlib-prj.adb, prj-part.adb, mlib.adb,
prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb,
prj-pars.ads, prj-conf.adb, prj-conf.ads, prj-tree.adb,
prj-tree.ads (Immediate_Directory_Of): Removed.
(Prj.Pars): Now parse the project simulating a default config file.
(Add_Default_GNAT_Naming_Scheme): New subprogram
(Check_Naming_Multi_Lang): Fix default value for Dot_Replacement.
Remove gnatmake-specific parsing of source files.
(Check_Illegal_Suffix): Renames Is_Illegal_Suffix, since it now raises
the error itself to provide more precise diagnostics.
(Process_Exceptions_Unit_Based): Avoid duplicate error message when
a unit belongs to several projects.
(Copy_Interface_Sources): Search the full path of files to copy in the
list of sources of the application rather than in the list of units.
(Parse_Project_And_Apply_Config): Do not reset the name of the main
project file.
(Check_File): Use htables to find out whether a source is duplicated.
(Add_Source): check whether the source or unit were already seen earlier
* gcc-interface/Makefile.in: Update gnatmake dependencies.
2009-07-13 Robert Dewar <dewar@adacore.com>
* par-ch3.adb (P_Discrete_Choice_List): Choice can only be simple
......
gcc/ada/clean.adb
......@@ -1391,8 +1391,7 @@ package body Clean is
(Project => Main_Project,
In_Tree => Project_Tree,
Project_File_Name => Project_File_Name.all,
Packages_To_Check => Packages_To_Check_By_Gnatmake,
Is_Config_File => False);
Packages_To_Check => Packages_To_Check_By_Gnatmake);
if Main_Project = No_Project then
Fail ("""" & Project_File_Name.all & """ processing failed");
......
gcc/ada/gcc-interface/Makefile.in
......@@ -295,6 +295,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \
make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o \
mlib-tgt-specific.o mlib-utl.o namet.o nlists.o opt.o osint.o osint-m.o \
output.o prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o \
prj-conf.o \
prj-err.o prj-ext.o prj-nmsc.o prj-pars.o prj-part.o prj-proc.o prj-strt.o \
prj-tree.o prj-util.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o sinfo.o sinput.o \
......
gcc/ada/gnatcmd.adb
......@@ -365,7 +365,6 @@ procedure GNATCmd is
new String'
(Get_Name_String
(Proj.Project.Object_Directory.Name) &
Directory_Separator &
B_Start.all &
MLib.Fil.Ext_To
(Get_Name_String
......@@ -392,7 +391,6 @@ procedure GNATCmd is
new String'
(Get_Name_String
(Proj.Project.Object_Directory.Name) &
Directory_Separator &
B_Start.all &
Get_Name_String (Proj.Project.Library_Name) &
".ci");
......@@ -514,7 +512,6 @@ procedure GNATCmd is
(Get_Name_String
(Unit.File_Names
(Impl).Project. Object_Directory.Name) &
Directory_Separator &
MLib.Fil.Ext_To
(Get_Name_String
(Unit.File_Names (Impl).Display_File),
......@@ -1077,7 +1074,6 @@ procedure GNATCmd is
begin
if Is_Regular_File
(Dir &
Directory_Separator &
ALI_File (1 .. Last))
then
-- We have found the correct project, so we
......@@ -1085,8 +1081,8 @@ procedure GNATCmd is
Last_Switches.Table (J) :=
new String'
(Dir & Directory_Separator &
ALI_File (1 .. Last));
(Dir
& ALI_File (1 .. Last));
-- And we are done
......@@ -1155,7 +1151,6 @@ procedure GNATCmd is
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Name_Buffer (1 .. Name_Len) &
Directory_Separator &
Executable_Name
(Base_Name (Arg (Arg'First .. Last))));
exit;
......@@ -1784,8 +1779,7 @@ begin
(Project => Project,
In_Tree => Project_Tree,
Project_File_Name => Project_File.all,
Packages_To_Check => Packages_To_Check,
Is_Config_File => False);
Packages_To_Check => Packages_To_Check);
if Project = Prj.No_Project then
Fail ("""" & Project_File.all & """ processing failed");
......
gcc/ada/make.adb
......@@ -1978,12 +1978,8 @@ package body Make is
Name_Len := 0;
Add_Str_To_Name_Buffer (Res_Obj_Dir);
if Name_Len > 1 and then
(Name_Buffer (Name_Len) = '/'
or else
Name_Buffer (Name_Len) = Directory_Separator)
then
Name_Len := Name_Len - 1;
if not Is_Directory_Separator (Name_Buffer (Name_Len)) then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Obj_Dir := Name_Find;
......@@ -4450,8 +4446,8 @@ package body Make is
(ALI_Project.Object_Directory.Name);
end if;
if Name_Buffer (Name_Len) /=
Directory_Separator
if not Is_Directory_Separator
(Name_Buffer (Name_Len))
then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
......@@ -5312,7 +5308,9 @@ package body Make is
if not Is_Absolute_Path (Exec_File_Name) then
Get_Name_String (Main_Project.Exec_Directory.Name);
if Name_Buffer (Name_Len) /= Directory_Separator then
if
not Is_Directory_Separator (Name_Buffer (Name_Len))
then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
......@@ -6867,8 +6865,7 @@ package body Make is
(Project => Main_Project,
In_Tree => Project_Tree,
Project_File_Name => Project_File_Name.all,
Packages_To_Check => Packages_To_Check_By_Gnatmake,
Is_Config_File => False);
Packages_To_Check => Packages_To_Check_By_Gnatmake);
-- The parsing of project files may have changed the current output
......@@ -7611,8 +7608,7 @@ package body Make is
-- separator.
if Argv (Argv'Last) = Directory_Separator then
Object_Directory_Path :=
new String'(Argv);
Object_Directory_Path := new String'(Argv);
else
Object_Directory_Path :=
new String'(Argv & Directory_Separator);
......
gcc/ada/mlib-prj.adb
......@@ -2152,20 +2152,12 @@ package body MLib.Prj is
First_Unit : ALI.Unit_Id;
Second_Unit : ALI.Unit_Id;
Data : Unit_Index;
Copy_Subunits : Boolean := False;
-- When True, indicates that subunits, if any, need to be copied too
procedure Copy (File_Name : File_Name_Type);
-- Copy one source of the project to the target directory
function Is_Same_Or_Extension
(Extending : Project_Id;
Extended : Project_Id) return Boolean;
-- Return True if project Extending is equal to or extends project
-- Extended.
----------
-- Copy --
----------
......@@ -2174,56 +2166,26 @@ package body MLib.Prj is
Success : Boolean;
pragma Warnings (Off, Success);
Source : Standard.Prj.Source_Id;
begin
Data := Units_Htable.Get_First (In_Tree.Units_HT);
Unit_Loop :
while Data /= No_Unit_Index loop
-- Find and copy the immediate or inherited source
for J in Data.File_Names'Range loop
if Data.File_Names (J) /= null
and then Is_Same_Or_Extension
(For_Project, Data.File_Names (J).Project)
and then Data.File_Names (J).File = File_Name
then
Copy_File
(Get_Name_String (Data.File_Names (J).Path.Name),
Target,
Success,
Mode => Overwrite,
Preserve => Preserve);
exit Unit_Loop;
end if;
end loop;
Data := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop Unit_Loop;
Source := Find_Source
(In_Tree, For_Project,
In_Extended_Only => True,
Base_Name => File_Name);
if Source /= No_Source
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
then
Copy_File
(Get_Name_String (Source.Path.Name),
Target,
Success,
Mode => Overwrite,
Preserve => Preserve);
end if;
end Copy;
--------------------------
-- Is_Same_Or_Extension --
--------------------------
function Is_Same_Or_Extension
(Extending : Project_Id;
Extended : Project_Id) return Boolean
is
Ext : Project_Id;
begin
Ext := Extending;
while Ext /= No_Project loop
if Ext = Extended then
return True;
end if;
Ext := Ext.Extends;
end loop;
return False;
end Is_Same_Or_Extension;
-- Start of processing for Copy_Interface_Sources
begin
......
gcc/ada/mlib.adb
......@@ -55,7 +55,7 @@ package body MLib is
Write_Line (Output_File);
end if;
Ar (Output_Dir & Directory_Separator &
Ar (Output_Dir &
"lib" & Output_File & ".a", Objects => Ofiles);
end Build_Library;
......
gcc/ada/prj-conf.adb
......@@ -34,7 +34,6 @@ with Prj.Proc; use Prj.Proc;
with Prj.Tree; use Prj.Tree;
with Prj.Util; use Prj.Util;
with Prj; use Prj;
with Sinput.P;
with Snames; use Snames;
with System.Case_Util; use System.Case_Util;
with System;
......@@ -908,7 +907,9 @@ package body Prj.Conf is
Report_Error : Put_Line_Access := null;
On_Load_Config : Config_File_Hook := null;
Compiler_Driver_Mandatory : Boolean := True;
Allow_Duplicate_Basenames : Boolean := False)
Allow_Duplicate_Basenames : Boolean := False;
Reset_Tree : Boolean := True;
When_No_Sources : Error_Warning := Warning)
is
Main_Config_Project : Project_Id;
Success : Boolean;
......@@ -923,7 +924,8 @@ package body Prj.Conf is
Success => Success,
From_Project_Node => User_Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Report_Error => Report_Error);
Report_Error => Report_Error,
Reset_Tree => Reset_Tree);
if not Success then
Main_Project := No_Project;
......@@ -951,8 +953,6 @@ package body Prj.Conf is
-- Finish processing the user's project
Sinput.P.Reset_First;
Prj.Proc.Process_Project_Tree_Phase_2
(In_Tree => Project_Tree,
Project => Main_Project,
......@@ -961,7 +961,7 @@ package body Prj.Conf is
From_Project_Node_Tree => Project_Node_Tree,
Report_Error => Report_Error,
Current_Dir => Current_Directory,
When_No_Sources => Warning,
When_No_Sources => When_No_Sources,
Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Is_Config_File => False);
......@@ -1121,4 +1121,76 @@ package body Prj.Conf is
end if;
end Runtime_Name_For;
------------------------------------
-- Add_Default_GNAT_Naming_Scheme --
------------------------------------
procedure Add_Default_GNAT_Naming_Scheme
(Config_File : in out Project_Node_Id;
Project_Tree : Project_Node_Tree_Ref)
is
Name : Name_Id;
begin
if Config_File = Empty_Node then
-- Create a dummy config file is none was found.
Name_Len := Auto_Cgpr'Length;
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
Name := Name_Find;
Config_File := Create_Project
(In_Tree => Project_Tree,
Name => Name,
Full_Path => Path_Name_Type (Name),
Is_Config_File => True);
-- ??? This isn't strictly required, since Prj.Nmsc.Add_Language
-- already has a workaround in the Ada_Only case. But it would be
-- nicer to do it this way
-- Likewise for the default language, hard-coded in
-- Pjr.Nmsc.Check_Programming_Languages
-- Update_Attribute_Value_In_Scenario
-- (Tree => Project_Tree,
-- Project => Config_File,
-- Scenario_Variables => No_Scenario,
-- Attribute => "default_language",
-- Value => "Ada");
--
-- Update_Attribute_Value_In_Scenario
-- (Tree => Project_Tree,
-- Project => Config_File,
-- Scenario_Variables => No_Scenario,
-- Attribute => Separate_Suffix_Attribute,
-- Value => ".adb",
-- Attribute_Index => "Ada");
-- Update_Attribute_Value_In_Scenario
-- (Tree => Project_Tree,
-- Project => Config_File,
-- Scenario_Variables => No_Scenario,
-- Attribute => Spec_Suffix_Attribute,
-- Value => ".ads",
-- Attribute_Index => "Ada");
-- Update_Attribute_Value_In_Scenario
-- (Tree => Project_Tree,
-- Project => Config_File,
-- Scenario_Variables => No_Scenario,
-- Attribute => Impl_Suffix_Attribute,
-- Value => ".adb",
-- Attribute_Index => "Ada");
-- Update_Attribute_Value_In_Scenario
-- (Tree => Project_Tree,
-- Project => Config_File,
-- Scenario_Variables => No_Scenario,
-- Attribute => Dot_Replacement_Attribute,
-- Value => "-");
-- Update_Attribute_Value_In_Scenario
-- (Tree => Project_Tree,
-- Project => Config_File,
-- Scenario_Variables => No_Scenario,
-- Attribute => Casing_Attribute,
-- Value => "lowercase");
end if;
end Add_Default_GNAT_Naming_Scheme;
end Prj.Conf;
gcc/ada/prj-conf.ads
......@@ -99,10 +99,15 @@ package Prj.Conf is
Report_Error : Put_Line_Access := null;
On_Load_Config : Config_File_Hook := null;
Compiler_Driver_Mandatory : Boolean := True;
Allow_Duplicate_Basenames : Boolean := False);
Allow_Duplicate_Basenames : Boolean := False;
Reset_Tree : Boolean := True;
When_No_Sources : Error_Warning := Warning);
-- Same as above, except the project must already have been parsed through
-- Prj.Part.Parse, and only the processing of the project and the
-- configuration is done at this level.
-- If Reset_Tree is true, all projects are first removed from the tree.
-- When_No_Sources indicates what should be done when no sources are found
-- for one of the languages of the project.
Invalid_Config : exception;
......@@ -162,6 +167,15 @@ package Prj.Conf is
-- projects, so that when the second phase of the processing is performed
-- these attributes are automatically taken into account.
procedure Add_Default_GNAT_Naming_Scheme
(Config_File : in out Prj.Tree.Project_Node_Id;
Project_Tree : Prj.Tree.Project_Node_Tree_Ref);
-- A hook for Get_Or_Create_Configuration_File and
-- Process_Project_And_Apply_Config that will create a new config file (in
-- memory) and add the default GNAT naming scheme to it. Nothing is done
-- if the config_file already exists, to avoid overriding what the user
-- might have put in there.
--------------
-- Runtimes --
--------------
......
gcc/ada/prj-nmsc.adb
......@@ -28,7 +28,6 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable;
with Err_Vars; use Err_Vars;
with Hostparm;
with MLib.Tgt;
with Opt; use Opt;
with Osint; use Osint;
......@@ -165,8 +164,8 @@ package body Prj.Nmsc is
package Object_File_Names is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => File_Name_Type,
No_Element => No_File,
Element => Source_Id,
No_Element => No_Source,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
......@@ -235,24 +234,23 @@ package body Prj.Nmsc is
procedure Add_Source
(Id : out Source_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
Project : Project_Id;
Lang_Id : Language_Ptr;
Kind : Source_Kind;
File_Name : File_Name_Type;
Display_File : File_Name_Type;
Allow_Duplicate_Basenames : Boolean;
Naming_Exception : Boolean := False;
Path : Path_Information := No_Path_Information;
Alternate_Languages : Language_List := null;
Unit : Name_Id := No_Name;
Index : Int := 0;
Source_To_Replace : Source_Id := No_Source);
Index : Int := 0);
-- Add a new source to the different lists: list of all sources in the
-- project tree, list of source of a project and list of sources of a
-- language.
--
-- If Path is specified, the file is also added to Source_Paths_HT.
-- If Source_To_Replace is specified, it points to the source in the
-- extended project that the new file is overriding.
function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
-- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
......@@ -278,11 +276,13 @@ package body Prj.Nmsc is
-- Check that a name is a valid Ada unit name
procedure Check_Package_Naming
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Is_Config_File : Boolean;
Bodies : out Array_Element_Id;
Specs : out Array_Element_Id);
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
Is_Config_File : Boolean;
Allow_Duplicate_Basenames : Boolean;
Bodies : out Array_Element_Id;
Specs : out Array_Element_Id);
-- Check the naming scheme part of Data, and initialize the naming scheme
-- data in the config of the various languages. Is_Config_File should be
-- True if Project is a config file (.cgpr) This also returns the naming
......@@ -342,27 +342,6 @@ package body Prj.Nmsc is
-- Current_Dir should represent the current directory, and is passed for
-- efficiency to avoid system calls to recompute it.
procedure Check_And_Normalize_Unit_Names
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
List : Array_Element_Id;
Debug_Name : String);
-- Check that a list of unit names contains only valid names. Casing
-- is normalized where appropriate.
-- Debug_Name is the name representing the list, and is used for debug
-- output only.
procedure Find_Ada_Sources
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Explicit_Sources_Only : Boolean;
Proc_Data : in out Processing_Data);
-- Find all Ada sources by traversing all source directories. If
-- Explicit_Sources_Only is True, then the sources found must belong to
-- the list of sources specified explicitly in the project file. If
-- Explicit_Sources_Only is False, then all sources matching the naming
-- scheme are recorded.
function Compute_Directory_Last (Dir : String) return Natural;
-- Return the index of the last significant character in Dir. This is used
-- to avoid duplicate '/' (slash) characters at the end of directory names.
......@@ -379,6 +358,7 @@ package body Prj.Nmsc is
procedure Search_Directories
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
For_All_Sources : Boolean;
Allow_Duplicate_Basenames : Boolean;
Excluded : in out Excluded_Sources_Htable.Instance);
......@@ -392,9 +372,11 @@ package body Prj.Nmsc is
procedure Check_File
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
Path : Path_Name_Type;
File_Name : File_Name_Type;
Display_File_Name : File_Name_Type;
Locally_Removed : Boolean;
For_All_Sources : Boolean;
Allow_Duplicate_Basenames : Boolean);
-- Check if file File_Name is a valid source of the project. This is used
......@@ -464,7 +446,7 @@ package body Prj.Nmsc is
procedure Find_Sources
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Proc_Data : in out Processing_Data;
File_To_Source : in out Files_Htable.Instance;
Allow_Duplicate_Basenames : Boolean;
Excluded : in out Excluded_Sources_Htable.Instance);
-- Process the Source_Files and Source_List_File attributes, and store the
......@@ -484,24 +466,17 @@ package body Prj.Nmsc is
-- compute its unit name. If Unit is set to No_Name on exit, none of the
-- other out parameters are relevant.
procedure Get_Unit
(In_Tree : Project_Tree_Ref;
Canonical_File_Name : File_Name_Type;
Project : Project_Id;
Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body);
-- Find out, from a file name, the unit name, the unit kind and if a
-- 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, and the other information are not set.
function Is_Illegal_Suffix
(Suffix : File_Name_Type;
Dot_Replacement : File_Name_Type) return Boolean;
-- Returns True if the string Suffix cannot be used as a spec suffix, a
-- body suffix or a separate suffix.
procedure Check_Illegal_Suffix
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Suffix : File_Name_Type;
Dot_Replacement : File_Name_Type;
Attribute_Name : String;
Location : Source_Ptr);
-- Display an error message if the given suffix is illegal for some reason.
-- The name of the attribute we are testing is specified in Attribute_Name,
-- which is used in the error message. Location is the location where the
-- suffix is defined.
procedure Locate_Directory
(Project : Project_Id;
......@@ -542,26 +517,6 @@ package body Prj.Nmsc is
-- Returns the path name of a (non project) file. Returns an empty string
-- if file cannot be found.
procedure Prepare_Ada_Naming_Exceptions
(List : Array_Element_Id;
In_Tree : Project_Tree_Ref;
Kind : Spec_Or_Body);
-- Prepare the internal hash tables used for checking naming exceptions
-- for Ada. Insert all elements of List in the tables.
procedure Record_Ada_Source
(File_Name : File_Name_Type;
Path_Name : Path_Name_Type;
Project : Project_Id;
In_Tree : Project_Tree_Ref;
Proc_Data : in out Processing_Data;
Ada_Language : Language_Ptr;
Location : Source_Ptr;
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. Ada_Language is a pointer to the
-- Language_Data for "Ada" in Project.
procedure Remove_Source
(Id : Source_Id;
Replaced_By : Source_Id);
......@@ -684,28 +639,160 @@ package body Prj.Nmsc is
procedure Add_Source
(Id : out Source_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
Project : Project_Id;
Lang_Id : Language_Ptr;
Kind : Source_Kind;
File_Name : File_Name_Type;
Display_File : File_Name_Type;
Allow_Duplicate_Basenames : Boolean;
Naming_Exception : Boolean := False;
Path : Path_Information := No_Path_Information;
Alternate_Languages : Language_List := null;
Unit : Name_Id := No_Name;
Index : Int := 0;
Source_To_Replace : Source_Id := No_Source)
Index : Int := 0)
is
Config : constant Language_Config := Lang_Id.Config;
UData : Unit_Index;
Config : constant Language_Config := Lang_Id.Config;
UData : Unit_Index;
Add_Src : Boolean;
Source : Source_Id;
Prev_Unit : Unit_Index := No_Unit_Index;
Source_To_Replace : Source_Id := No_Source;
begin
-- Check if the same file name or unit is used in the prj tree
Add_Src := True;
Source := Files_Htable.Get (File_To_Source, File_Name);
if Unit /= No_Name then
Prev_Unit := Units_Htable.Get (In_Tree.Units_HT, Unit);
end if;
if Prev_Unit /= No_Unit_Index
and then (Kind = Impl or Kind = Spec)
and then Prev_Unit.File_Names (Kind) /= null
then
-- Suspicious, we need to check later whether this is authorized
Add_Src := False;
Source := Prev_Unit.File_Names (Kind);
elsif Source /= No_Source then
if Source.Index = Index then
Add_Src := False;
end if;
end if;
-- Duplication of file/unit in same project is allowed
-- if order of source directories is known.
if Add_Src = False then
Add_Src := True;
if Project = Source.Project then
if Prev_Unit = No_Unit_Index then
if Allow_Duplicate_Basenames then
Add_Src := True;
elsif Project.Known_Order_Of_Source_Dirs then
Add_Src := False;
else
Error_Msg_File_1 := File_Name;
Error_Msg
(Project, In_Tree, "duplicate source file name {",
No_Location);
Add_Src := False;
end if;
else
if Project.Known_Order_Of_Source_Dirs then
Add_Src := False;
-- We might be seeing the same file through a different path
-- (for instance because of symbolic links)
elsif Source.Path.Name /= Path.Name then
Error_Msg_Name_1 := Unit;
Error_Msg
(Project, In_Tree, "duplicate unit %%",
No_Location);
Add_Src := False;
end if;
end if;
-- Do not allow the same unit name in different projects,
-- except if one is extending the other.
-- For a file based language, the same file name replaces
-- a file in a project being extended, but it is allowed
-- to have the same file name in unrelated projects.
elsif Is_Extending (Project, Source.Project) then
Source_To_Replace := Source;
elsif Prev_Unit /= No_Unit_Index
and then not Source.Locally_Removed
then
if Path /= No_Path_Information then
Error_Msg_Name_1 := Unit;
Error_Msg
(Project, In_Tree,
"unit %% cannot belong to several projects",
No_Location);
Error_Msg_Name_1 := Project.Name;
Error_Msg_Name_2 := Name_Id (Path.Name);
Error_Msg
(Project, In_Tree, "\ project %%, %%", No_Location);
Error_Msg_Name_1 := Source.Project.Name;
Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
Error_Msg
(Project, In_Tree, "\ project %%, %%", No_Location);
else
Error_Msg_Name_1 := Unit;
Error_Msg_Name_2 := Source.Project.Name;
Error_Msg
(Project, In_Tree,
"unit %% already belongs to project %%",
No_Location);
end if;
Add_Src := False;
elsif not Source.Locally_Removed
and then not Allow_Duplicate_Basenames
and then Lang_Id.Config.Kind = Unit_Based
then
Error_Msg_File_1 := File_Name;
Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
Error_Msg
(Project, In_Tree,
"{ is already a source of project {",
No_Location);
-- Add the file anyway, to avoid further warnings like "language
-- unknown"
Add_Src := True;
end if;
end if;
if not Add_Src then
return;
end if;
-- Add the new file
Id := new Source_Data;
if Current_Verbosity = High then
Write_Str ("Adding source File: ");
Write_Str (Get_Name_String (File_Name));
if Index /= 0 then
Write_Str (" at" & Index'Img);
end if;
if Lang_Id.Config.Kind = Unit_Based then
Write_Str (" Unit: ");
......@@ -778,6 +865,8 @@ package body Prj.Nmsc is
if Source_To_Replace /= No_Source then
Remove_Source (Source_To_Replace, Id);
end if;
Files_Htable.Set (File_To_Source, File_Name, Id);
end Add_Source;
-------------------
......@@ -906,12 +995,10 @@ package body Prj.Nmsc is
Extending := Project.Extends /= No_Project;
Check_Package_Naming (Project, In_Tree, Is_Config_File, Bodies, Specs);
if Get_Mode = Ada_Only then
Prepare_Ada_Naming_Exceptions (Bodies, In_Tree, Impl);
Prepare_Ada_Naming_Exceptions (Specs, In_Tree, Spec);
end if;
Check_Package_Naming
(Project, In_Tree, Proc_Data.Units, Is_Config_File,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Bodies => Bodies, Specs => Specs);
-- Find the sources
......@@ -2648,79 +2735,24 @@ package body Prj.Nmsc is
end if;
end Check_Interfaces;
------------------------------------
-- Check_And_Normalize_Unit_Names --
------------------------------------
procedure Check_And_Normalize_Unit_Names
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
List : Array_Element_Id;
Debug_Name : String)
is
Current : Array_Element_Id;
Element : Array_Element;
Unit_Name : Name_Id;
begin
if Current_Verbosity = High then
Write_Line (" Checking unit names in " & Debug_Name);
end if;
Current := List;
while Current /= No_Array_Element loop
Element := In_Tree.Array_Elements.Table (Current);
Element.Value.Value :=
Name_Id (Canonical_Case_File_Name (Element.Value.Value));
-- Check that it contains a valid unit name
Get_Name_String (Element.Index);
Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name);
if Unit_Name = No_Name then
Err_Vars.Error_Msg_Name_1 := Element.Index;
Error_Msg
(Project, In_Tree,
"%% is not a valid unit name.",
Element.Value.Location);
else
if Current_Verbosity = High then
Write_Str (" for unit: ");
Write_Line (Get_Name_String (Unit_Name));
end if;
Element.Index := Unit_Name;
In_Tree.Array_Elements.Table (Current) := Element;
end if;
Current := Element.Next;
end loop;
end Check_And_Normalize_Unit_Names;
--------------------------
-- Check_Package_Naming --
--------------------------
procedure Check_Package_Naming
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Is_Config_File : Boolean;
Bodies : out Array_Element_Id;
Specs : out Array_Element_Id)
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
Is_Config_File : Boolean;
Allow_Duplicate_Basenames : Boolean;
Bodies : out Array_Element_Id;
Specs : out Array_Element_Id)
is
Naming_Id : constant Package_Id :=
Util.Value_Of (Name_Naming, Project.Decl.Packages, In_Tree);
Naming : Package_Element;
Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
Ada_Spec_Suffix_Loc : Source_Ptr := No_Location;
procedure Check_Naming_Ada_Only;
-- Does Check_Naming_Schemes processing in Ada_Only mode.
-- If there is a package Naming, puts in Data.Naming the contents of
-- this package.
procedure Check_Naming_Multi_Lang;
-- Does Check_Naming_Schemes processing for Multi_Language mode
......@@ -2873,13 +2905,9 @@ package body Prj.Nmsc is
Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
Sep_Suffix_Loc := Sep_Suffix.Location;
if Is_Illegal_Suffix (Separate_Suffix, Dot_Replacement) then
Err_Vars.Error_Msg_File_1 := Separate_Suffix;
Error_Msg
(Project, In_Tree,
"{ is illegal for Separate_Suffix",
Sep_Suffix.Location);
end if;
Check_Illegal_Suffix
(Project, In_Tree, Separate_Suffix,
Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location);
end if;
end if;
......@@ -2945,9 +2973,11 @@ package body Prj.Nmsc is
Add_Source
(Id => Source,
In_Tree => In_Tree,
File_To_Source => File_To_Source,
Project => Project,
Lang_Id => Lang_Id,
Kind => Kind,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
File_Name => File_Name,
Display_File => File_Name_Type (Element.Value),
Naming_Exception => True);
......@@ -2997,9 +3027,6 @@ package body Prj.Nmsc is
Index : Int;
File_Name : File_Name_Type;
Source : Source_Id;
Source_To_Replace : Source_Id := No_Source;
Other_Project : Project_Id;
Iter : Source_Iterator;
begin
case Kind is
......@@ -3057,182 +3084,32 @@ package body Prj.Nmsc is
end if;
if Unit /= No_Name then
-- Check if the source already exists
-- ??? In Ada_Only mode (Record_Unit), we use a htable for
-- efficiency
Source_To_Replace := No_Source;
Iter := For_Each_Source (In_Tree);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source
or else (Source.Unit /= null
and then Source.Unit.Name = Unit
and then Source.Index = Index);
Next (Iter);
end loop;
if Source /= No_Source then
if Source.Kind /= Kind then
loop
Next (Iter);
Source := Prj.Element (Iter);
exit when Source = No_Source
or else (Source.Unit /= null
and then Source.Unit.Name = Unit
and then Source.Index = Index);
end loop;
end if;
if Source /= No_Source then
Other_Project := Source.Project;
if Is_Extending (Project, Other_Project) then
Source_To_Replace := Source;
Source := No_Source;
else
Error_Msg_Name_1 := Unit;
Error_Msg_Name_2 := Other_Project.Name;
Error_Msg
(Project,
In_Tree,
"%% is already a source of project %%",
Element.Value.Location);
end if;
end if;
end if;
if Source = No_Source then
Add_Source
(Id => Source,
In_Tree => In_Tree,
Project => Project,
Lang_Id => Lang_Id,
Kind => Kind,
File_Name => File_Name,
Display_File => File_Name_Type (Element.Value.Value),
Unit => Unit,
Index => Index,
Naming_Exception => True,
Source_To_Replace => Source_To_Replace);
end if;
Add_Source
(Id => Source,
In_Tree => In_Tree,
File_To_Source => File_To_Source,
Project => Project,
Lang_Id => Lang_Id,
Kind => Kind,
File_Name => File_Name,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Display_File => File_Name_Type (Element.Value.Value),
Unit => Unit,
Index => Index,
Naming_Exception => True);
end if;
Exceptions := Element.Next;
end loop;
end Process_Exceptions_Unit_Based;
---------------------------
-- Check_Naming_Ada_Only --
---------------------------
procedure Check_Naming_Ada_Only is
Ada : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
Casing_Defined : Boolean;
Sep_Suffix_Loc : Source_Ptr;
begin
-- If no language, then nothing to do
if Ada = null then
return;
end if;
declare
Data : Lang_Naming_Data renames Ada.Config.Naming_Data;
begin
-- The default value of separate suffix should be the same as the
-- body suffix, so we need to compute that first.
Data.Separate_Suffix := Data.Body_Suffix;
Write_Attr ("Body_Suffix", Get_Name_String (Data.Body_Suffix));
-- We'll need the dot replacement below, so compute it now
Check_Common
(Dot_Replacement => Data.Dot_Replacement,
Casing => Data.Casing,
Casing_Defined => Casing_Defined,
Separate_Suffix => Data.Separate_Suffix,
Sep_Suffix_Loc => Sep_Suffix_Loc);
Bodies := Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree);
if Bodies /= No_Array_Element then
Check_And_Normalize_Unit_Names
(Project, In_Tree, Bodies, "Naming.Bodies");
end if;
Specs := Util.Value_Of (Name_Spec, Naming.Decl.Arrays, In_Tree);
if Specs /= No_Array_Element then
Check_And_Normalize_Unit_Names
(Project, In_Tree, Specs, "Naming.Specs");
end if;
-- Check Spec_Suffix
if Is_Illegal_Suffix (Data.Spec_Suffix, Data.Dot_Replacement) then
Err_Vars.Error_Msg_File_1 := Data.Spec_Suffix;
Error_Msg
(Project, In_Tree,
"{ is illegal for Spec_Suffix",
Ada_Spec_Suffix_Loc);
end if;
Write_Attr ("Spec_Suffix", Get_Name_String (Data.Spec_Suffix));
-- Check Body_Suffix
if Is_Illegal_Suffix (Data.Body_Suffix, Data.Dot_Replacement) then
Err_Vars.Error_Msg_File_1 := Data.Body_Suffix;
Error_Msg
(Project, In_Tree,
"{ is illegal for Body_Suffix",
Ada_Body_Suffix_Loc);
end if;
-- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
-- since that would cause a clear ambiguity. Note that we do allow
-- a Spec_Suffix to have the same termination as one of these,
-- which causes a potential ambiguity, but we resolve that my
-- matching the longest possible suffix.
if Data.Spec_Suffix = Data.Body_Suffix then
Error_Msg
(Project, In_Tree,
"Body_Suffix ("""
& Get_Name_String (Data.Body_Suffix)
& """) cannot be the same as Spec_Suffix.",
Ada_Body_Suffix_Loc);
end if;
if Data.Body_Suffix /= Data.Separate_Suffix
and then Data.Spec_Suffix = Data.Separate_Suffix
then
Error_Msg
(Project, In_Tree,
"Separate_Suffix ("""
& Get_Name_String (Data.Separate_Suffix)
& """) cannot be the same as Spec_Suffix.",
Sep_Suffix_Loc);
end if;
end;
end Check_Naming_Ada_Only;
-----------------------------
-- Check_Naming_Multi_Lang --
-----------------------------
procedure Check_Naming_Multi_Lang is
Dot_Replacement : File_Name_Type := No_File;
Dot_Replacement : File_Name_Type :=
File_Name_Type (First_Name_Id + Character'Pos ('-'));
Separate_Suffix : File_Name_Type := No_File;
Casing : Casing_Type := All_Lower_Case;
Casing_Defined : Boolean;
......@@ -3269,11 +3146,6 @@ package body Prj.Nmsc is
if Casing_Defined then
Lang_Id.Config.Naming_Data.Casing := Casing;
end if;
if Separate_Suffix /= No_File then
Lang_Id.Config.Naming_Data.Separate_Suffix :=
Separate_Suffix;
end if;
end if;
Lang_Id := Lang_Id.Next;
......@@ -3297,7 +3169,7 @@ package body Prj.Nmsc is
if Suffix = Nil_Variable_Value then
Suffix := Value_Of
(Name => Lang,
Attribute_Or_Array_Name => Name_Spec_Suffix,
Attribute_Or_Array_Name => Name_Specification_Suffix,
In_Package => Naming_Id,
In_Tree => In_Tree);
end if;
......@@ -3305,6 +3177,16 @@ package body Prj.Nmsc is
if Suffix /= Nil_Variable_Value then
Lang_Id.Config.Naming_Data.Spec_Suffix :=
File_Name_Type (Suffix.Value);
Check_Illegal_Suffix
(Project, In_Tree,
Lang_Id.Config.Naming_Data.Spec_Suffix,
Lang_Id.Config.Naming_Data.Dot_Replacement,
"Spec_Suffix", Suffix.Location);
Write_Attr
("Spec_Suffix",
Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
end if;
-- Body_Suffix
......@@ -3325,14 +3207,68 @@ package body Prj.Nmsc is
if Suffix /= Nil_Variable_Value then
Lang_Id.Config.Naming_Data.Body_Suffix :=
File_Name_Type (Suffix.Value);
File_Name_Type (Suffix.Value);
-- The default value of separate suffix should be the same as
-- the body suffix, so we need to compute that first.
if Separate_Suffix = No_File then
Lang_Id.Config.Naming_Data.Separate_Suffix :=
Lang_Id.Config.Naming_Data.Body_Suffix;
Write_Attr
("Sep_Suffix",
Get_Name_String
(Lang_Id.Config.Naming_Data.Separate_Suffix));
else
Lang_Id.Config.Naming_Data.Separate_Suffix :=
Separate_Suffix;
end if;
Check_Illegal_Suffix
(Project, In_Tree,
Lang_Id.Config.Naming_Data.Body_Suffix,
Lang_Id.Config.Naming_Data.Dot_Replacement,
"Body_Suffix", Suffix.Location);
Write_Attr
("Body_Suffix",
Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
elsif Separate_Suffix /= No_File then
Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
end if;
-- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
-- since that would cause a clear ambiguity. Note that we do allow
-- a Spec_Suffix to have the same termination as one of these,
-- which causes a potential ambiguity, but we resolve that my
-- matching the longest possible suffix.
if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
and then Lang_Id.Config.Naming_Data.Spec_Suffix =
Lang_Id.Config.Naming_Data.Body_Suffix
then
Error_Msg
(Project, In_Tree,
"Body_Suffix ("""
& Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
& """) cannot be the same as Spec_Suffix.",
Ada_Body_Suffix_Loc);
end if;
-- ??? As opposed to what is done in Check_Naming_Ada_Only,
-- we do not check whether spec_suffix=body_suffix, which
-- should be illegal. Best would be to share this code into
-- Check_Common, but we access the attributes from the project
-- files slightly differently apparently.
if Lang_Id.Config.Naming_Data.Body_Suffix /=
Lang_Id.Config.Naming_Data.Separate_Suffix
and then Lang_Id.Config.Naming_Data.Spec_Suffix =
Lang_Id.Config.Naming_Data.Separate_Suffix
then
Error_Msg
(Project, In_Tree,
"Separate_Suffix ("""
& Get_Name_String
(Lang_Id.Config.Naming_Data.Separate_Suffix)
& """) cannot be the same as Spec_Suffix.",
Sep_Suffix_Loc);
end if;
Lang_Id := Lang_Id.Next;
end loop;
......@@ -3421,10 +3357,6 @@ package body Prj.Nmsc is
else
Value := In_Tree.Array_Elements.Table (Specs).Value;
if Lang.Name = Name_Ada then
Ada_Spec_Suffix_Loc := Value.Location;
end if;
if Value.Kind = Single then
Lang.Config.Naming_Data.Spec_Suffix :=
Canonical_Case_File_Name (Value.Value);
......@@ -3480,13 +3412,7 @@ package body Prj.Nmsc is
end if;
Initialize_Naming_Data;
case Get_Mode is
when Ada_Only =>
Check_Naming_Ada_Only;
when Multi_Language =>
Check_Naming_Multi_Lang;
end case;
Check_Naming_Multi_Lang;
end if;
end Check_Package_Naming;
......@@ -4981,7 +4907,6 @@ package body Prj.Nmsc is
Name_Len := 0;
Add_Str_To_Name_Buffer
(Get_Name_String (Project.Directory.Name));
Add_Char_To_Name_Buffer (Directory_Separator);
Add_Str_To_Name_Buffer
(Get_Name_String (Lib_Ref_Symbol_File.Value));
Project.Symbol_Data.Reference := Name_Find;
......@@ -5030,7 +4955,6 @@ package body Prj.Nmsc is
Normalize_Pathname
(Get_Name_String
(Project.Object_Directory.Name) &
Directory_Separator &
Name_Buffer (1 .. Name_Len),
Directory => Current_Dir,
Resolve_Links =>
......@@ -5584,15 +5508,13 @@ package body Prj.Nmsc is
else
declare
Path : constant String :=
Get_Name_String (Path_Name.Name) &
Directory_Separator;
Get_Name_String (Path_Name.Name);
Last_Path : constant Natural :=
Compute_Directory_Last (Path);
Path_Id : Name_Id;
Display_Path : constant String :=
Get_Name_String
(Path_Name.Display_Name) &
Directory_Separator;
(Path_Name.Display_Name);
Last_Display_Path : constant Natural :=
Compute_Directory_Last
(Display_Path);
......@@ -6006,10 +5928,6 @@ package body Prj.Nmsc is
Name_Loc : Name_Location;
begin
if Get_Mode = Ada_Only then
Source_Names.Reset;
end if;
if Current_Verbosity = High then
Write_Str ("Opening """);
Write_Str (Path);
......@@ -6139,7 +6057,7 @@ package body Prj.Nmsc is
if Last = Filename'Last then
if Current_Verbosity = High then
Write_Line (" No matching suffix");
Write_Line (" no matching suffix");
end if;
return;
......@@ -6306,67 +6224,6 @@ package body Prj.Nmsc is
end if;
end Compute_Unit_Name;
--------------
-- Get_Unit --
--------------
procedure Get_Unit
(In_Tree : Project_Tree_Ref;
Canonical_File_Name : File_Name_Type;
Project : Project_Id;
Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body)
is
Info_Id : Ada_Naming_Exception_Id :=
Ada_Naming_Exceptions.Get (Canonical_File_Name);
VMS_Name : File_Name_Type;
Kind : Source_Kind;
Lang : Language_Ptr;
begin
if Info_Id = No_Ada_Naming_Exception
and then Hostparm.OpenVMS
then
VMS_Name := Canonical_File_Name;
Get_Name_String (VMS_Name);
if Name_Buffer (Name_Len) = '.' then
Name_Len := Name_Len - 1;
VMS_Name := Name_Find;
end if;
Info_Id := Ada_Naming_Exceptions.Get (VMS_Name);
end if;
if Info_Id /= No_Ada_Naming_Exception then
Exception_Id := Info_Id;
Unit_Name := No_Name;
Unit_Kind := Spec;
else
Exception_Id := No_Ada_Naming_Exception;
Lang := Get_Language_From_Name (Project, "ada");
if Lang = null then
Unit_Name := No_Name;
Unit_Kind := Spec;
else
Compute_Unit_Name
(File_Name => Canonical_File_Name,
Naming => Lang.Config.Naming_Data,
Kind => Kind,
Unit => Unit_Name,
In_Tree => In_Tree);
case Kind is
when Spec => Unit_Kind := Spec;
when Impl | Sep => Unit_Kind := Impl;
end case;
end if;
end if;
end Get_Unit;
----------
-- Hash --
----------
......@@ -6376,44 +6233,62 @@ package body Prj.Nmsc is
return Header_Num (Unit.Unit mod 2048);
end Hash;
-----------------------
-- Is_Illegal_Suffix --
-----------------------
--------------------------
-- Check_Illegal_Suffix --
--------------------------
function Is_Illegal_Suffix
(Suffix : File_Name_Type;
Dot_Replacement : File_Name_Type) return Boolean
procedure Check_Illegal_Suffix
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Suffix : File_Name_Type;
Dot_Replacement : File_Name_Type;
Attribute_Name : String;
Location : Source_Ptr)
is
Suffix_Str : constant String := Get_Name_String (Suffix);
begin
if Suffix_Str'Length = 0 then
return False;
-- Always valid
return;
elsif Index (Suffix_Str, ".") = 0 then
return True;
Err_Vars.Error_Msg_File_1 := Suffix;
Error_Msg
(Project, In_Tree,
"{ is illegal for " & Attribute_Name & ": must have a dot",
Location);
return;
end if;
-- Case of dot replacement is a single dot, and first character of
-- suffix is also a dot.
if Get_Name_String (Dot_Replacement) = "."
if Dot_Replacement /= No_File
and then Get_Name_String (Dot_Replacement) = "."
and then Suffix_Str (Suffix_Str'First) = '.'
then
for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
-- Case of following dot
-- If there are multiple dots in the name
if Suffix_Str (Index) = '.' then
-- It is illegal to have a letter following the initial dot
return Is_Letter (Suffix_Str (Suffix_Str'First + 1));
if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
Err_Vars.Error_Msg_File_1 := Suffix;
Error_Msg
(Project, In_Tree,
"{ is illegal for " & Attribute_Name
& ": ambiguous prefix when Dot_Replacement is a dot",
Location);
end if;
return;
end if;
end loop;
end if;
return False;
end Is_Illegal_Suffix;
end Check_Illegal_Suffix;
----------------------
-- Locate_Directory --
......@@ -6433,7 +6308,7 @@ package body Prj.Nmsc is
Parent : constant Path_Name_Type :=
Project.Directory.Display_Name;
The_Parent : constant String :=
Get_Name_String (Parent) & Directory_Separator;
Get_Name_String (Parent);
The_Parent_Last : constant Natural :=
Compute_Directory_Last (The_Parent);
Full_Name : File_Name_Type;
......@@ -6560,10 +6435,22 @@ package body Prj.Nmsc is
begin
Name_Len := Normed'Length;
Name_Buffer (1 .. Name_Len) := Normed;
-- Directories should always end with a directory separator
if Name_Buffer (Name_Len) /= Directory_Separator then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Path.Display_Name := Name_Find;
Name_Len := Canonical_Path'Length;
Name_Buffer (1 .. Name_Len) := Canonical_Path;
if Name_Buffer (Name_Len) /= Directory_Separator then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Path.Name := Name_Find;
end;
end if;
......@@ -6730,7 +6617,7 @@ package body Prj.Nmsc is
procedure Find_Sources
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Proc_Data : in out Processing_Data;
File_To_Source : in out Files_Htable.Instance;
Allow_Duplicate_Basenames : Boolean;
Excluded : in out Excluded_Sources_Htable.Instance)
is
......@@ -6775,7 +6662,7 @@ package body Prj.Nmsc is
Name : File_Name_Type;
begin
if Get_Mode = Multi_Language then
-- if Get_Mode = Multi_Language then
if Current = Nil_String then
Project.Languages := No_Language_Index;
......@@ -6789,7 +6676,7 @@ package body Prj.Nmsc is
Project.Object_Directory := No_Path_Information;
end if;
end if;
end if;
-- end if;
while Current /= Nil_String loop
Element := In_Tree.String_Elements.Table (Current);
......@@ -6822,17 +6709,11 @@ package body Prj.Nmsc is
end if;
end loop;
-- In Multi_Language mode, check whether the file is already
-- there: the same file name may be in the list. If the source
-- is missing, the error will be on the first mention of the
-- source file name.
-- Check whether the file is already there: the same file name
-- may be in the list. If the source is missing, the error will
-- be on the first mention of the source file name.
case Get_Mode is
when Ada_Only =>
Name_Loc := No_Name_Location;
when Multi_Language =>
Name_Loc := Source_Names.Get (Name);
end case;
Name_Loc := Source_Names.Get (Name);
if Name_Loc = No_Name_Location then
Name_Loc :=
......@@ -6890,20 +6771,12 @@ package body Prj.Nmsc is
Has_Explicit_Sources := False;
end if;
if Get_Mode = Ada_Only then
Find_Ada_Sources
(Project, In_Tree,
Explicit_Sources_Only => Has_Explicit_Sources,
Proc_Data => Proc_Data);
else
Search_Directories
(Project, In_Tree,
For_All_Sources =>
Sources.Default and then Source_List_File.Default,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Excluded => Excluded);
end if;
Search_Directories
(Project, In_Tree,
File_To_Source => File_To_Source,
For_All_Sources => Sources.Default and then Source_List_File.Default,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Excluded => Excluded);
-- Check if all exceptions have been found. For Ada, it is an error if
-- an exception is not found. For other language, the source is simply
......@@ -6937,10 +6810,29 @@ package body Prj.Nmsc is
(Project, In_Tree,
"source file %% for unit %% not found",
No_Location);
else
-- Set the full path information since we know it
-- anyway
Source.Path := Files_Htable.Get
(File_To_Source, Source.File).Path;
if Current_Verbosity = High then
if Source.Path /= No_Path_Information then
Write_Line ("Setting full path for "
& Get_Name_String (Source.File)
& " at" & Source.Index'Img
& " to "
& Get_Name_String (Source.Path.Name));
end if;
end if;
end if;
end if;
Remove_Source (Source, No_Source);
if Source.Path = No_Path_Information then
Remove_Source (Source, No_Source);
end if;
end if;
Next (Iter);
......@@ -7012,154 +6904,6 @@ package body Prj.Nmsc is
Files_Htable.Reset (Proc_Data.Units);
end Free;
----------------------
-- Find_Ada_Sources --
----------------------
procedure Find_Ada_Sources
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Explicit_Sources_Only : Boolean;
Proc_Data : in out Processing_Data)
is
Source_Dir : String_List_Id;
Element : String_Element;
Dir : Dir_Type;
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 := Project.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.
Source_Dir := Project.Source_Dirs;
while Source_Dir /= Nil_String loop
Dir_Has_Source := False;
Element := In_Tree.String_Elements.Table (Source_Dir);
declare
Dir_Path : constant String :=
Get_Name_String (Element.Display_Value) &
Directory_Separator;
Dir_Last : constant Natural := Compute_Directory_Last (Dir_Path);
begin
if Current_Verbosity = High then
Write_Line ("checking directory """ & Dir_Path & """");
end if;
-- Look for all files in the current source directory
Open (Dir, Dir_Path (Dir_Path'First .. Dir_Last));
loop
Read (Dir, Name_Buffer, Name_Len);
exit when Name_Len = 0;
if Current_Verbosity = High then
Write_Line (" Checking " & Name_Buffer (1 .. Name_Len));
end if;
declare
Name : constant File_Name_Type := Name_Find;
Canonical_Name : File_Name_Type;
-- ??? We could probably optimize the following call: we
-- need to resolve links only once for the directory itself,
-- and then do a single call to readlink() for each file.
-- Unfortunately that would require Normalize_Pathname to
-- be changed so that it has the option of not resolving
-- links for its Directory parameter, only for Name.
Path : constant String :=
Normalize_Pathname
(Name => Name_Buffer (1 .. Name_Len),
Directory => Dir_Path (Dir_Path'First .. Dir_Last),
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True); -- no case folding
Path_Name : Path_Name_Type;
To_Record : Boolean := False;
Location : Source_Ptr;
begin
-- If the file was listed in the explicit list of sources,
-- mark it as such (since we'll need to report an error when
-- an explicit source was not found)
if Explicit_Sources_Only then
Canonical_Name :=
Canonical_Case_File_Name (Name_Id (Name));
NL := Source_Names.Get (Canonical_Name);
To_Record := NL /= No_Name_Location and then not NL.Found;
if To_Record then
NL.Found := True;
Location := NL.Location;
Source_Names.Set (Canonical_Name, NL);
end if;
else
To_Record := True;
Location := No_Location;
end if;
if To_Record then
Name_Len := Path'Length;
Name_Buffer (1 .. Name_Len) := Path;
Path_Name := Name_Find;
if Current_Verbosity = High then
Write_Line (" recording " & Get_Name_String (Name));
end if;
-- Register the source if it is an Ada compilation unit
Record_Ada_Source
(File_Name => Name,
Path_Name => Path_Name,
Project => Project,
In_Tree => In_Tree,
Proc_Data => Proc_Data,
Ada_Language => Ada_Language,
Location => Location,
Source_Recorded => Dir_Has_Source);
end if;
end;
end loop;
Close (Dir);
exception
when others =>
Close (Dir);
raise;
end;
if Dir_Has_Source then
In_Tree.String_Elements.Table (Source_Dir).Flag := True;
end if;
Source_Dir := Element.Next;
end loop;
if Current_Verbosity = High then
Write_Line ("End looking for sources");
end if;
end Find_Ada_Sources;
-------------------------------
-- Check_File_Naming_Schemes --
-------------------------------
......@@ -7328,9 +7072,11 @@ package body Prj.Nmsc is
procedure Check_File
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
Path : Path_Name_Type;
File_Name : File_Name_Type;
Display_File_Name : File_Name_Type;
Locally_Removed : Boolean;
For_All_Sources : Boolean;
Allow_Duplicate_Basenames : Boolean)
is
......@@ -7343,14 +7089,11 @@ package body Prj.Nmsc is
Alternate_Languages : Language_List;
Language : Language_Ptr;
Source : Source_Id;
Add_Src : Boolean;
Src_Ind : Source_File_Index;
Unit : Name_Id;
Source_To_Replace : Source_Id := No_Source;
Display_Language_Name : Name_Id;
Lang_Kind : Language_Kind;
Kind : Source_Kind := Spec;
Iter : Source_Iterator;
begin
if Name_Loc = No_Name_Location then
......@@ -7403,6 +7146,8 @@ package body Prj.Nmsc is
Override_Kind (Name_Loc.Source, Sep);
end if;
end if;
Files_Htable.Set (File_To_Source, File_Name, Name_Loc.Source);
end if;
end if;
end if;
......@@ -7423,126 +7168,34 @@ package body Prj.Nmsc is
-- A file name in a list must be a source of a language
if Name_Loc.Found then
Error_Msg_File_1 := File_Name;
Error_Msg
(Project,
In_Tree,
"language unknown for {",
Name_Loc.Location);
if Get_Mode = Multi_Language then
if Name_Loc.Found then
Error_Msg_File_1 := File_Name;
Error_Msg
(Project,
In_Tree,
"language unknown for {",
Name_Loc.Location);
end if;
end if;
else
-- Check if the same file name or unit is used in the prj tree
Iter := For_Each_Source (In_Tree);
Add_Src := True;
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Unit /= No_Name
and then Source.Unit /= No_Unit_Index
and then Source.Unit.Name = Unit
and then
((Source.Kind = Spec and then Kind = Impl)
or else
(Source.Kind = Impl and then Kind = Spec))
then
-- We found the "other_part (source)"
null;
elsif (Unit /= No_Name
and then Source.Unit /= No_Unit_Index
and then Source.Unit.Name = Unit
and then
(Source.Kind = Kind
or else
(Source.Kind = Sep and then Kind = Impl)
or else
(Source.Kind = Impl and then Kind = Sep)))
or else
(Unit = No_Name and then Source.File = File_Name)
then
-- Duplication of file/unit in same project is only allowed
-- if order of source directories is known.
if Project = Source.Project then
if Unit = No_Name then
if Allow_Duplicate_Basenames then
Add_Src := True;
elsif Project.Known_Order_Of_Source_Dirs then
Add_Src := False;
else
Error_Msg_File_1 := File_Name;
Error_Msg
(Project, In_Tree, "duplicate source file name {",
No_Location);
Add_Src := False;
end if;
else
if Project.Known_Order_Of_Source_Dirs then
Add_Src := False;
else
Error_Msg_Name_1 := Unit;
Error_Msg
(Project, In_Tree, "duplicate unit %%",
No_Location);
Add_Src := False;
end if;
end if;
-- Do not allow the same unit name in different projects,
-- except if one is extending the other.
-- For a file based language, the same file name replaces
-- a file in a project being extended, but it is allowed
-- to have the same file name in unrelated projects.
elsif Is_Extending (Project, Source.Project) then
Source_To_Replace := Source;
elsif Unit /= No_Name
and then not Source.Locally_Removed
then
Error_Msg_Name_1 := Unit;
Error_Msg
(Project, In_Tree,
"unit %% cannot belong to several projects",
No_Location);
Error_Msg_Name_1 := Project.Name;
Error_Msg_Name_2 := Name_Id (Path);
Error_Msg
(Project, In_Tree, "\ project %%, %%", No_Location);
Error_Msg_Name_1 := Source.Project.Name;
Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
Error_Msg
(Project, In_Tree, "\ project %%, %%", No_Location);
Add_Src := False;
end if;
end if;
Next (Iter);
end loop;
if Add_Src then
Add_Source
(Id => Source,
In_Tree => In_Tree,
Project => Project,
Lang_Id => Language,
Kind => Kind,
Alternate_Languages => Alternate_Languages,
File_Name => File_Name,
Display_File => Display_File_Name,
Unit => Unit,
Path => (Canonical_Path, Path),
Source_To_Replace => Source_To_Replace);
Add_Source
(Id => Source,
In_Tree => In_Tree,
File_To_Source => File_To_Source,
Project => Project,
Lang_Id => Language,
Kind => Kind,
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Alternate_Languages => Alternate_Languages,
File_Name => File_Name,
Display_File => Display_File_Name,
Unit => Unit,
Path => (Canonical_Path, Path));
if Source /= No_Source then
Source.Locally_Removed := Locally_Removed;
end if;
end if;
end if;
......@@ -7555,6 +7208,7 @@ package body Prj.Nmsc is
procedure Search_Directories
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
File_To_Source : in out Files_Htable.Instance;
For_All_Sources : Boolean;
Allow_Duplicate_Basenames : Boolean;
Excluded : in out Excluded_Sources_Htable.Instance)
......@@ -7644,6 +7298,7 @@ package body Prj.Nmsc is
Path : Path_Name_Type;
FF : File_Found := Excluded_Sources_Htable.Get
(Excluded, File_Name);
To_Remove : Boolean := False;
begin
Name_Len := Path_Name'Length;
......@@ -7661,20 +7316,29 @@ package body Prj.Nmsc is
Write_Str (Get_Name_String (File_Name));
Write_Line ("""");
end if;
end if;
else
Check_File
(Project => Project,
In_Tree => In_Tree,
Path => Path,
File_Name => File_Name,
Display_File_Name =>
Display_File_Name,
For_All_Sources => For_All_Sources,
Allow_Duplicate_Basenames =>
Allow_Duplicate_Basenames);
-- Will mark the file as removed, but we
-- still need to add it to the list: if we
-- don't, the file will not appear in the
-- mapping file and will cause the compiler
-- to fail
To_Remove := True;
end if;
end if;
Check_File
(Project => Project,
In_Tree => In_Tree,
File_To_Source => File_To_Source,
Path => Path,
File_Name => File_Name,
Locally_Removed => To_Remove,
Display_File_Name =>
Display_File_Name,
For_All_Sources => For_All_Sources,
Allow_Duplicate_Basenames =>
Allow_Duplicate_Basenames);
end;
end if;
end loop;
......@@ -7881,7 +7545,6 @@ package body Prj.Nmsc is
Check_Object_File_Names : declare
Src_Id : Source_Id;
Source_Name : File_Name_Type;
procedure Check_Object (Src : Source_Id);
-- Check if object file name of the current source is already in
......@@ -7893,12 +7556,15 @@ package body Prj.Nmsc is
------------------
procedure Check_Object (Src : Source_Id) is
Source : Source_Id;
begin
Source_Name := Object_File_Names.Get (Src.Object);
Source := Object_File_Names.Get (Src.Object);
if Source_Name /= No_File then
if Source /= No_Source
and then Source = Src
then
Error_Msg_File_1 := Src.File;
Error_Msg_File_2 := Source_Name;
Error_Msg_File_2 := Source.File;
Error_Msg
(Project,
In_Tree,
......@@ -7906,7 +7572,7 @@ package body Prj.Nmsc is
No_Location);
else
Object_File_Names.Set (Src.Object, Src.File);
Object_File_Names.Set (Src.Object, Src);
end if;
end Check_Object;
......@@ -7979,18 +7645,14 @@ package body Prj.Nmsc is
or else (Get_Mode = Multi_Language
and then Project.Languages /= No_Language_Index)
then
if Get_Mode = Multi_Language then
Load_Naming_Exceptions (Project, In_Tree, Excluded_Sources);
end if;
Load_Naming_Exceptions (Project, In_Tree, Excluded_Sources);
Find_Sources
(Project, In_Tree, Proc_Data, Allow_Duplicate_Basenames,
(Project, In_Tree, Proc_Data.Units, Allow_Duplicate_Basenames,
Excluded => Excluded_Sources);
Mark_Excluded_Sources;
if Get_Mode = Multi_Language then
Process_Sources_In_Multi_Language_Mode;
end if;
Process_Sources_In_Multi_Language_Mode;
end if;
end Look_For_Sources;
......@@ -8025,280 +7687,6 @@ package body Prj.Nmsc is
end if;
end Path_Name_Of;
-----------------------------------
-- Prepare_Ada_Naming_Exceptions --
-----------------------------------
procedure Prepare_Ada_Naming_Exceptions
(List : Array_Element_Id;
In_Tree : Project_Tree_Ref;
Kind : Spec_Or_Body)
is
Current : Array_Element_Id;
Element : Array_Element;
Unit : Unit_Info;
begin
-- Traverse the list
Current := List;
while Current /= No_Array_Element loop
Element := In_Tree.Array_Elements.Table (Current);
if Element.Index /= No_Name then
Unit :=
(Kind => Kind,
Unit => Element.Index,
Next => No_Ada_Naming_Exception);
Reverse_Ada_Naming_Exceptions.Set
(Unit, (Element.Value.Value, Element.Value.Index));
Unit.Next :=
Ada_Naming_Exceptions.Get (File_Name_Type (Element.Value.Value));
Ada_Naming_Exception_Table.Increment_Last;
Ada_Naming_Exception_Table.Table
(Ada_Naming_Exception_Table.Last) := Unit;
Ada_Naming_Exceptions.Set
(File_Name_Type (Element.Value.Value),
Ada_Naming_Exception_Table.Last);
end if;
Current := Element.Next;
end loop;
end Prepare_Ada_Naming_Exceptions;
-----------------------
-- Record_Ada_Source --
-----------------------
procedure Record_Ada_Source
(File_Name : File_Name_Type;
Path_Name : Path_Name_Type;
Project : Project_Id;
In_Tree : Project_Tree_Ref;
Proc_Data : in out Processing_Data;
Ada_Language : Language_Ptr;
Location : Source_Ptr;
Source_Recorded : in out Boolean)
is
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
UData : constant Unit_Index :=
Units_Htable.Get (In_Tree.Units_HT, Unit_Name);
-- ??? Add_Source will look it up again, can we do that only once ?
Source : Source_Id;
To_Record : Boolean := False;
The_Location : Source_Ptr := Location;
Unit_Prj : Project_Id;
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 UData /= No_Unit_Index then
if UData.File_Names (Unit_Kind) = null
or else
(UData.File_Names (Unit_Kind).File = Canonical_File
and then UData.File_Names (Unit_Kind).Locally_Removed)
or else Is_Extending
(Project.Extends, UData.File_Names (Unit_Kind).Project)
then
To_Record := 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
(Project.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 := 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 :=
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 := 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 (Proc_Data.Units, Canonical_File);
if not File_Recorded
and then Unit_Prj /= No_Project
then
Error_Msg_File_1 := File_Name;
Error_Msg_Name_1 := Unit_Prj.Name;
Error_Msg
(Project, In_Tree,
"{ is already a source of project %%",
Location);
else
To_Record := True;
end if;
end if;
if To_Record then
Files_Htable.Set (Proc_Data.Units, Canonical_File, Project);
Add_Source
(Id => Source,
In_Tree => In_Tree,
Project => Project,
Lang_Id => Ada_Language,
File_Name => Canonical_File,
Display_File => File_Name,
Unit => Unit_Name,
Path => (Canonical_Path, Path_Name),
Naming_Exception => Needs_Pragma,
Kind => Unit_Kind,
Index => Unit_Ind);
Source_Recorded := True;
end if;
end Record_Unit;
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;
Except_Name : Name_And_Index := No_Name_And_Index;
Needs_Pragma : Boolean;
begin
Canonical_File := Canonical_Case_File_Name (Name_Id (File_Name));
Canonical_Path :=
Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path_Name)));
-- Check the naming scheme to get extra file properties
Get_Unit
(In_Tree => In_Tree,
Canonical_File_Name => Canonical_File,
Project => Project,
Exception_Id => Exception_Id,
Unit_Name => Unit_Name,
Unit_Kind => Unit_Kind);
Needs_Pragma := Exception_Id /= No_Ada_Naming_Exception;
if Exception_Id = No_Ada_Naming_Exception
and then Unit_Name = No_Name
then
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;
-- 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 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;
Record_Unit (Unit_Name, Unit_Ind, Unit_Kind, Needs_Pragma);
File_Recorded := True;
exit when Exception_Id = No_Ada_Naming_Exception;
end loop;
end Record_Ada_Source;
-------------------
-- Remove_Source --
-------------------
......@@ -8312,7 +7700,7 @@ package body Prj.Nmsc is
begin
if Current_Verbosity = High then
Write_Str ("Removing source ");
Write_Line (Get_Name_String (Id.File));
Write_Line (Get_Name_String (Id.File) & " at" & Id.Index'Img);
end if;
if Replaced_By /= No_Source then
......
gcc/ada/prj-nmsc.ads
......@@ -83,6 +83,6 @@ private package Prj.Nmsc is
private
type Processing_Data is record
Units : Files_Htable.Instance;
-- Mapping from file base name to the project containing the file
-- Mapping from file base name to the Source_Id of the file
end record;
end Prj.Nmsc;
gcc/ada/prj-pars.adb
......@@ -27,9 +27,9 @@ with Ada.Exceptions; use Ada.Exceptions;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Output; use Output;
with Prj.Conf; use Prj.Conf;
with Prj.Err; use Prj.Err;
with Prj.Part;
with Prj.Proc;
with Prj.Tree; use Prj.Tree;
with Sinput.P;
......@@ -46,15 +46,15 @@ package body Prj.Pars is
Packages_To_Check : String_List_Access := All_Packages;
When_No_Sources : Error_Warning := Error;
Report_Error : Put_Line_Access := null;
Reset_Tree : Boolean := True;
Is_Config_File : Boolean := False)
Reset_Tree : Boolean := True)
is
Project_Node : Project_Node_Id := Empty_Node;
The_Project : Project_Id := No_Project;
Success : Boolean := True;
Current_Dir : constant String := Get_Current_Dir;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Automatically_Generated : Boolean;
Config_File_Path : String_Access;
begin
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
......@@ -69,22 +69,42 @@ package body Prj.Pars is
Always_Errout_Finalize => False,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Dir,
Is_Config_File => Is_Config_File);
Is_Config_File => False);
-- If there were no error, process the tree
if Project_Node /= Empty_Node then
Prj.Proc.Process
(In_Tree => In_Tree,
Project => The_Project,
Success => Success,
From_Project_Node => Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Report_Error => Report_Error,
Reset_Tree => Reset_Tree,
When_No_Sources => When_No_Sources,
Current_Dir => Current_Dir,
Is_Config_File => Is_Config_File);
begin
-- No config file should be read from the disk for gnatmake.
-- However, we will simulate one that only contains the
-- default GNAT naming scheme.
Process_Project_And_Apply_Config
(Main_Project => The_Project,
User_Project_Node => Project_Node,
Config_File_Name => "",
Autoconf_Specified => False,
Project_Tree => In_Tree,
Project_Node_Tree => Project_Node_Tree,
Packages_To_Check => null,
Allow_Automatic_Generation => False,
Automatically_Generated => Automatically_Generated,
Config_File_Path => Config_File_Path,
Report_Error => Report_Error,
Normalized_Hostname => "",
Compiler_Driver_Mandatory => False,
Allow_Duplicate_Basenames => False,
On_Load_Config =>
Add_Default_GNAT_Naming_Scheme'Access,
Reset_Tree => Reset_Tree,
When_No_Sources => When_No_Sources);
Success := The_Project /= No_Project;
exception
when Invalid_Config =>
Success := False;
end;
Prj.Err.Finalize;
......
gcc/ada/prj-pars.ads
......@@ -37,8 +37,7 @@ package Prj.Pars is
Packages_To_Check : String_List_Access := All_Packages;
When_No_Sources : Error_Warning := Error;
Report_Error : Prj.Put_Line_Access := null;
Reset_Tree : Boolean := True;
Is_Config_File : Boolean := False);
Reset_Tree : Boolean := True);
-- Parse and process a project files and all its imported project files, in
-- the project tree In_Tree.
-- All the project files are parsed (through Prj.Tree) to create a tree in
......@@ -62,8 +61,5 @@ package Prj.Pars is
--
-- When Reset_Tree is True, all the project data are removed from the
-- project table before processing.
--
-- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply.
end Prj.Pars;
gcc/ada/prj-part.adb
......@@ -214,12 +214,6 @@ package body Prj.Part is
-- Returns the path name of a project file. Returns an empty string
-- if project file cannot be found.
function Immediate_Directory_Of
(Path_Name : Path_Name_Type) return Path_Name_Type;
-- Get the directory of the file with the specified path name.
-- This includes the directory separator as the last character.
-- Returns "./" if Path_Name contains no directory separator.
function Project_Name_From
(Path_Name : String;
Is_Config_File : Boolean) return Name_Id;
......@@ -249,10 +243,6 @@ package body Prj.Part is
-- Fake path name of the virtual extending project. The directory is
-- the same directory as the extending all project.
Virtual_Dir_Id : constant Path_Name_Type :=
Immediate_Directory_Of (Path_Name_Of (Main_Project, In_Tree));
-- The directory of the extending all project
-- The source of the virtual extending project is something like:
-- project V$<project name> extends <project path> is
......@@ -266,15 +256,11 @@ package body Prj.Part is
-- Nodes that made up the virtual extending project
Virtual_Project : constant Project_Node_Id :=
Default_Project_Node
(In_Tree, N_Project);
Virtual_Project : Project_Node_Id;
With_Clause : constant Project_Node_Id :=
Default_Project_Node
(In_Tree, N_With_Clause);
Project_Declaration : constant Project_Node_Id :=
Default_Project_Node
(In_Tree, N_Project_Declaration);
Project_Declaration : Project_Node_Id;
Source_Dirs_Declaration : constant Project_Node_Id :=
Default_Project_Node
(In_Tree, N_Declarative_Item);
......@@ -292,12 +278,6 @@ package body Prj.Part is
(In_Tree, N_Literal_String_List, List);
begin
-- Get the virtual name id
Name_Len := Virtual_Name'Length;
Name_Buffer (1 .. Name_Len) := Virtual_Name;
Virtual_Name_Id := Name_Find;
-- Get the virtual path name
Get_Name_String (Path_Name_Of (Main_Project, In_Tree));
......@@ -314,6 +294,20 @@ package body Prj.Part is
Name_Len := Name_Len + Virtual_Name'Length;
Virtual_Path_Id := Name_Find;
-- Get the virtual name id
Name_Len := Virtual_Name'Length;
Name_Buffer (1 .. Name_Len) := Virtual_Name;
Virtual_Name_Id := Name_Find;
Virtual_Project := Create_Project
(In_Tree => In_Tree,
Name => Virtual_Name_Id,
Full_Path => Virtual_Path_Id,
Is_Config_File => False);
Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree);
-- With clause
Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id);
......@@ -325,13 +319,8 @@ package body Prj.Part is
-- Virtual project node
Set_Name_Of (Virtual_Project, In_Tree, Virtual_Name_Id);
Set_Path_Name_Of (Virtual_Project, In_Tree, Virtual_Path_Id);
Set_Location_Of
(Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree));
Set_Directory_Of (Virtual_Project, In_Tree, Virtual_Dir_Id);
Set_Project_Declaration_Of
(Virtual_Project, In_Tree, Project_Declaration);
Set_Extended_Project_Path_Of
(Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree));
......@@ -361,54 +350,8 @@ package body Prj.Part is
Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List);
-- Source_Dirs empty list: nothing to do
-- Put virtual project into Projects_Htable
Prj.Tree.Tree_Private_Part.Projects_Htable.Set
(T => In_Tree.Projects_HT,
K => Virtual_Name_Id,
E => (Name => Virtual_Name_Id,
Node => Virtual_Project,
Canonical_Path => No_Path,
Extended => False,
Proj_Qualifier => Unspecified));
end Create_Virtual_Extending_Project;
----------------------------
-- Immediate_Directory_Of --
----------------------------
function Immediate_Directory_Of
(Path_Name : Path_Name_Type) return Path_Name_Type
is
begin
Get_Name_String (Path_Name);
for Index in reverse 1 .. Name_Len loop
if Name_Buffer (Index) = '/'
or else Name_Buffer (Index) = Dir_Sep
then
-- Remove all chars after last directory separator from name
if Index > 1 then
Name_Len := Index - 1;
else
Name_Len := Index;
end if;
return Name_Find;
end if;
end loop;
-- There is no directory separator in name. Return "./" or ".\"
Name_Len := 2;
Name_Buffer (1) := '.';
Name_Buffer (2) := Dir_Sep;
return Name_Find;
end Immediate_Directory_Of;
-----------------------------------
-- Look_For_Virtual_Projects_For --
-----------------------------------
......@@ -1167,7 +1110,8 @@ package body Prj.Part is
Write_Eol;
end if;
Project_Directory := Immediate_Directory_Of (Normed_Path_Name);
Project_Directory := Path_Name_Type
(Get_Directory (File_Name_Type (Normed_Path_Name)));
-- Is there any imported project?
......
gcc/ada/prj-tree.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Osint; use Osint;
with Prj.Err;
package body Prj.Tree is
......@@ -2820,4 +2821,45 @@ package body Prj.Tree is
return Unkept_Comments;
end There_Are_Unkept_Comments;
--------------------
-- Create_Project --
--------------------
function Create_Project
(In_Tree : Project_Node_Tree_Ref;
Name : Name_Id;
Full_Path : Path_Name_Type;
Is_Config_File : Boolean := False) return Project_Node_Id
is
Project : Project_Node_Id;
Qualifier : Project_Qualifier := Unspecified;
begin
Project := Default_Project_Node (In_Tree, N_Project);
Set_Name_Of (Project, In_Tree, Name);
Set_Directory_Of
(Project, In_Tree,
Path_Name_Type (Get_Directory (File_Name_Type (Full_Path))));
Set_Path_Name_Of (Project, In_Tree, Full_Path);
Set_Project_Declaration_Of
(Project, In_Tree,
Default_Project_Node (In_Tree, N_Project_Declaration));
if Is_Config_File then
Qualifier := Configuration;
end if;
Prj.Tree.Tree_Private_Part.Projects_Htable.Set
(In_Tree.Projects_HT,
Name,
Prj.Tree.Tree_Private_Part.Project_Name_And_Node'
(Name => Name,
Canonical_Path => No_Path, -- ??? in GPS: Path_Name_Type (Name),
Node => Project,
Extended => False,
Proj_Qualifier => Qualifier));
return Project;
end Create_Project;
end Prj.Tree;
gcc/ada/prj-tree.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -92,11 +92,11 @@ package Prj.Tree is
function Present (Node : Project_Node_Id) return Boolean;
pragma Inline (Present);
-- Return True iff Node /= Empty_Node
-- Return True if Node /= Empty_Node
function No (Node : Project_Node_Id) return Boolean;
pragma Inline (No);
-- Return True iff Node = Empty_Node
-- Return True if Node = Empty_Node
procedure Initialize (Tree : Project_Node_Tree_Ref);
-- Initialize the Project File tree: empty the Project_Nodes table
......@@ -108,6 +108,15 @@ package Prj.Tree is
And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id;
-- Returns a Project_Node_Record with the specified Kind and Expr_Kind. All
-- the other components have default nil values.
-- To create a node for a project itself, see Create_Project below instead
function Create_Project
(In_Tree : Project_Node_Tree_Ref;
Name : Name_Id;
Full_Path : Path_Name_Type;
Is_Config_File : Boolean := False) return Project_Node_Id;
-- Create a new node for a project and register it in the tree so that it
-- can be retrieved later on
function Hash (N : Project_Node_Id) return Header_Num;
-- Used for hash tables where the key is a Project_Node_Id
......@@ -285,7 +294,9 @@ package Prj.Tree is
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Directory_Of);
-- Only valid for N_Project nodes
-- Only valid for N_Project nodes.
-- Returns the directory that contains the project file. This always
-- ends with a directory separator
function Expression_Kind_Of
(Node : Project_Node_Id;
......
gcc/ada/prj.adb
......@@ -476,7 +476,8 @@ package body Prj is
function Find_Source
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
In_Imported_Only : Boolean;
In_Imported_Only : Boolean := False;
In_Extended_Only : Boolean := False;
Base_Name : File_Name_Type) return Source_Id
is
Result : Source_Id := No_Source;
......@@ -506,10 +507,21 @@ package body Prj is
procedure For_Imported_Projects is new For_Every_Project_Imported
(State => Source_Id, Action => Look_For_Sources);
Proj : Project_Id;
-- Start of processing for Find_Source
begin
if In_Imported_Only then
if In_Extended_Only then
Proj := Project;
while Proj /= No_Project loop
Look_For_Sources (Proj, Result);
exit when Result /= No_Source;
Proj := Proj.Extends;
end loop;
elsif In_Imported_Only then
Look_For_Sources (Project, Result);
if Result = No_Source then
......
gcc/ada/prj.ads
......@@ -145,6 +145,7 @@ package Prj is
Name : Path_Name_Type := No_Path;
Display_Name : Path_Name_Type := No_Path;
end record;
-- Directory names always end with a directory separator
No_Path_Information : constant Path_Information := (No_Path, No_Path);
......@@ -1269,8 +1270,8 @@ package Prj is
package Files_Htable is new Simple_HTable
(Header_Num => Header_Num,
Element => Project_Id,
No_Element => No_Project,
Element => Source_Id,
No_Element => No_Source,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
......@@ -1298,11 +1299,13 @@ package Prj is
function Find_Source
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
In_Imported_Only : Boolean;
In_Imported_Only : Boolean := False;
In_Extended_Only : Boolean := False;
Base_Name : File_Name_Type) return Source_Id;
-- Find the first source file with the given name either in the whole tree
-- (if In_Imported_Only is False) or in the projects imported or extended
-- by Project otherwise.
-- by Project otherwise. In_Extended_Only implies In_Imported_Only, and
-- will only look in Project and the projects it extends
-----------------------
-- Project_Tree_Data --
......
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