diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-07-13 09:04:17 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-07-13 09:04:17 +0000 |
| commit | 189243d59e89001449ec294fa1ff7816c7ef68f3 (patch) | |
| tree | 0248d58807123b435413867f377c3448a7f12aef /gcc | |
| parent | 1cb8dd63a9f58d7f106b2d90f39fe4170bc593ec (diff) | |
| download | ppe42-gcc-189243d59e89001449ec294fa1ff7816c7ef68f3.tar.gz ppe42-gcc-189243d59e89001449ec294fa1ff7816c7ef68f3.zip | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149557 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/clean.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 1 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/mlib-prj.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/mlib.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/prj-conf.adb | 84 | ||||
| -rw-r--r-- | gcc/ada/prj-conf.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 1436 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/prj-pars.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/prj-pars.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/prj-part.adb | 92 | ||||
| -rw-r--r-- | gcc/ada/prj-tree.adb | 44 | ||||
| -rw-r--r-- | gcc/ada/prj-tree.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/prj.ads | 11 |
18 files changed, 695 insertions, 1218 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2029915348e..51dddf508a4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +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 diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index e909cae2527..64f8045710c 100644 --- a/gcc/ada/clean.adb +++ b/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"); diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 35ea1e32aa8..ec0367de6f4 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/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 \ diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 68ed4c77718..ef1cf3e712d 100644 --- a/gcc/ada/gnatcmd.adb +++ b/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"); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index f91d705142f..3d370be24e7 100644 --- a/gcc/ada/make.adb +++ b/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); diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index c7f0f0b73f0..c8aad89ab69 100644 --- a/gcc/ada/mlib-prj.adb +++ b/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 diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb index 6c1a4918340..5d029dbf387 100644 --- a/gcc/ada/mlib.adb +++ b/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; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 0520cf5253c..ea8fe9a66b6 100644 --- a/gcc/ada/prj-conf.adb +++ b/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; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index 4eb8691bfc4..80f28ab1cac 100644 --- a/gcc/ada/prj-conf.ads +++ b/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 -- -------------- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 03acdb0e2ba..4efe034da84 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/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 diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index f0f2ee5d4c2..e5ebbcc8bdc 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/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; diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb index 92010bf7cfa..fa85c8cf37a 100644 --- a/gcc/ada/prj-pars.adb +++ b/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; diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads index 2c439ad115f..2494dcb0917 100644 --- a/gcc/ada/prj-pars.ads +++ b/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; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 6582e6b8183..c411f2f6f6e 100644 --- a/gcc/ada/prj-part.adb +++ b/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? diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index e9bc4a38853..ff5347239c0 100644 --- a/gcc/ada/prj-tree.adb +++ b/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; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 57fe531dc3d..3f62d7934cb 100644 --- a/gcc/ada/prj-tree.ads +++ b/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; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 94945c7e331..f9aca9278c1 100644 --- a/gcc/ada/prj.adb +++ b/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 diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 1923df17c8e..9d1dec2d56c 100644 --- a/gcc/ada/prj.ads +++ b/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 -- |
