diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-06-25 09:26:07 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-06-25 09:26:07 +0000 |
| commit | 77378d518eb62788e2f759abb1a87a66dfafabaf (patch) | |
| tree | 116462c37d01ba1b6c932ed55b7db566a03c056d /gcc | |
| parent | 703cfbf8e933ced3dc6df60732afddc46441db02 (diff) | |
| download | gcc-77378d518eb62788e2f759abb1a87a66dfafabaf.tar.gz | |
2009-06-25 Emmanuel Briot <briot@adacore.com>
* gnatcmd.adb, prj-proc.adb, make.adb, prj.adb, prj.ads, prj-nmsc.adb,
prj-util.adb, prj-env.adb, prj-env.ads: Merge handling of naming_data
between gnatmake and gprbuild.
(Naming_Data): Removed, no longer used
(Naming_Table, Project_Tree_Ref.Namings): Removed, since this is only
needed locally in one subprogram, no need to store forever in the
structure.
(Check_Naming_Scheme, Check_Package_Naming): Merged, since they play
a similar role.
(Body_Suffix_Of, Body_Suffix_Id_Of, Register_Default_Naming_Scheme,
Same_Naming_Scheme, Set_Body_Suffix, Set_Spec_Suffix, Spec_Suffix_Of,
Spec_Suffix_Id_Of): removed, no longer used.
2009-06-25 Javier Miranda <miranda@adacore.com>
* sem_res.adb (Resolve_Allocator): Skip test requiring exact match of
types on qualified expression in calls to imported C++ constructors.
* exp_ch4.adb (Expand_Allocator_Expression): Add missing support for
imported C++ constructors.
2009-06-25 Sergey Rybin <rybin@adacore.com>
* vms_data.ads: Add qualifier for new gnatcheck '-t' option.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148937 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 51 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/prj-env.adb | 298 | ||||
| -rw-r--r-- | gcc/ada/prj-env.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 605 | ||||
| -rw-r--r-- | gcc/ada/prj-proc.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/prj-util.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 367 | ||||
| -rw-r--r-- | gcc/ada/prj.ads | 106 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/vms_data.ads | 8 |
13 files changed, 570 insertions, 1013 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 63550a62b93..5e92642f334 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2009-06-25 Emmanuel Briot <briot@adacore.com> + + * gnatcmd.adb, prj-proc.adb, make.adb, prj.adb, prj.ads, prj-nmsc.adb, + prj-util.adb, prj-env.adb, prj-env.ads: Merge handling of naming_data + between gnatmake and gprbuild. + (Naming_Data): Removed, no longer used + (Naming_Table, Project_Tree_Ref.Namings): Removed, since this is only + needed locally in one subprogram, no need to store forever in the + structure. + (Check_Naming_Scheme, Check_Package_Naming): Merged, since they play + a similar role. + (Body_Suffix_Of, Body_Suffix_Id_Of, Register_Default_Naming_Scheme, + Same_Naming_Scheme, Set_Body_Suffix, Set_Spec_Suffix, Spec_Suffix_Of, + Spec_Suffix_Id_Of): removed, no longer used. + +2009-06-25 Javier Miranda <miranda@adacore.com> + + * sem_res.adb (Resolve_Allocator): Skip test requiring exact match of + types on qualified expression in calls to imported C++ constructors. + + * exp_ch4.adb (Expand_Allocator_Expression): Add missing support for + imported C++ constructors. + +2009-06-25 Sergey Rybin <rybin@adacore.com> + + * vms_data.ads: Add qualifier for new gnatcheck '-t' option. + 2009-06-25 Vincent Celier <celier@adacore.com> * s-os_lib.adb (Normalize_Pathname.Get_Directory): If directory @@ -12,6 +39,7 @@ 2009-06-25 Quentin Ochem <ochem@adacore.com> * prj.ads (Unit_Index): Now general access type. + 2009-06-25 Pascal Obry <obry@adacore.com> * a-stwise.adb, a-stzsea.adb: Fix confusion between 'Length and 'Last. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9c124ad6ec5..a4a6bc3d84b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -572,6 +572,57 @@ package body Exp_Ch4 is begin if Is_Tagged_Type (T) or else Needs_Finalization (T) then + if Is_CPP_Constructor_Call (Exp) then + + -- Generate: + -- Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn + + -- Allocate the object with no expression + + Node := Relocate_Node (N); + Set_Expression (Node, + New_Reference_To (Root_Type (Etype (Exp)), Loc)); + + -- Avoid its expansion to avoid generating a call to the default + -- C++ constructor + + Set_Analyzed (Node); + + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (PtrT, Loc), + Expression => Node)); + + Apply_Accessibility_Check (Temp); + + -- Locate the enclosing list to insert the C++ constructor call + + declare + P : Node_Id := Parent (Node); + + begin + while not Is_List_Member (P) loop + P := Parent (P); + end loop; + + Insert_List_After_And_Analyze (P, + Build_Initialization_Call (Loc, + Id_Ref => Make_Explicit_Dereference (Loc, + New_Reference_To (Temp, Loc)), + Typ => Root_Type (Etype (Exp)), + Constructor_Ref => Exp)); + end; + + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + + return; + end if; + -- Ada 2005 (AI-318-02): If the initialization expression is a call -- to a build-in-place function, then access to the allocated object -- must be passed to the function. Currently we limit such functions diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 89dcb6860ca..86f534da594 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -662,8 +662,7 @@ procedure GNATCmd is function Configuration_Pragmas_File return Path_Name_Type is begin - Prj.Env.Create_Config_Pragmas_File - (Project, Project, Project_Tree, Include_Config_Files => False); + Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree); return Project.Config_File_Name; end Configuration_Pragmas_File; @@ -2122,6 +2121,8 @@ begin File_Index : Integer := 0; Dir_Index : Integer := 0; Last : constant Integer := Last_Switches.Last; + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); begin for Index in 1 .. Last loop @@ -2138,7 +2139,7 @@ begin -- indicate to gnatstub the name of the body file with -- a -o switch. - if Body_Suffix_Id_Of (Project_Tree, Name_Ada, Project.Naming) /= + if Lang.Config.Naming_Data.Body_Suffix /= Prj.Default_Ada_Spec_Suffix then if File_Index /= 0 then @@ -2148,9 +2149,7 @@ begin Last : Natural := Spec'Last; begin - Get_Name_String - (Spec_Suffix_Id_Of - (Project_Tree, Name_Ada, Project.Naming)); + Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix); if Spec'Length > Name_Len and then Spec (Last - Name_Len + 1 .. Last) = @@ -2158,8 +2157,7 @@ begin then Last := Last - Name_Len; Get_Name_String - (Body_Suffix_Id_Of - (Project_Tree, Name_Ada, Project.Naming)); + (Lang.Config.Naming_Data.Body_Suffix); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-o"); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 8b1dbd50859..8d7e6de374a 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -644,7 +644,7 @@ package body Make is (Source_File : File_Name_Type; Source_File_Name : String; Source_Index : Int; - Naming : Naming_Data; + Project : Project_Id; In_Package : Package_Id; Allow_ALI : Boolean) return Variable_Value; -- Return the switches for the source file in the specified package of a @@ -1274,7 +1274,7 @@ package body Make is (Source_File => Name_Find, Source_File_Name => File_Name, Source_Index => Index, - Naming => Main_Project.Naming, + Project => Main_Project, In_Package => The_Package, Allow_ALI => Program = Binder or else Program = Linker); @@ -2388,7 +2388,7 @@ package body Make is (Source_File => Source_File, Source_File_Name => Source_File_Name, Source_Index => Source_Index, - Naming => Arguments_Project.Naming, + Project => Arguments_Project, In_Package => Compiler_Package, Allow_ALI => False); @@ -3750,7 +3750,7 @@ package body Make is begin Prj.Env.Create_Config_Pragmas_File - (For_Project, Main_Project, Project_Tree); + (For_Project, Project_Tree); if For_Project.Config_File_Name /= No_Path then Temporary_Config_File := For_Project.Config_File_Temp; @@ -4235,6 +4235,8 @@ package body Make is File_Name : constant String := Base_Name (Main); -- The simple file name of the current main + Lang : Language_Ptr; + begin exit when Main = ""; @@ -4256,18 +4258,18 @@ package body Make is -- is the actual path of a source of a project. if Main /= File_Name then + Lang := Get_Language_From_Name (Main_Project, "ada"); + Real_Path := Locate_Regular_File - (Main & - Body_Suffix_Of - (Project_Tree, "ada", Main_Project.Naming), + (Main & Get_Name_String + (Lang.Config.Naming_Data.Body_Suffix), ""); if Real_Path = null then Real_Path := Locate_Regular_File - (Main & - Spec_Suffix_Of - (Project_Tree, "ada", Main_Project.Naming), + (Main & Get_Name_String + (Lang.Config.Naming_Data.Spec_Suffix), ""); end if; @@ -8122,10 +8124,12 @@ package body Make is (Source_File : File_Name_Type; Source_File_Name : String; Source_Index : Int; - Naming : Naming_Data; + Project : Project_Id; In_Package : Package_Id; Allow_ALI : Boolean) return Variable_Value is + Lang : constant Language_Ptr := Get_Language_From_Name (Project, "ada"); + Switches : Variable_Value; Defaults : constant Array_Element_Id := @@ -8156,14 +8160,17 @@ package body Make is -- Check also without the suffix - if Switches = Nil_Variable_Value then + if Switches = Nil_Variable_Value + and then Lang /= null + then declare + Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; Name : String (1 .. Source_File_Name'Length + 3); Last : Positive := Source_File_Name'Length; Spec_Suffix : constant String := - Spec_Suffix_Of (Project_Tree, "ada", Naming); + Get_Name_String (Naming.Spec_Suffix); Body_Suffix : constant String := - Body_Suffix_Of (Project_Tree, "ada", Naming); + Get_Name_String (Naming.Body_Suffix); Truncated : Boolean := False; begin diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 2659fe40b89..3478676be81 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -32,8 +32,6 @@ with Tempdir; package body Prj.Env is - Default_Naming : constant Naming_Id := Naming_Table.First; - ----------------------- -- Local Subprograms -- ----------------------- @@ -387,27 +385,30 @@ package body Prj.Env is procedure Create_Config_Pragmas_File (For_Project : Project_Id; - Main_Project : Project_Id; - In_Tree : Project_Tree_Ref; - Include_Config_Files : Boolean := True) + In_Tree : Project_Tree_Ref) is - pragma Unreferenced (Main_Project); - pragma Unreferenced (Include_Config_Files); + type Naming_Id is new Nat; + package Naming_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Lang_Naming_Data, + Table_Index_Type => Naming_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 100); + Default_Naming : constant Naming_Id := Naming_Table.First; + Namings : Naming_Table.Instance; + -- Table storing the naming data for gnatmake/gprmake File_Name : Path_Name_Type := No_Path; File : File_Descriptor := Invalid_FD; Current_Unit : Unit_Index := Units_Htable.Get_First (In_Tree.Units_HT); - First_Project : Project_List; - - Current_Project : Project_List; Current_Naming : Naming_Id; Status : Boolean; -- For call to Close - procedure Check (Project : Project_Id); + procedure Check (Project : Project_Id; State : in out Integer); -- Recursive procedure that put in the config pragmas file any non -- standard naming schemes, if it is not already in the file, then call -- itself for any imported project. @@ -432,7 +433,11 @@ package body Prj.Env is -- Check -- ----------- - procedure Check (Project : Project_Id) is + procedure Check (Project : Project_Id; State : in out Integer) is + pragma Unreferenced (State); + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + Naming : Lang_Naming_Data; begin if Current_Verbosity = High then Write_Str ("Checking project file """); @@ -441,115 +446,85 @@ package body Prj.Env is Write_Eol; end if; - -- Is this project in the list of the visited project? - - Current_Project := First_Project; - while Current_Project /= null - and then Current_Project.Project /= Project - loop - Current_Project := Current_Project.Next; - end loop; - - -- If it is not, put it in the list, and visit it - - if Current_Project = null then - First_Project := new Project_List_Element' - (Project => Project, - Next => First_Project); - - -- Is the naming scheme of this project one that we know? - - Current_Naming := Default_Naming; - while Current_Naming <= - Naming_Table.Last (In_Tree.Private_Part.Namings) - and then not Same_Naming_Scheme - (Left => In_Tree.Private_Part.Namings.Table (Current_Naming), - Right => Project.Naming) loop - Current_Naming := Current_Naming + 1; - end loop; + if Lang = null then + if Current_Verbosity = High then + Write_Str ("Languages does not contain Ada, nothing to do"); + end if; + return; + end if; - -- If we don't know it, add it + Naming := Lang.Config.Naming_Data; - if Current_Naming > - Naming_Table.Last (In_Tree.Private_Part.Namings) - then - Naming_Table.Increment_Last (In_Tree.Private_Part.Namings); - In_Tree.Private_Part.Namings.Table - (Naming_Table.Last (In_Tree.Private_Part.Namings)) := - Project.Naming; + -- Is the naming scheme of this project one that we know? - -- We need a temporary file to be created + Current_Naming := Default_Naming; + while Current_Naming <= Naming_Table.Last (Namings) + and then Namings.Table (Current_Naming).Dot_Replacement = + Naming.Dot_Replacement + and then Namings.Table (Current_Naming).Casing = + Naming.Casing + and then Namings.Table (Current_Naming).Separate_Suffix = + Naming.Separate_Suffix + loop + Current_Naming := Current_Naming + 1; + end loop; - Check_Temp_File; + -- If we don't know it, add it - -- Put the SFN pragmas for the naming scheme + if Current_Naming > Naming_Table.Last (Namings) then + Naming_Table.Increment_Last (Namings); + Namings.Table (Naming_Table.Last (Namings)) := Naming; - -- Spec + -- We need a temporary file to be created - Put_Line - (File, "pragma Source_File_Name_Project"); - Put_Line - (File, " (Spec_File_Name => ""*" & - Spec_Suffix_Of (In_Tree, "ada", Project.Naming) & - ""","); - Put_Line - (File, " Casing => " & - Image (Project.Naming.Casing) & ","); - Put_Line - (File, " Dot_Replacement => """ & - Namet.Get_Name_String (Project.Naming.Dot_Replacement) & - """);"); - - -- and body + Check_Temp_File; + -- Put the SFN pragmas for the naming scheme + + -- Spec + + Put_Line + (File, "pragma Source_File_Name_Project"); + Put_Line + (File, " (Spec_File_Name => ""*" & + Get_Name_String (Naming.Spec_Suffix) & ""","); + Put_Line + (File, " Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (File, " Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & """);"); + + -- and body + + Put_Line + (File, "pragma Source_File_Name_Project"); + Put_Line + (File, " (Body_File_Name => ""*" & + Get_Name_String (Naming.Body_Suffix) & ""","); + Put_Line + (File, " Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (File, " Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & + """);"); + + -- and maybe separate + + if Naming.Body_Suffix /= Naming.Separate_Suffix then + Put_Line (File, "pragma Source_File_Name_Project"); Put_Line - (File, "pragma Source_File_Name_Project"); - Put_Line - (File, " (Body_File_Name => ""*" & - Body_Suffix_Of (In_Tree, "ada", Project.Naming) & - ""","); + (File, " (Subunit_File_Name => ""*" & + Get_Name_String (Naming.Separate_Suffix) & ""","); Put_Line (File, " Casing => " & - Image (Project.Naming.Casing) & ","); + Image (Naming.Casing) & ","); Put_Line (File, " Dot_Replacement => """ & - Namet.Get_Name_String (Project.Naming.Dot_Replacement) & + Get_Name_String (Naming.Dot_Replacement) & """);"); - - -- and maybe separate - - if Body_Suffix_Of (In_Tree, "ada", Project.Naming) /= - Get_Name_String (Project.Naming.Separate_Suffix) - then - Put_Line - (File, "pragma Source_File_Name_Project"); - Put_Line - (File, " (Subunit_File_Name => ""*" & - Namet.Get_Name_String (Project.Naming.Separate_Suffix) & - ""","); - Put_Line - (File, " Casing => " & - Image (Project.Naming.Casing) & - ","); - Put_Line - (File, " Dot_Replacement => """ & - Namet.Get_Name_String (Project.Naming.Dot_Replacement) & - """);"); - end if; - end if; - - if Project.Extends /= No_Project then - Check (Project.Extends); end if; - - declare - Current : Project_List := Project.Imported_Projects; - begin - while Current /= null loop - Check (Current.Project); - Current := Current.Next; - end loop; - end; end if; end Check; @@ -660,18 +635,20 @@ package body Prj.Env is end if; end Put_Line; + procedure Check_Imported_Projects is new For_Every_Project_Imported + (Integer, Check); + Dummy : Integer := 0; + -- Start of processing for Create_Config_Pragmas_File begin if not For_Project.Config_Checked then - -- Remove any memory of processed naming schemes, if any - - Naming_Table.Set_Last (In_Tree.Private_Part.Namings, Default_Naming); + Naming_Table.Init (Namings); -- Check the naming schemes - Check (For_Project); + Check_Imported_Projects (For_Project, Dummy, Imported_First => False); -- Visit all the units and process those that need an SFN pragma @@ -830,23 +807,24 @@ package body Prj.Env is and then Source.Path.Name /= No_Path and then (Source.Language.Config.Kind = File_Based - or else Source.Unit /= No_Unit_Index) + or else Source.Unit /= No_Unit_Index) then if Source.Unit /= No_Unit_Index then Get_Name_String (Source.Unit.Name); if Get_Mode = Ada_Only then + -- ??? Mapping_Spec_Suffix could be set in the case of -- gnatmake as well - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := '%'; - Name_Len := Name_Len + 1; + + Add_Char_To_Name_Buffer ('%'); if Source.Kind = Spec then - Name_Buffer (Name_Len) := 's'; + Add_Char_To_Name_Buffer ('s'); else - Name_Buffer (Name_Len) := 'b'; + Add_Char_To_Name_Buffer ('b'); end if; + else case Source.Kind is when Spec => @@ -997,12 +975,8 @@ package body Prj.Env is The_Project : Project_Id := Project; Original_Name : String := Name; - Extended_Spec_Name : String := - Name & - Spec_Suffix_Of (In_Tree, "ada", Project.Naming); - Extended_Body_Name : String := - Name & - Body_Suffix_Of (In_Tree, "ada", Project.Naming); + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); Unit : Unit_Index; The_Original_Name : Name_Id; @@ -1010,20 +984,38 @@ package body Prj.Env is The_Body_Name : Name_Id; begin + -- ??? Same block in Project_Od Canonical_Case_File_Name (Original_Name); Name_Len := Original_Name'Length; Name_Buffer (1 .. Name_Len) := Original_Name; The_Original_Name := Name_Find; - Canonical_Case_File_Name (Extended_Spec_Name); - Name_Len := Extended_Spec_Name'Length; - Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; - The_Spec_Name := Name_Find; + if Lang /= null then + declare + Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data; + Extended_Spec_Name : String := + Name & Namet.Get_Name_String (Naming.Spec_Suffix); + Extended_Body_Name : String := + Name & Namet.Get_Name_String (Naming.Body_Suffix); + begin + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + end; - Canonical_Case_File_Name (Extended_Body_Name); - Name_Len := Extended_Body_Name'Length; - Name_Buffer (1 .. Name_Len) := Extended_Body_Name; - The_Body_Name := Name_Find; + else + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + Canonical_Case_File_Name (Name_Buffer); + The_Spec_Name := Name_Find; + The_Body_Name := The_Spec_Name; + end if; if Current_Verbosity = High then Write_Str ("Looking for file name of """); @@ -1031,11 +1023,11 @@ package body Prj.Env is Write_Char ('"'); Write_Eol; Write_Str (" Extended Spec Name = """); - Write_Str (Extended_Spec_Name); + Write_Str (Get_Name_String (The_Spec_Name)); Write_Char ('"'); Write_Eol; Write_Str (" Extended Body Name = """); - Write_Str (Extended_Body_Name); + Write_Str (Get_Name_String (The_Body_Name)); Write_Char ('"'); Write_Eol; end if; @@ -1103,7 +1095,7 @@ package body Prj.Env is (Unit.File_Names (Impl).Path.Name); else - return Extended_Body_Name; + return Get_Name_String (The_Body_Name); end if; else @@ -1167,7 +1159,7 @@ package body Prj.Env is return Get_Name_String (Unit.File_Names (Spec).Path.Name); else - return Extended_Spec_Name; + return Get_Name_String (The_Spec_Name); end if; else @@ -1442,10 +1434,8 @@ package body Prj.Env is Original_Name : String := Name; - Extended_Spec_Name : String := - Name & Spec_Suffix_Of (In_Tree, "ada", Main_Project.Naming); - Extended_Body_Name : String := - Name & Body_Suffix_Of (In_Tree, "ada", Main_Project.Naming); + Lang : constant Language_Ptr := + Get_Language_From_Name (Main_Project, "ada"); Unit : Unit_Index; @@ -1455,20 +1445,34 @@ package body Prj.Env is The_Body_Name : File_Name_Type; begin + -- ??? Same block in File_Name_Of_Library_Unit_Body Canonical_Case_File_Name (Original_Name); Name_Len := Original_Name'Length; Name_Buffer (1 .. Name_Len) := Original_Name; The_Original_Name := Name_Find; - Canonical_Case_File_Name (Extended_Spec_Name); - Name_Len := Extended_Spec_Name'Length; - Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; - The_Spec_Name := Name_Find; - - Canonical_Case_File_Name (Extended_Body_Name); - Name_Len := Extended_Body_Name'Length; - Name_Buffer (1 .. Name_Len) := Extended_Body_Name; - The_Body_Name := Name_Find; + if Lang /= null then + declare + Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; + Extended_Spec_Name : String := + Name & Namet.Get_Name_String (Naming.Spec_Suffix); + Extended_Body_Name : String := + Name & Namet.Get_Name_String (Naming.Body_Suffix); + begin + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + end; + else + The_Spec_Name := The_Original_Name; + The_Body_Name := The_Original_Name; + end if; Unit := Units_Htable.Get_First (In_Tree.Units_HT); diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index a41df8ca828..8104e341976 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -63,16 +63,9 @@ package Prj.Env is procedure Create_Config_Pragmas_File (For_Project : Project_Id; - Main_Project : Project_Id; - In_Tree : Project_Tree_Ref; - Include_Config_Files : Boolean := True); + In_Tree : Project_Tree_Ref); -- If there needs to have SFN pragmas, either for non standard naming - -- schemes or for individual units, or (when Include_Config_Files is True) - -- if Global_Configuration_Pragmas has been specified in package gnatmake - -- of the main project, or if Local_Configuration_Pragmas has been - -- specified in package Compiler of the main project, build (if needed) - -- a temporary file that contains all configuration pragmas, and specify - -- the configuration pragmas file in the project data. + -- schemes or for individual units. procedure Create_New_Path_File (In_Tree : Project_Tree_Ref; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 3c2a7ebb78c..f4a1894971e 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -273,13 +273,14 @@ package body Prj.Nmsc is procedure Check_Ada_Name (Name : String; Unit : out Name_Id); -- Check that a name is a valid Ada unit name - procedure Check_Naming_Schemes + 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); - -- Check the naming scheme part of Data. + -- 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 scheme exceptions for unit-based -- languages (Bodies and Specs are associative arrays mapping individual @@ -314,12 +315,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_Package_Naming - (Project : Project_Id; - In_Tree : Project_Tree_Ref); - -- Check package Naming of project Project in project tree In_Tree and - -- modify its data Data accordingly. - procedure Check_Programming_Languages (In_Tree : Project_Tree_Ref; Project : Project_Id); @@ -482,11 +477,7 @@ package body Prj.Nmsc is procedure Compute_Unit_Name (File_Name : File_Name_Type; - Dot_Replacement : File_Name_Type; - Separate_Suffix : File_Name_Type; - Body_Suffix : File_Name_Type; - Spec_Suffix : File_Name_Type; - Casing : Casing_Type; + Naming : Lang_Naming_Data; Kind : out Source_Kind; Unit : out Name_Id; In_Tree : Project_Tree_Ref); @@ -497,7 +488,7 @@ package body Prj.Nmsc is procedure Get_Unit (In_Tree : Project_Tree_Ref; Canonical_File_Name : File_Name_Type; - Naming : Naming_Data; + Project : Project_Id; Exception_Id : out Ada_Naming_Exception_Id; Unit_Name : out Name_Id; Unit_Kind : out Spec_Or_Body); @@ -910,11 +901,9 @@ package body Prj.Nmsc is Show_Source_Dirs (Project, In_Tree); end if; - Check_Package_Naming (Project, In_Tree); - Extending := Project.Extends /= No_Project; - Check_Naming_Schemes (Project, In_Tree, Is_Config_File, Bodies, Specs); + 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); @@ -2409,7 +2398,7 @@ package body Prj.Nmsc is Lang_Index := Project.Languages; while Lang_Index /= No_Language_Index loop -- For all languages, Compiler_Driver needs to be specified. This is - -- only necessary if we do intend to compiler (not in GPS for + -- only necessary if we do intend to compile (not in GPS for -- instance) if Compiler_Driver_Mandatory @@ -2698,10 +2687,10 @@ package body Prj.Nmsc is end Check_And_Normalize_Unit_Names; -------------------------- - -- Check_Naming_Schemes -- + -- Check_Package_Naming -- -------------------------- - procedure Check_Naming_Schemes + procedure Check_Package_Naming (Project : Project_Id; In_Tree : Project_Tree_Ref; Is_Config_File : Boolean; @@ -2712,6 +2701,9 @@ package body Prj.Nmsc is 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 @@ -2737,6 +2729,9 @@ package body Prj.Nmsc is -- In Multi_Lang mode, process the naming exceptions for the two types -- of languages we can have. + procedure Initialize_Naming_Data; + -- Initialize internal naming data for the various languages + ------------------ -- Check_Common -- ------------------ @@ -3122,129 +3117,98 @@ package body Prj.Nmsc is --------------------------- procedure Check_Naming_Ada_Only is + Ada : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + Casing_Defined : Boolean; - Spec_Suffix : File_Name_Type; - Body_Suffix : File_Name_Type; Sep_Suffix_Loc : Source_Ptr; - Ada_Spec_Suffix : constant Variable_Value := - Prj.Util.Value_Of - (Index => Name_Ada, - Src_Index => 0, - In_Array => Project.Naming.Spec_Suffix, - In_Tree => In_Tree); - - Ada_Body_Suffix : constant Variable_Value := - Prj.Util.Value_Of - (Index => Name_Ada, - Src_Index => 0, - In_Array => Project.Naming.Body_Suffix, - In_Tree => In_Tree); - begin - -- The default value of separate suffix should be the same as the - -- body suffix, so we need to compute that first. - - if Ada_Body_Suffix.Kind = Single - and then Length_Of_Name (Ada_Body_Suffix.Value) /= 0 - then - Body_Suffix := Canonical_Case_File_Name (Ada_Body_Suffix.Value); - Project.Naming.Separate_Suffix := Body_Suffix; - Set_Body_Suffix (In_Tree, "ada", Project.Naming, Body_Suffix); - - else - Body_Suffix := Default_Ada_Body_Suffix; - Project.Naming.Separate_Suffix := Body_Suffix; - Set_Body_Suffix (In_Tree, "ada", Project.Naming, Body_Suffix); + if Ada = null then + -- No language, thus nothing to do + return; end if; - Write_Attr ("Body_Suffix", Get_Name_String (Body_Suffix)); + 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. - -- We'll need the dot replacement below, so compute it now + Data.Separate_Suffix := Data.Body_Suffix; + Write_Attr ("Body_Suffix", Get_Name_String (Data.Body_Suffix)); - Check_Common - (Dot_Replacement => Project.Naming.Dot_Replacement, - Casing => Project.Naming.Casing, - Casing_Defined => Casing_Defined, - Separate_Suffix => Project.Naming.Separate_Suffix, - Sep_Suffix_Loc => Sep_Suffix_Loc); + -- We'll need the dot replacement below, so compute it now - Bodies := Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree); + 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); - if Bodies /= No_Array_Element then - Check_And_Normalize_Unit_Names - (Project, In_Tree, Bodies, "Naming.Bodies"); - end if; + Bodies := Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree); - Specs := Util.Value_Of (Name_Spec, Naming.Decl.Arrays, In_Tree); + if Bodies /= No_Array_Element then + Check_And_Normalize_Unit_Names + (Project, In_Tree, Bodies, "Naming.Bodies"); + end if; - if Specs /= No_Array_Element then - Check_And_Normalize_Unit_Names - (Project, In_Tree, Specs, "Naming.Specs"); - end if; + Specs := Util.Value_Of (Name_Spec, Naming.Decl.Arrays, In_Tree); - -- Check Spec_Suffix + if Specs /= No_Array_Element then + Check_And_Normalize_Unit_Names + (Project, In_Tree, Specs, "Naming.Specs"); + end if; - if Ada_Spec_Suffix.Kind = Single - and then Length_Of_Name (Ada_Spec_Suffix.Value) /= 0 - then - Spec_Suffix := Canonical_Case_File_Name (Ada_Spec_Suffix.Value); - Set_Spec_Suffix (In_Tree, "ada", Project.Naming, Spec_Suffix); + -- Check Spec_Suffix - if Is_Illegal_Suffix - (Spec_Suffix, Project.Naming.Dot_Replacement) - then - Err_Vars.Error_Msg_File_1 := 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.Location); + Ada_Spec_Suffix_Loc); end if; - else - Spec_Suffix := Default_Ada_Spec_Suffix; - Set_Spec_Suffix (In_Tree, "ada", Project.Naming, Spec_Suffix); - end if; - - Write_Attr ("Spec_Suffix", Get_Name_String (Spec_Suffix)); + Write_Attr ("Spec_Suffix", Get_Name_String (Data.Spec_Suffix)); - -- Check Body_Suffix + -- Check Body_Suffix - if Is_Illegal_Suffix - (Body_Suffix, Project.Naming.Dot_Replacement) - then - Err_Vars.Error_Msg_File_1 := Body_Suffix; - Error_Msg - (Project, In_Tree, - "{ is illegal for Body_Suffix", - Ada_Body_Suffix.Location); - end if; + 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. + -- 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 Spec_Suffix = Body_Suffix then - Error_Msg - (Project, In_Tree, - "Body_Suffix (""" & - Get_Name_String (Body_Suffix) & - """) cannot be the same as Spec_Suffix.", - Ada_Body_Suffix.Location); - end if; + 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 Body_Suffix /= Project.Naming.Separate_Suffix - and then Spec_Suffix = Project.Naming.Separate_Suffix - then - Error_Msg - (Project, In_Tree, - "Separate_Suffix (""" & - Get_Name_String (Project.Naming.Separate_Suffix) & - """) cannot be the same as Spec_Suffix.", - Sep_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; ----------------------------- @@ -3375,10 +3339,92 @@ package body Prj.Nmsc is end loop; end Check_Naming_Multi_Lang; + ---------------------------- + -- Initialize_Naming_Data -- + ---------------------------- + + procedure Initialize_Naming_Data is + Specs : Array_Element_Id := + Util.Value_Of + (Name_Spec_Suffix, + Naming.Decl.Arrays, + In_Tree); + Impls : Array_Element_Id := + Util.Value_Of + (Name_Body_Suffix, + Naming.Decl.Arrays, + In_Tree); + Lang : Language_Ptr; + Lang_Name : Name_Id; + Value : Variable_Value; + + begin + -- At this stage, the project already contains the default + -- extensions for the various languages. We now merge those + -- suffixes read in the user project, and they override the + -- default + + while Specs /= No_Array_Element loop + Lang_Name := In_Tree.Array_Elements.Table (Specs).Index; + Lang := Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); + + if Lang = null then + if Current_Verbosity = High then + Write_Line + ("Ignoring spec naming data for " + & Get_Name_String (Lang_Name) + & " since language is not defined for this project"); + end if; + 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); + end if; + end if; + + Specs := In_Tree.Array_Elements.Table (Specs).Next; + end loop; + + while Impls /= No_Array_Element loop + Lang_Name := In_Tree.Array_Elements.Table (Impls).Index; + Lang := Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); + + if Lang = null then + if Current_Verbosity = High then + Write_Line + ("Ignoring impl naming data for " + & Get_Name_String (Lang_Name) + & " since language is not defined for this project"); + end if; + else + Value := In_Tree.Array_Elements.Table (Impls).Value; + + if Lang.Name = Name_Ada then + Ada_Body_Suffix_Loc := Value.Location; + end if; + + if Value.Kind = Single then + Lang.Config.Naming_Data.Body_Suffix := + Canonical_Case_File_Name (Value.Value); + end if; + end if; + + Impls := In_Tree.Array_Elements.Table (Impls).Next; + end loop; + end Initialize_Naming_Data; + -- Start of processing for Check_Naming_Schemes begin - Specs := No_Array_Element; + Specs := No_Array_Element; Bodies := No_Array_Element; -- No Naming package or parsing a configuration file? nothing to do @@ -3387,9 +3433,12 @@ package body Prj.Nmsc is Naming := In_Tree.Packages.Table (Naming_Id); if Current_Verbosity = High then - Write_Line ("Checking package Naming."); + Write_Line ("Checking package Naming for project " + & Get_Name_String (Project.Name)); end if; + Initialize_Naming_Data; + case Get_Mode is when Ada_Only => Check_Naming_Ada_Only; @@ -3397,7 +3446,7 @@ package body Prj.Nmsc is Check_Naming_Multi_Lang; end case; end if; - end Check_Naming_Schemes; + end Check_Package_Naming; ------------------------------ -- Check_Library_Attributes -- @@ -4091,154 +4140,6 @@ package body Prj.Nmsc is end if; end Check_Library_Attributes; - -------------------------- - -- Check_Package_Naming -- - -------------------------- - - procedure Check_Package_Naming - (Project : Project_Id; - In_Tree : Project_Tree_Ref) - is - Naming_Id : constant Package_Id := - Util.Value_Of (Name_Naming, Project.Decl.Packages, In_Tree); - - Naming : Package_Element; - - begin - -- If there is a package Naming, we will put in Data.Naming - -- what is in this package Naming. - - if Naming_Id /= No_Package then - Naming := In_Tree.Packages.Table (Naming_Id); - - if Current_Verbosity = High then - Write_Line ("Checking ""Naming""."); - end if; - - -- Check Spec_Suffix - - declare - Spec_Suffixs : Array_Element_Id := - Util.Value_Of - (Name_Spec_Suffix, - Naming.Decl.Arrays, - In_Tree); - - Suffix : Array_Element_Id; - Element : Array_Element; - Suffix2 : Array_Element_Id; - - begin - -- If some suffixes have been specified, we make sure that - -- for each language for which a default suffix has been - -- specified, there is a suffix specified, either the one - -- in the project file or if there were none, the default. - - if Spec_Suffixs /= No_Array_Element then - Suffix := Project.Naming.Spec_Suffix; - - while Suffix /= No_Array_Element loop - Element := - In_Tree.Array_Elements.Table (Suffix); - Suffix2 := Spec_Suffixs; - - while Suffix2 /= No_Array_Element loop - exit when In_Tree.Array_Elements.Table - (Suffix2).Index = Element.Index; - Suffix2 := In_Tree.Array_Elements.Table - (Suffix2).Next; - end loop; - - -- There is a registered default suffix, but no - -- suffix specified in the project file. - -- Add the default to the array. - - if Suffix2 = No_Array_Element then - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last - (In_Tree.Array_Elements)) := - (Index => Element.Index, - Src_Index => Element.Src_Index, - Index_Case_Sensitive => False, - Value => Element.Value, - Next => Spec_Suffixs); - Spec_Suffixs := Array_Element_Table.Last - (In_Tree.Array_Elements); - end if; - - Suffix := Element.Next; - end loop; - - -- Put the resulting array as the Spec suffixes - - Project.Naming.Spec_Suffix := Spec_Suffixs; - end if; - end; - - -- Check Body_Suffix - - declare - Impl_Suffixs : Array_Element_Id := - Util.Value_Of - (Name_Body_Suffix, - Naming.Decl.Arrays, - In_Tree); - - Suffix : Array_Element_Id; - Element : Array_Element; - Suffix2 : Array_Element_Id; - - begin - -- If some suffixes have been specified, we make sure that - -- for each language for which a default suffix has been - -- specified, there is a suffix specified, either the one - -- in the project file or if there were none, the default. - - if Impl_Suffixs /= No_Array_Element then - Suffix := Project.Naming.Body_Suffix; - while Suffix /= No_Array_Element loop - Element := - In_Tree.Array_Elements.Table (Suffix); - - Suffix2 := Impl_Suffixs; - while Suffix2 /= No_Array_Element loop - exit when In_Tree.Array_Elements.Table - (Suffix2).Index = Element.Index; - Suffix2 := In_Tree.Array_Elements.Table - (Suffix2).Next; - end loop; - - -- There is a registered default suffix, but no suffix was - -- specified in the project file. Add default to the array. - - if Suffix2 = No_Array_Element then - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last - (In_Tree.Array_Elements)) := - (Index => Element.Index, - Src_Index => Element.Src_Index, - Index_Case_Sensitive => False, - Value => Element.Value, - Next => Impl_Suffixs); - Impl_Suffixs := Array_Element_Table.Last - (In_Tree.Array_Elements); - end if; - - Suffix := Element.Next; - end loop; - - -- Put the resulting array as the implementation suffixes - - Project.Naming.Body_Suffix := Impl_Suffixs; - end if; - end; - end if; - end Check_Package_Naming; - --------------------------------- -- Check_Programming_Languages -- --------------------------------- @@ -4251,8 +4152,53 @@ package body Prj.Nmsc is Def_Lang : Variable_Value := Nil_Variable_Value; Def_Lang_Id : Name_Id; + procedure Add_Language (Name, Display_Name : Name_Id); + -- Add a new language to the list of languages for the project. + -- Nothing is done if the language has already been defined + + procedure Add_Language (Name, Display_Name : Name_Id) is + Lang : Language_Ptr := Project.Languages; + begin + while Lang /= No_Language_Index loop + if Name = Lang.Name then + return; + end if; + + Lang := Lang.Next; + end loop; + + Lang := new Language_Data'(No_Language_Data); + Lang.Next := Project.Languages; + Project.Languages := Lang; + Lang.Name := Name; + Lang.Display_Name := Display_Name; + + if Name = Name_Ada then + Lang.Config.Kind := Unit_Based; + Lang.Config.Dependency_Kind := ALI_File; + + if Get_Mode = Ada_Only then + -- Create a default config for Ada (since there is no + -- configuration file to create it for us) + -- ??? We should do as GPS does and create a dummy config + -- file + + Lang.Config.Naming_Data := + (Dot_Replacement => File_Name_Type + (First_Name_Id + Character'Pos ('-')), + Casing => All_Lower_Case, + Separate_Suffix => Default_Ada_Body_Suffix, + Spec_Suffix => Default_Ada_Spec_Suffix, + Body_Suffix => Default_Ada_Body_Suffix); + end if; + + else + Lang.Config.Kind := File_Based; + end if; + end Add_Language; + begin - Project.Languages := No_Language_Index; + Project.Languages := null; Languages := Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, In_Tree); Def_Lang := @@ -4296,27 +4242,17 @@ package body Prj.Nmsc is end if; if Def_Lang_Id /= No_Name then - Project.Languages := new Language_Data'(No_Language_Data); - Project.Languages.Name := Def_Lang_Id; Get_Name_String (Def_Lang_Id); Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1)); - Project.Languages.Display_Name := Name_Find; - - if Def_Lang_Id = Name_Ada then - Project.Languages.Config.Kind := Unit_Based; - Project.Languages.Config.Dependency_Kind := ALI_File; - else - Project.Languages.Config.Kind := File_Based; - end if; + Add_Language + (Name => Def_Lang_Id, + Display_Name => Name_Find); end if; else declare Current : String_List_Id := Languages.Values; Element : String_Element; - Lang_Name : Name_Id; - Index : Language_Ptr; - NL_Id : Language_Ptr; begin -- If there are no languages declared, there are no sources @@ -4340,34 +4276,10 @@ package body Prj.Nmsc is Element := In_Tree.String_Elements.Table (Current); Get_Name_String (Element.Value); To_Lower (Name_Buffer (1 .. Name_Len)); - Lang_Name := Name_Find; - -- If the language was not already specified (duplicates - -- are simply ignored). - - NL_Id := Project.Languages; - while NL_Id /= No_Language_Index loop - exit when Lang_Name = NL_Id.Name; - NL_Id := NL_Id.Next; - end loop; - - if NL_Id = No_Language_Index then - Index := new Language_Data'(No_Language_Data); - Index.Name := Lang_Name; - Index.Display_Name := Element.Value; - Index.Next := Project.Languages; - - if Lang_Name = Name_Ada then - Index.Config.Kind := Unit_Based; - Index.Config.Dependency_Kind := ALI_File; - - else - Index.Config.Kind := File_Based; - Index.Config.Dependency_Kind := None; - end if; - - Project.Languages := Index; - end if; + Add_Language + (Name => Name_Find, + Display_Name => Element.Value); Current := Element.Next; end loop; @@ -6115,11 +6027,7 @@ package body Prj.Nmsc is procedure Compute_Unit_Name (File_Name : File_Name_Type; - Dot_Replacement : File_Name_Type; - Separate_Suffix : File_Name_Type; - Body_Suffix : File_Name_Type; - Spec_Suffix : File_Name_Type; - Casing : Casing_Type; + Naming : Lang_Naming_Data; Kind : out Source_Kind; Unit : out Name_Id; In_Tree : Project_Tree_Ref) @@ -6127,16 +6035,16 @@ package body Prj.Nmsc is Filename : constant String := Get_Name_String (File_Name); Last : Integer := Filename'Last; Sep_Len : constant Integer := - Integer (Length_Of_Name (Separate_Suffix)); + Integer (Length_Of_Name (Naming.Separate_Suffix)); Body_Len : constant Integer := - Integer (Length_Of_Name (Body_Suffix)); + Integer (Length_Of_Name (Naming.Body_Suffix)); Spec_Len : constant Integer := - Integer (Length_Of_Name (Spec_Suffix)); + Integer (Length_Of_Name (Naming.Spec_Suffix)); Standard_GNAT : constant Boolean := - Spec_Suffix = Default_Ada_Spec_Suffix + Naming.Spec_Suffix = Default_Ada_Spec_Suffix and then - Body_Suffix = Default_Ada_Body_Suffix; + Naming.Body_Suffix = Default_Ada_Body_Suffix; Unit_Except : Unit_Exception; Masked : Boolean := False; @@ -6144,7 +6052,7 @@ package body Prj.Nmsc is Unit := No_Name; Kind := Spec; - if Dot_Replacement = No_File then + if Naming.Dot_Replacement = No_File then if Current_Verbosity = High then Write_Line (" No dot_replacement specified"); end if; @@ -6154,22 +6062,22 @@ package body Prj.Nmsc is -- Choose the longest suffix that matches. If there are several matches, -- give priority to specs, then bodies, then separates. - if Separate_Suffix /= Body_Suffix - and then Suffix_Matches (Filename, Separate_Suffix) + if Naming.Separate_Suffix /= Naming.Body_Suffix + and then Suffix_Matches (Filename, Naming.Separate_Suffix) then Last := Filename'Last - Sep_Len; Kind := Sep; end if; if Filename'Last - Body_Len <= Last - and then Suffix_Matches (Filename, Body_Suffix) + and then Suffix_Matches (Filename, Naming.Body_Suffix) then Last := Natural'Min (Last, Filename'Last - Body_Len); Kind := Impl; end if; if Filename'Last - Spec_Len <= Last - and then Suffix_Matches (Filename, Spec_Suffix) + and then Suffix_Matches (Filename, Naming.Spec_Suffix) then Last := Natural'Min (Last, Filename'Last - Spec_Len); Kind := Spec; @@ -6185,7 +6093,7 @@ package body Prj.Nmsc is -- Check that the casing matches if File_Names_Case_Sensitive then - case Casing is + case Naming.Casing is when All_Lower_Case => for J in Filename'First .. Last loop if Is_Letter (Filename (J)) @@ -6219,7 +6127,8 @@ package body Prj.Nmsc is -- be any dot in the name. declare - Dot_Repl : constant String := Get_Name_String (Dot_Replacement); + Dot_Repl : constant String := + Get_Name_String (Naming.Dot_Replacement); begin if Dot_Repl /= "." then @@ -6345,7 +6254,7 @@ package body Prj.Nmsc is procedure Get_Unit (In_Tree : Project_Tree_Ref; Canonical_File_Name : File_Name_Type; - Naming : Naming_Data; + Project : Project_Id; Exception_Id : out Ada_Naming_Exception_Id; Unit_Name : out Name_Id; Unit_Kind : out Spec_Or_Body) @@ -6354,6 +6263,7 @@ package body Prj.Nmsc is 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 @@ -6377,21 +6287,24 @@ package body Prj.Nmsc is else Exception_Id := No_Ada_Naming_Exception; - Compute_Unit_Name - (File_Name => Canonical_File_Name, - Dot_Replacement => Naming.Dot_Replacement, - Separate_Suffix => Naming.Separate_Suffix, - Body_Suffix => Body_Suffix_Id_Of (In_Tree, Name_Ada, Naming), - Spec_Suffix => Spec_Suffix_Id_Of (In_Tree, Name_Ada, Naming), - Casing => Naming.Casing, - Kind => Kind, - Unit => Unit_Name, - In_Tree => In_Tree); + Lang := Get_Language_From_Name (Project, "ada"); - case Kind is - when Spec => Unit_Kind := Spec; - when Impl | Sep => Unit_Kind := Impl; - end case; + 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; @@ -7286,11 +7199,7 @@ package body Prj.Nmsc is if not Header_File then Compute_Unit_Name (File_Name => File_Name, - Dot_Replacement => Config.Naming_Data.Dot_Replacement, - Separate_Suffix => Config.Naming_Data.Separate_Suffix, - Body_Suffix => Config.Naming_Data.Body_Suffix, - Spec_Suffix => Config.Naming_Data.Spec_Suffix, - Casing => Config.Naming_Data.Casing, + Naming => Config.Naming_Data, Kind => Kind, Unit => Unit, In_Tree => In_Tree); @@ -8219,7 +8128,7 @@ package body Prj.Nmsc is Get_Unit (In_Tree => In_Tree, Canonical_File_Name => Canonical_File, - Naming => Project.Naming, + Project => Project, Exception_Id => Exception_Id, Unit_Name => Unit_Name, Unit_Kind => Unit_Kind); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 31cd2922557..4c45642bf0d 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -2336,6 +2336,7 @@ package body Prj.Proc is begin Error_Report := Report_Error; + Success := True; if Project /= No_Project then @@ -2581,7 +2582,7 @@ package body Prj.Proc is return; end if; - Project := new Project_Data'(Empty_Project (In_Tree)); + Project := new Project_Data'(Empty_Project); In_Tree.Projects := new Project_List_Element' (Project => Project, Next => In_Tree.Projects); diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index cd7696fdfed..5e36fcd71e6 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -134,7 +134,7 @@ package body Prj.Util is Executable_Suffix_Name : Name_Id := No_Name; - Naming : constant Naming_Data := Project.Naming; + Lang : Language_Ptr; Spec_Suffix : Name_Id := No_Name; Body_Suffix : Name_Id := No_Name; @@ -143,8 +143,8 @@ package body Prj.Util is Body_Suffix_Length : Natural := 0; procedure Get_Suffixes - (B_Suffix : String; - S_Suffix : String); + (B_Suffix : File_Name_Type; + S_Suffix : File_Name_Type); -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix ------------------ @@ -152,22 +152,18 @@ package body Prj.Util is ------------------ procedure Get_Suffixes - (B_Suffix : String; - S_Suffix : String) + (B_Suffix : File_Name_Type; + S_Suffix : File_Name_Type) is begin - if B_Suffix'Length > 0 then - Name_Len := B_Suffix'Length; - Name_Buffer (1 .. Name_Len) := B_Suffix; - Body_Suffix := Name_Find; - Body_Suffix_Length := B_Suffix'Length; + if B_Suffix /= No_File then + Body_Suffix := Name_Id (B_Suffix); + Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix)); end if; - if S_Suffix'Length > 0 then - Name_Len := S_Suffix'Length; - Name_Buffer (1 .. Name_Len) := S_Suffix; - Spec_Suffix := Name_Find; - Spec_Suffix_Length := S_Suffix'Length; + if S_Suffix /= No_File then + Spec_Suffix := Name_Id (S_Suffix); + Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix)); end if; end Get_Suffixes; @@ -175,14 +171,15 @@ package body Prj.Util is begin if Ada_Main then - Get_Suffixes - (B_Suffix => Body_Suffix_Of (In_Tree, "ada", Naming), - S_Suffix => Spec_Suffix_Of (In_Tree, "ada", Naming)); - + Lang := Get_Language_From_Name (Project, "ada"); elsif Language /= "" then + Lang := Get_Language_From_Name (Project, Language); + end if; + + if Lang /= null then Get_Suffixes - (B_Suffix => Body_Suffix_Of (In_Tree, Language, Naming), - S_Suffix => Spec_Suffix_Of (In_Tree, Language, Naming)); + (B_Suffix => Lang.Config.Naming_Data.Body_Suffix, + S_Suffix => Lang.Config.Naming_Data.Spec_Suffix); end if; if Builder_Package /= No_Package then @@ -217,7 +214,8 @@ package body Prj.Util is Truncated : Boolean := False; begin - if Last > Natural (Length_Of_Name (Body_Suffix)) + if Body_Suffix /= No_Name + and then Last > Natural (Length_Of_Name (Body_Suffix)) and then Name (Last - Body_Suffix_Length + 1 .. Last) = Get_Name_String (Body_Suffix) then @@ -225,7 +223,8 @@ package body Prj.Util is Last := Last - Body_Suffix_Length; end if; - if not Truncated + if Spec_Suffix /= No_Name + and then not Truncated and then Last > Spec_Suffix_Length and then Name (Last - Spec_Suffix_Length + 1 .. Last) = Get_Name_String (Spec_Suffix) diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index e66182fc9f4..ec7eeaa0903 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -64,17 +64,6 @@ package body Prj is Initialized : Boolean := False; - Standard_Dot_Replacement : constant File_Name_Type := - File_Name_Type - (First_Name_Id + Character'Pos ('-')); - - Std_Naming_Data : constant Naming_Data := - (Dot_Replacement => Standard_Dot_Replacement, - Casing => All_Lower_Case, - Spec_Suffix => No_Array_Element, - Body_Suffix => No_Array_Element, - Separate_Suffix => No_File); - Project_Empty : constant Project_Data := (Qualifier => Unspecified, Externally_Built => False, @@ -108,8 +97,7 @@ package body Prj is Exec_Directory => No_Path_Information, Extends => No_Project, Extended_By => No_Project, - Naming => Std_Naming_Data, - Languages => No_Language_Index, + Languages => No_Language_Index, Decl => No_Declarations, Imported_Projects => null, All_Imported_Projects => null, @@ -187,67 +175,6 @@ package body Prj is Last := Last + S'Length; end Add_To_Buffer; - ----------------------- - -- Body_Suffix_Id_Of -- - ----------------------- - - function Body_Suffix_Id_Of - (In_Tree : Project_Tree_Ref; - Language_Id : Name_Id; - Naming : Naming_Data) return File_Name_Type - is - Element_Id : Array_Element_Id; - Element : Array_Element; - - begin - -- ??? This seems to be only for Ada_Only mode... - Element_Id := Naming.Body_Suffix; - while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); - - if Element.Index = Language_Id then - return File_Name_Type (Element.Value.Value); - end if; - - Element_Id := Element.Next; - end loop; - - return No_File; - end Body_Suffix_Id_Of; - - -------------------- - -- Body_Suffix_Of -- - -------------------- - - function Body_Suffix_Of - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : Naming_Data) return String - is - Language_Id : Name_Id; - Element_Id : Array_Element_Id; - Element : Array_Element; - - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Language); - To_Lower (Name_Buffer (1 .. Name_Len)); - Language_Id := Name_Find; - - Element_Id := Naming.Body_Suffix; - while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); - - if Element.Index = Language_Id then - return Get_Name_String (Element.Value.Value); - end if; - - Element_Id := Element.Next; - end loop; - - return ""; - end Body_Suffix_Of; - ----------------------------- -- Default_Ada_Body_Suffix -- ----------------------------- @@ -322,15 +249,10 @@ package body Prj is -- Empty_Project -- ------------------- - function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is - Value : Project_Data; - + function Empty_Project return Project_Data is begin Prj.Initialize (Tree => No_Project_Tree); - Value := Project_Empty; - Value.Naming := Tree.Private_Part.Default_Naming; - - return Value; + return Project_Empty; end Empty_Project; ------------------ @@ -690,110 +612,6 @@ package body Prj is Temp_Files.Table (Temp_Files.Last) := Path; end Record_Temp_File; - ------------------------------------ - -- Register_Default_Naming_Scheme -- - ------------------------------------ - - procedure Register_Default_Naming_Scheme - (Language : Name_Id; - Default_Spec_Suffix : File_Name_Type; - Default_Body_Suffix : File_Name_Type; - In_Tree : Project_Tree_Ref) - is - Lang : Name_Id; - Suffix : Array_Element_Id; - Found : Boolean := False; - Element : Array_Element; - - begin - -- Get the language name in small letters - - Get_Name_String (Language); - Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); - Lang := Name_Find; - - -- Look for an element of the spec suffix array indexed by the language - -- name. If one is found, put the default value. - - Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix; - Found := False; - while Suffix /= No_Array_Element and then not Found loop - Element := In_Tree.Array_Elements.Table (Suffix); - - if Element.Index = Lang then - Found := True; - Element.Value.Value := Name_Id (Default_Spec_Suffix); - In_Tree.Array_Elements.Table (Suffix) := Element; - - else - Suffix := Element.Next; - end if; - end loop; - - -- If none can be found, create a new one - - if not Found then - Element := - (Index => Lang, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => (Project => No_Project, - Kind => Single, - Location => No_Location, - Default => False, - Value => Name_Id (Default_Spec_Suffix), - Index => 0), - Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix); - Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last (In_Tree.Array_Elements)) := - Element; - In_Tree.Private_Part.Default_Naming.Spec_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - end if; - - -- Look for an element of the body suffix array indexed by the language - -- name. If one is found, put the default value. - - Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix; - Found := False; - while Suffix /= No_Array_Element and then not Found loop - Element := In_Tree.Array_Elements.Table (Suffix); - - if Element.Index = Lang then - Found := True; - Element.Value.Value := Name_Id (Default_Body_Suffix); - In_Tree.Array_Elements.Table (Suffix) := Element; - - else - Suffix := Element.Next; - end if; - end loop; - - -- If none can be found, create a new one - - if not Found then - Element := - (Index => Lang, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => (Project => No_Project, - Kind => Single, - Location => No_Location, - Default => False, - Value => Name_Id (Default_Body_Suffix), - Index => 0), - Next => In_Tree.Private_Part.Default_Naming.Body_Suffix); - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last (In_Tree.Array_Elements)) - := Element; - In_Tree.Private_Part.Default_Naming.Body_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - end if; - end Register_Default_Naming_Scheme; - ---------- -- Free -- ---------- @@ -955,7 +773,6 @@ package body Prj is -- Private part - Naming_Table.Free (Tree.Private_Part.Namings); Path_File_Table.Free (Tree.Private_Part.Path_Files); Source_Path_Table.Free (Tree.Private_Part.Source_Paths); Object_Path_Table.Free (Tree.Private_Part.Object_Paths); @@ -992,24 +809,11 @@ package body Prj is -- Private part table - Naming_Table.Init (Tree.Private_Part.Namings); - Naming_Table.Increment_Last (Tree.Private_Part.Namings); - Tree.Private_Part.Namings.Table - (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data; Path_File_Table.Init (Tree.Private_Part.Path_Files); Source_Path_Table.Init (Tree.Private_Part.Source_Paths); Object_Path_Table.Init (Tree.Private_Part.Object_Paths); - Tree.Private_Part.Default_Naming := Std_Naming_Data; if Current_Mode = Ada_Only then - Register_Default_Naming_Scheme - (Language => Name_Ada, - Default_Spec_Suffix => Default_Ada_Spec_Suffix, - Default_Body_Suffix => Default_Ada_Body_Suffix, - In_Tree => Tree); - Tree.Private_Part.Default_Naming.Separate_Suffix := - Default_Ada_Body_Suffix; - Tree.Private_Part.Current_Source_Path_File := No_Path; Tree.Private_Part.Current_Object_Path_File := No_Path; Tree.Private_Part.Ada_Path_Length := 0; @@ -1019,57 +823,6 @@ package body Prj is end if; end Reset; - ------------------------ - -- Same_Naming_Scheme -- - ------------------------ - - function Same_Naming_Scheme - (Left, Right : Naming_Data) return Boolean - is - begin - return Left.Dot_Replacement = Right.Dot_Replacement - and then Left.Casing = Right.Casing - and then Left.Separate_Suffix = Right.Separate_Suffix; - end Same_Naming_Scheme; - - --------------------- - -- Set_Body_Suffix -- - --------------------- - - procedure Set_Body_Suffix - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : in out Naming_Data; - Suffix : File_Name_Type) - is - Language_Id : Name_Id; - Element : Array_Element; - - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Language); - To_Lower (Name_Buffer (1 .. Name_Len)); - Language_Id := Name_Find; - - Element := - (Index => Language_Id, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => - (Kind => Single, - Project => No_Project, - Location => No_Location, - Default => False, - Value => Name_Id (Suffix), - Index => 0), - Next => Naming.Body_Suffix); - - Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - Naming.Body_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element; - end Set_Body_Suffix; - -------------- -- Set_Mode -- -------------- @@ -1088,120 +841,6 @@ package body Prj is end case; end Set_Mode; - --------------------- - -- Set_Spec_Suffix -- - --------------------- - - procedure Set_Spec_Suffix - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : in out Naming_Data; - Suffix : File_Name_Type) - is - Language_Id : Name_Id; - Element : Array_Element; - - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Language); - To_Lower (Name_Buffer (1 .. Name_Len)); - Language_Id := Name_Find; - - Element := - (Index => Language_Id, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => - (Kind => Single, - Project => No_Project, - Location => No_Location, - Default => False, - Value => Name_Id (Suffix), - Index => 0), - Next => Naming.Spec_Suffix); - - Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - Naming.Spec_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element; - end Set_Spec_Suffix; - - ----------------------- - -- Spec_Suffix_Id_Of -- - ----------------------- - - function Spec_Suffix_Id_Of - (In_Tree : Project_Tree_Ref; - Language_Id : Name_Id; - Naming : Naming_Data) return File_Name_Type - is - Element_Id : Array_Element_Id; - Element : Array_Element; - - begin - Element_Id := Naming.Spec_Suffix; - while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); - - if Element.Index = Language_Id then - return File_Name_Type (Element.Value.Value); - end if; - - Element_Id := Element.Next; - end loop; - - return No_File; - end Spec_Suffix_Id_Of; - - -------------------- - -- Spec_Suffix_Of -- - -------------------- - - function Spec_Suffix_Of - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : Naming_Data) return String - is - Language_Id : Name_Id; - Element_Id : Array_Element_Id; - Element : Array_Element; - - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Language); - To_Lower (Name_Buffer (1 .. Name_Len)); - Language_Id := Name_Find; - - Element_Id := Naming.Spec_Suffix; - while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); - - if Element.Index = Language_Id then - return Get_Name_String (Element.Value.Value); - end if; - - Element_Id := Element.Next; - end loop; - - return ""; - end Spec_Suffix_Of; - - -------------------------- - -- Standard_Naming_Data -- - -------------------------- - - function Standard_Naming_Data - (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data - is - begin - if Tree = No_Project_Tree then - Prj.Initialize (Tree => No_Project_Tree); - return Std_Naming_Data; - else - return Tree.Private_Part.Default_Naming; - end if; - end Standard_Naming_Data; - ------------------- -- Switches_Name -- ------------------- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index ebb45782a2c..22280252ec5 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -830,61 +830,6 @@ package Prj is -- The following record contains data for a naming scheme - type Naming_Data is record - - Dot_Replacement : File_Name_Type := No_File; - -- The string to replace '.' in the source file name (for Ada) - - Casing : Casing_Type := All_Lower_Case; - -- The casing of the source file name (for Ada) - - Spec_Suffix : Array_Element_Id := No_Array_Element; - -- The string to append to the unit name for the - -- source file name of a spec. - -- Indexed by the programming language. - - Body_Suffix : Array_Element_Id := No_Array_Element; - -- The string to append to the unit name for the - -- source file name of a body. - -- Indexed by the programming language. - - Separate_Suffix : File_Name_Type := No_File; - -- String to append to unit name for source file name of an Ada subunit - - end record; - - function Spec_Suffix_Of - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : Naming_Data) return String; - - function Spec_Suffix_Id_Of - (In_Tree : Project_Tree_Ref; - Language_Id : Name_Id; - Naming : Naming_Data) return File_Name_Type; - - procedure Set_Spec_Suffix - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : in out Naming_Data; - Suffix : File_Name_Type); - - function Body_Suffix_Id_Of - (In_Tree : Project_Tree_Ref; - Language_Id : Name_Id; - Naming : Naming_Data) return File_Name_Type; - - function Body_Suffix_Of - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : Naming_Data) return String; - - procedure Set_Body_Suffix - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : in out Naming_Data; - Suffix : File_Name_Type); - function Get_Object_Directory (Project : Project_Id; Including_Libraries : Boolean; @@ -906,18 +851,6 @@ package Prj is -- Returns the ultimate extending project of project Proj. If project Proj -- is not extended, returns Proj. - function Standard_Naming_Data - (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data; - pragma Inline (Standard_Naming_Data); - -- The standard GNAT naming scheme when Tree is No_Project_Tree. - -- Otherwise, return the default naming scheme for the project tree Tree, - -- which must have been Initialized. - - function Same_Naming_Scheme - (Left, Right : Naming_Data) return Boolean; - -- Returns True if Left and Right are the same naming scheme - -- not considering Specs and Bodies. - type Project_List_Element; type Project_List is access all Project_List_Element; type Project_List_Element is record @@ -1121,9 +1054,6 @@ package Prj is Location : Source_Ptr := No_Location; -- The location in the project file source of the reserved word project - Naming : Naming_Data := Standard_Naming_Data; - -- The naming scheme of this project file - --------------- -- Languages -- --------------- @@ -1305,9 +1235,9 @@ package Prj is end record; - function Empty_Project (Tree : Project_Tree_Ref) return Project_Data; - -- Return the representation of an empty project in project Tree tree. - -- The project tree Tree must have been Initialized and/or Reset. + function Empty_Project return Project_Data; + -- Return the representation of an empty project. + -- In Ada-only mode, the Ada language is also partly initialized function Is_Extending (Extending : Project_Id; @@ -1410,18 +1340,6 @@ package Prj is -- This procedure resets all the tables that are used when processing a -- project file tree. Initialize must be called before the call to Reset. - procedure Register_Default_Naming_Scheme - (Language : Name_Id; - Default_Spec_Suffix : File_Name_Type; - Default_Body_Suffix : File_Name_Type; - In_Tree : Project_Tree_Ref); - -- Register the default suffixes for a given language. These extensions - -- will be ignored if the user has specified a new naming scheme in a - -- project file. - -- - -- Otherwise, this information will be automatically added to Naming_Data - -- when a project is processed, in the lists Spec_Suffix and Body_Suffix. - package Project_Boolean_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Boolean, @@ -1531,16 +1449,6 @@ private Last : in out Natural); -- Append a String to the Buffer - type Naming_Id is new Nat; - - package Naming_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Naming_Data, - Table_Index_Type => Naming_Id, - Table_Low_Bound => 1, - Table_Initial => 5, - Table_Increment => 100); - -- Table storing the naming data for gnatmake/gprmake - package Path_File_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Path_Name_Type, Table_Index_Type => Natural, @@ -1567,26 +1475,28 @@ private -- A table to store the object dirs, before creating the object path file type Private_Project_Tree_Data is record - Namings : Naming_Table.Instance; Path_Files : Path_File_Table.Instance; Source_Paths : Source_Path_Table.Instance; Object_Paths : Object_Path_Table.Instance; - Default_Naming : Naming_Data; Current_Source_Path_File : Path_Name_Type := No_Path; -- Current value of project source path file env var. Used to avoid -- setting the env var to the same value. + -- gnatmake only Current_Object_Path_File : Path_Name_Type := No_Path; -- Current value of project object path file env var. Used to avoid -- setting the env var to the same value. + -- gnatmake only Ada_Path_Buffer : String_Access := new String (1 .. 1024); -- A buffer where values for ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are -- stored. + -- gnatmake only Ada_Path_Length : Natural := 0; -- Index of the last valid character in Ada_Path_Buffer + -- gnatmake only Ada_Prj_Include_File_Set : Boolean := False; Ada_Prj_Objects_File_Set : Boolean := False; @@ -1596,8 +1506,10 @@ private -- effect on most platforms, except on VMS where the logical names are -- deassigned, thus avoiding the pollution of the environment of the -- caller. + -- gnatmake only Fill_Mapping_File : Boolean := True; + -- gnatmake only end record; -- Type to represent the part of a project tree which is private to the diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c797d8caef1..47b88c3338a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3979,9 +3979,17 @@ package body Sem_Res is Check_Unset_Reference (Expression (E)); -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. + -- class-wide matching is not allowed. We skip this test in a call + -- to a CPP constructor because in such case, although the function + -- profile indicates that it returns a class-wide type, the object + -- returned by the C++ constructor has a concrete type. - if (Is_Class_Wide_Type (Etype (Expression (E))) + if Is_Class_Wide_Type (Etype (Expression (E))) + and then Is_CPP_Constructor_Call (Expression (E)) + then + null; + + elsif (Is_Class_Wide_Type (Etype (Expression (E))) or else Is_Class_Wide_Type (Etype (E))) and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) then diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 04c3c3864da..07047c71b5b 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -820,6 +820,13 @@ package VMS_Data is -- -- Work quietly, only output warnings and errors. + S_Check_Time : aliased constant S := "/TIME " & + "-t"; + -- /NOTIME (D) + -- /QUIET + -- + -- Print out execution time + S_Check_Sections : aliased constant S := "/SECTIONS=" & "DEFAULT " & "-s123 " & @@ -893,6 +900,7 @@ package VMS_Data is S_Check_Mess 'Access, S_Check_Project 'Access, S_Check_Quiet 'Access, + S_Check_Time 'Access, S_Check_Sections 'Access, S_Check_Short 'Access, S_Check_Subdirs 'Access, |