Commit fadcf313 by Arnaud Charlet

[multiple changes]

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.

From-SVN: r148937
parent 5b900a45
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> 2009-06-25 Vincent Celier <celier@adacore.com>
* s-os_lib.adb (Normalize_Pathname.Get_Directory): If directory * s-os_lib.adb (Normalize_Pathname.Get_Directory): If directory
...@@ -12,6 +39,7 @@ ...@@ -12,6 +39,7 @@
2009-06-25 Quentin Ochem <ochem@adacore.com> 2009-06-25 Quentin Ochem <ochem@adacore.com>
* prj.ads (Unit_Index): Now general access type. * prj.ads (Unit_Index): Now general access type.
2009-06-25 Pascal Obry <obry@adacore.com> 2009-06-25 Pascal Obry <obry@adacore.com>
* a-stwise.adb, a-stzsea.adb: Fix confusion between 'Length and 'Last. * a-stwise.adb, a-stzsea.adb: Fix confusion between 'Length and 'Last.
......
...@@ -572,6 +572,57 @@ package body Exp_Ch4 is ...@@ -572,6 +572,57 @@ package body Exp_Ch4 is
begin begin
if Is_Tagged_Type (T) or else Needs_Finalization (T) then 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 -- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object -- to a build-in-place function, then access to the allocated object
-- must be passed to the function. Currently we limit such functions -- must be passed to the function. Currently we limit such functions
......
...@@ -662,8 +662,7 @@ procedure GNATCmd is ...@@ -662,8 +662,7 @@ procedure GNATCmd is
function Configuration_Pragmas_File return Path_Name_Type is function Configuration_Pragmas_File return Path_Name_Type is
begin begin
Prj.Env.Create_Config_Pragmas_File Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
(Project, Project, Project_Tree, Include_Config_Files => False);
return Project.Config_File_Name; return Project.Config_File_Name;
end Configuration_Pragmas_File; end Configuration_Pragmas_File;
...@@ -2122,6 +2121,8 @@ begin ...@@ -2122,6 +2121,8 @@ begin
File_Index : Integer := 0; File_Index : Integer := 0;
Dir_Index : Integer := 0; Dir_Index : Integer := 0;
Last : constant Integer := Last_Switches.Last; Last : constant Integer := Last_Switches.Last;
Lang : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
begin begin
for Index in 1 .. Last loop for Index in 1 .. Last loop
...@@ -2138,7 +2139,7 @@ begin ...@@ -2138,7 +2139,7 @@ begin
-- indicate to gnatstub the name of the body file with -- indicate to gnatstub the name of the body file with
-- a -o switch. -- 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 Prj.Default_Ada_Spec_Suffix
then then
if File_Index /= 0 then if File_Index /= 0 then
...@@ -2148,9 +2149,7 @@ begin ...@@ -2148,9 +2149,7 @@ begin
Last : Natural := Spec'Last; Last : Natural := Spec'Last;
begin begin
Get_Name_String Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
(Spec_Suffix_Id_Of
(Project_Tree, Name_Ada, Project.Naming));
if Spec'Length > Name_Len if Spec'Length > Name_Len
and then Spec (Last - Name_Len + 1 .. Last) = and then Spec (Last - Name_Len + 1 .. Last) =
...@@ -2158,8 +2157,7 @@ begin ...@@ -2158,8 +2157,7 @@ begin
then then
Last := Last - Name_Len; Last := Last - Name_Len;
Get_Name_String Get_Name_String
(Body_Suffix_Id_Of (Lang.Config.Naming_Data.Body_Suffix);
(Project_Tree, Name_Ada, Project.Naming));
Last_Switches.Increment_Last; Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) := Last_Switches.Table (Last_Switches.Last) :=
new String'("-o"); new String'("-o");
......
...@@ -644,7 +644,7 @@ package body Make is ...@@ -644,7 +644,7 @@ package body Make is
(Source_File : File_Name_Type; (Source_File : File_Name_Type;
Source_File_Name : String; Source_File_Name : String;
Source_Index : Int; Source_Index : Int;
Naming : Naming_Data; Project : Project_Id;
In_Package : Package_Id; In_Package : Package_Id;
Allow_ALI : Boolean) return Variable_Value; Allow_ALI : Boolean) return Variable_Value;
-- Return the switches for the source file in the specified package of a -- Return the switches for the source file in the specified package of a
...@@ -1274,7 +1274,7 @@ package body Make is ...@@ -1274,7 +1274,7 @@ package body Make is
(Source_File => Name_Find, (Source_File => Name_Find,
Source_File_Name => File_Name, Source_File_Name => File_Name,
Source_Index => Index, Source_Index => Index,
Naming => Main_Project.Naming, Project => Main_Project,
In_Package => The_Package, In_Package => The_Package,
Allow_ALI => Program = Binder or else Program = Linker); Allow_ALI => Program = Binder or else Program = Linker);
...@@ -2388,7 +2388,7 @@ package body Make is ...@@ -2388,7 +2388,7 @@ package body Make is
(Source_File => Source_File, (Source_File => Source_File,
Source_File_Name => Source_File_Name, Source_File_Name => Source_File_Name,
Source_Index => Source_Index, Source_Index => Source_Index,
Naming => Arguments_Project.Naming, Project => Arguments_Project,
In_Package => Compiler_Package, In_Package => Compiler_Package,
Allow_ALI => False); Allow_ALI => False);
...@@ -3750,7 +3750,7 @@ package body Make is ...@@ -3750,7 +3750,7 @@ package body Make is
begin begin
Prj.Env.Create_Config_Pragmas_File 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 if For_Project.Config_File_Name /= No_Path then
Temporary_Config_File := For_Project.Config_File_Temp; Temporary_Config_File := For_Project.Config_File_Temp;
...@@ -4235,6 +4235,8 @@ package body Make is ...@@ -4235,6 +4235,8 @@ package body Make is
File_Name : constant String := Base_Name (Main); File_Name : constant String := Base_Name (Main);
-- The simple file name of the current main -- The simple file name of the current main
Lang : Language_Ptr;
begin begin
exit when Main = ""; exit when Main = "";
...@@ -4256,18 +4258,18 @@ package body Make is ...@@ -4256,18 +4258,18 @@ package body Make is
-- is the actual path of a source of a project. -- is the actual path of a source of a project.
if Main /= File_Name then if Main /= File_Name then
Lang := Get_Language_From_Name (Main_Project, "ada");
Real_Path := Real_Path :=
Locate_Regular_File Locate_Regular_File
(Main & (Main & Get_Name_String
Body_Suffix_Of (Lang.Config.Naming_Data.Body_Suffix),
(Project_Tree, "ada", Main_Project.Naming),
""); "");
if Real_Path = null then if Real_Path = null then
Real_Path := Real_Path :=
Locate_Regular_File Locate_Regular_File
(Main & (Main & Get_Name_String
Spec_Suffix_Of (Lang.Config.Naming_Data.Spec_Suffix),
(Project_Tree, "ada", Main_Project.Naming),
""); "");
end if; end if;
...@@ -8122,10 +8124,12 @@ package body Make is ...@@ -8122,10 +8124,12 @@ package body Make is
(Source_File : File_Name_Type; (Source_File : File_Name_Type;
Source_File_Name : String; Source_File_Name : String;
Source_Index : Int; Source_Index : Int;
Naming : Naming_Data; Project : Project_Id;
In_Package : Package_Id; In_Package : Package_Id;
Allow_ALI : Boolean) return Variable_Value Allow_ALI : Boolean) return Variable_Value
is is
Lang : constant Language_Ptr := Get_Language_From_Name (Project, "ada");
Switches : Variable_Value; Switches : Variable_Value;
Defaults : constant Array_Element_Id := Defaults : constant Array_Element_Id :=
...@@ -8156,14 +8160,17 @@ package body Make is ...@@ -8156,14 +8160,17 @@ package body Make is
-- Check also without the suffix -- Check also without the suffix
if Switches = Nil_Variable_Value then if Switches = Nil_Variable_Value
and then Lang /= null
then
declare declare
Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
Name : String (1 .. Source_File_Name'Length + 3); Name : String (1 .. Source_File_Name'Length + 3);
Last : Positive := Source_File_Name'Length; Last : Positive := Source_File_Name'Length;
Spec_Suffix : constant String := Spec_Suffix : constant String :=
Spec_Suffix_Of (Project_Tree, "ada", Naming); Get_Name_String (Naming.Spec_Suffix);
Body_Suffix : constant String := Body_Suffix : constant String :=
Body_Suffix_Of (Project_Tree, "ada", Naming); Get_Name_String (Naming.Body_Suffix);
Truncated : Boolean := False; Truncated : Boolean := False;
begin begin
......
...@@ -32,8 +32,6 @@ with Tempdir; ...@@ -32,8 +32,6 @@ with Tempdir;
package body Prj.Env is package body Prj.Env is
Default_Naming : constant Naming_Id := Naming_Table.First;
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
...@@ -387,27 +385,30 @@ package body Prj.Env is ...@@ -387,27 +385,30 @@ package body Prj.Env is
procedure Create_Config_Pragmas_File procedure Create_Config_Pragmas_File
(For_Project : Project_Id; (For_Project : Project_Id;
Main_Project : Project_Id; In_Tree : Project_Tree_Ref)
In_Tree : Project_Tree_Ref;
Include_Config_Files : Boolean := True)
is is
pragma Unreferenced (Main_Project); type Naming_Id is new Nat;
pragma Unreferenced (Include_Config_Files); 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_Name : Path_Name_Type := No_Path;
File : File_Descriptor := Invalid_FD; File : File_Descriptor := Invalid_FD;
Current_Unit : Unit_Index := Units_Htable.Get_First (In_Tree.Units_HT); Current_Unit : Unit_Index := Units_Htable.Get_First (In_Tree.Units_HT);
First_Project : Project_List;
Current_Project : Project_List;
Current_Naming : Naming_Id; Current_Naming : Naming_Id;
Status : Boolean; Status : Boolean;
-- For call to Close -- 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 -- Recursive procedure that put in the config pragmas file any non
-- standard naming schemes, if it is not already in the file, then call -- standard naming schemes, if it is not already in the file, then call
-- itself for any imported project. -- itself for any imported project.
...@@ -432,7 +433,11 @@ package body Prj.Env is ...@@ -432,7 +433,11 @@ package body Prj.Env is
-- Check -- -- 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 begin
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Checking project file """); Write_Str ("Checking project file """);
...@@ -441,115 +446,85 @@ package body Prj.Env is ...@@ -441,115 +446,85 @@ package body Prj.Env is
Write_Eol; Write_Eol;
end if; end if;
-- Is this project in the list of the visited project? if Lang = null then
if Current_Verbosity = High then
Current_Project := First_Project; Write_Str ("Languages does not contain Ada, nothing to do");
while Current_Project /= null end if;
and then Current_Project.Project /= Project return;
loop end if;
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 we don't know it, add it Naming := Lang.Config.Naming_Data;
if Current_Naming > -- Is the naming scheme of this project one that we know?
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;
-- 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 Check_Temp_File;
(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
-- 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 Put_Line
(File, "pragma Source_File_Name_Project"); (File, " (Subunit_File_Name => ""*" &
Put_Line Get_Name_String (Naming.Separate_Suffix) & """,");
(File, " (Body_File_Name => ""*" &
Body_Suffix_Of (In_Tree, "ada", Project.Naming) &
""",");
Put_Line Put_Line
(File, " Casing => " & (File, " Casing => " &
Image (Project.Naming.Casing) & ","); Image (Naming.Casing) & ",");
Put_Line Put_Line
(File, " Dot_Replacement => """ & (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; 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 if;
end Check; end Check;
...@@ -660,18 +635,20 @@ package body Prj.Env is ...@@ -660,18 +635,20 @@ package body Prj.Env is
end if; end if;
end Put_Line; 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 -- Start of processing for Create_Config_Pragmas_File
begin begin
if not For_Project.Config_Checked then if not For_Project.Config_Checked then
-- Remove any memory of processed naming schemes, if any Naming_Table.Init (Namings);
Naming_Table.Set_Last (In_Tree.Private_Part.Namings, Default_Naming);
-- Check the naming schemes -- 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 -- Visit all the units and process those that need an SFN pragma
...@@ -830,23 +807,24 @@ package body Prj.Env is ...@@ -830,23 +807,24 @@ package body Prj.Env is
and then Source.Path.Name /= No_Path and then Source.Path.Name /= No_Path
and then and then
(Source.Language.Config.Kind = File_Based (Source.Language.Config.Kind = File_Based
or else Source.Unit /= No_Unit_Index) or else Source.Unit /= No_Unit_Index)
then then
if Source.Unit /= No_Unit_Index then if Source.Unit /= No_Unit_Index then
Get_Name_String (Source.Unit.Name); Get_Name_String (Source.Unit.Name);
if Get_Mode = Ada_Only then if Get_Mode = Ada_Only then
-- ??? Mapping_Spec_Suffix could be set in the case of -- ??? Mapping_Spec_Suffix could be set in the case of
-- gnatmake as well -- gnatmake as well
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := '%'; Add_Char_To_Name_Buffer ('%');
Name_Len := Name_Len + 1;
if Source.Kind = Spec then if Source.Kind = Spec then
Name_Buffer (Name_Len) := 's'; Add_Char_To_Name_Buffer ('s');
else else
Name_Buffer (Name_Len) := 'b'; Add_Char_To_Name_Buffer ('b');
end if; end if;
else else
case Source.Kind is case Source.Kind is
when Spec => when Spec =>
...@@ -997,12 +975,8 @@ package body Prj.Env is ...@@ -997,12 +975,8 @@ package body Prj.Env is
The_Project : Project_Id := Project; The_Project : Project_Id := Project;
Original_Name : String := Name; Original_Name : String := Name;
Extended_Spec_Name : String := Lang : constant Language_Ptr :=
Name & Get_Language_From_Name (Project, "ada");
Spec_Suffix_Of (In_Tree, "ada", Project.Naming);
Extended_Body_Name : String :=
Name &
Body_Suffix_Of (In_Tree, "ada", Project.Naming);
Unit : Unit_Index; Unit : Unit_Index;
The_Original_Name : Name_Id; The_Original_Name : Name_Id;
...@@ -1010,20 +984,38 @@ package body Prj.Env is ...@@ -1010,20 +984,38 @@ package body Prj.Env is
The_Body_Name : Name_Id; The_Body_Name : Name_Id;
begin begin
-- ??? Same block in Project_Od
Canonical_Case_File_Name (Original_Name); Canonical_Case_File_Name (Original_Name);
Name_Len := Original_Name'Length; Name_Len := Original_Name'Length;
Name_Buffer (1 .. Name_Len) := Original_Name; Name_Buffer (1 .. Name_Len) := Original_Name;
The_Original_Name := Name_Find; The_Original_Name := Name_Find;
Canonical_Case_File_Name (Extended_Spec_Name); if Lang /= null then
Name_Len := Extended_Spec_Name'Length; declare
Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
The_Spec_Name := Name_Find; 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); else
Name_Len := Extended_Body_Name'Length; Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Body_Name; Name_Buffer (1 .. Name_Len) := Name;
The_Body_Name := Name_Find; Canonical_Case_File_Name (Name_Buffer);
The_Spec_Name := Name_Find;
The_Body_Name := The_Spec_Name;
end if;
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Looking for file name of """); Write_Str ("Looking for file name of """);
...@@ -1031,11 +1023,11 @@ package body Prj.Env is ...@@ -1031,11 +1023,11 @@ package body Prj.Env is
Write_Char ('"'); Write_Char ('"');
Write_Eol; Write_Eol;
Write_Str (" Extended Spec Name = """); Write_Str (" Extended Spec Name = """);
Write_Str (Extended_Spec_Name); Write_Str (Get_Name_String (The_Spec_Name));
Write_Char ('"'); Write_Char ('"');
Write_Eol; Write_Eol;
Write_Str (" Extended Body Name = """); Write_Str (" Extended Body Name = """);
Write_Str (Extended_Body_Name); Write_Str (Get_Name_String (The_Body_Name));
Write_Char ('"'); Write_Char ('"');
Write_Eol; Write_Eol;
end if; end if;
...@@ -1103,7 +1095,7 @@ package body Prj.Env is ...@@ -1103,7 +1095,7 @@ package body Prj.Env is
(Unit.File_Names (Impl).Path.Name); (Unit.File_Names (Impl).Path.Name);
else else
return Extended_Body_Name; return Get_Name_String (The_Body_Name);
end if; end if;
else else
...@@ -1167,7 +1159,7 @@ package body Prj.Env is ...@@ -1167,7 +1159,7 @@ package body Prj.Env is
return Get_Name_String return Get_Name_String
(Unit.File_Names (Spec).Path.Name); (Unit.File_Names (Spec).Path.Name);
else else
return Extended_Spec_Name; return Get_Name_String (The_Spec_Name);
end if; end if;
else else
...@@ -1442,10 +1434,8 @@ package body Prj.Env is ...@@ -1442,10 +1434,8 @@ package body Prj.Env is
Original_Name : String := Name; Original_Name : String := Name;
Extended_Spec_Name : String := Lang : constant Language_Ptr :=
Name & Spec_Suffix_Of (In_Tree, "ada", Main_Project.Naming); Get_Language_From_Name (Main_Project, "ada");
Extended_Body_Name : String :=
Name & Body_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
Unit : Unit_Index; Unit : Unit_Index;
...@@ -1455,20 +1445,34 @@ package body Prj.Env is ...@@ -1455,20 +1445,34 @@ package body Prj.Env is
The_Body_Name : File_Name_Type; The_Body_Name : File_Name_Type;
begin begin
-- ??? Same block in File_Name_Of_Library_Unit_Body
Canonical_Case_File_Name (Original_Name); Canonical_Case_File_Name (Original_Name);
Name_Len := Original_Name'Length; Name_Len := Original_Name'Length;
Name_Buffer (1 .. Name_Len) := Original_Name; Name_Buffer (1 .. Name_Len) := Original_Name;
The_Original_Name := Name_Find; The_Original_Name := Name_Find;
Canonical_Case_File_Name (Extended_Spec_Name); if Lang /= null then
Name_Len := Extended_Spec_Name'Length; declare
Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
The_Spec_Name := Name_Find; Extended_Spec_Name : String :=
Name & Namet.Get_Name_String (Naming.Spec_Suffix);
Canonical_Case_File_Name (Extended_Body_Name); Extended_Body_Name : String :=
Name_Len := Extended_Body_Name'Length; Name & Namet.Get_Name_String (Naming.Body_Suffix);
Name_Buffer (1 .. Name_Len) := Extended_Body_Name; begin
The_Body_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;
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); Unit := Units_Htable.Get_First (In_Tree.Units_HT);
......
...@@ -63,16 +63,9 @@ package Prj.Env is ...@@ -63,16 +63,9 @@ package Prj.Env is
procedure Create_Config_Pragmas_File procedure Create_Config_Pragmas_File
(For_Project : Project_Id; (For_Project : Project_Id;
Main_Project : Project_Id; In_Tree : Project_Tree_Ref);
In_Tree : Project_Tree_Ref;
Include_Config_Files : Boolean := True);
-- If there needs to have SFN pragmas, either for non standard naming -- If there needs to have SFN pragmas, either for non standard naming
-- schemes or for individual units, or (when Include_Config_Files is True) -- schemes or for individual units.
-- 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.
procedure Create_New_Path_File procedure Create_New_Path_File
(In_Tree : Project_Tree_Ref; (In_Tree : Project_Tree_Ref;
......
...@@ -273,13 +273,14 @@ package body Prj.Nmsc is ...@@ -273,13 +273,14 @@ package body Prj.Nmsc is
procedure Check_Ada_Name (Name : String; Unit : out Name_Id); procedure Check_Ada_Name (Name : String; Unit : out Name_Id);
-- Check that a name is a valid Ada unit name -- Check that a name is a valid Ada unit name
procedure Check_Naming_Schemes procedure Check_Package_Naming
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Is_Config_File : Boolean; Is_Config_File : Boolean;
Bodies : out Array_Element_Id; Bodies : out Array_Element_Id;
Specs : 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) -- Is_Config_File should be True if Project is a config file (.cgpr)
-- This also returns the naming scheme exceptions for unit-based -- This also returns the naming scheme exceptions for unit-based
-- languages (Bodies and Specs are associative arrays mapping individual -- languages (Bodies and Specs are associative arrays mapping individual
...@@ -314,12 +315,6 @@ package body Prj.Nmsc is ...@@ -314,12 +315,6 @@ package body Prj.Nmsc is
-- Current_Dir should represent the current directory, and is passed for -- Current_Dir should represent the current directory, and is passed for
-- efficiency to avoid system calls to recompute it. -- 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 procedure Check_Programming_Languages
(In_Tree : Project_Tree_Ref; (In_Tree : Project_Tree_Ref;
Project : Project_Id); Project : Project_Id);
...@@ -482,11 +477,7 @@ package body Prj.Nmsc is ...@@ -482,11 +477,7 @@ package body Prj.Nmsc is
procedure Compute_Unit_Name procedure Compute_Unit_Name
(File_Name : File_Name_Type; (File_Name : File_Name_Type;
Dot_Replacement : File_Name_Type; Naming : Lang_Naming_Data;
Separate_Suffix : File_Name_Type;
Body_Suffix : File_Name_Type;
Spec_Suffix : File_Name_Type;
Casing : Casing_Type;
Kind : out Source_Kind; Kind : out Source_Kind;
Unit : out Name_Id; Unit : out Name_Id;
In_Tree : Project_Tree_Ref); In_Tree : Project_Tree_Ref);
...@@ -497,7 +488,7 @@ package body Prj.Nmsc is ...@@ -497,7 +488,7 @@ package body Prj.Nmsc is
procedure Get_Unit procedure Get_Unit
(In_Tree : Project_Tree_Ref; (In_Tree : Project_Tree_Ref;
Canonical_File_Name : File_Name_Type; Canonical_File_Name : File_Name_Type;
Naming : Naming_Data; Project : Project_Id;
Exception_Id : out Ada_Naming_Exception_Id; Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id; Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body); Unit_Kind : out Spec_Or_Body);
...@@ -910,11 +901,9 @@ package body Prj.Nmsc is ...@@ -910,11 +901,9 @@ package body Prj.Nmsc is
Show_Source_Dirs (Project, In_Tree); Show_Source_Dirs (Project, In_Tree);
end if; end if;
Check_Package_Naming (Project, In_Tree);
Extending := Project.Extends /= No_Project; 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 if Get_Mode = Ada_Only then
Prepare_Ada_Naming_Exceptions (Bodies, In_Tree, Impl); Prepare_Ada_Naming_Exceptions (Bodies, In_Tree, Impl);
...@@ -2409,7 +2398,7 @@ package body Prj.Nmsc is ...@@ -2409,7 +2398,7 @@ package body Prj.Nmsc is
Lang_Index := Project.Languages; Lang_Index := Project.Languages;
while Lang_Index /= No_Language_Index loop while Lang_Index /= No_Language_Index loop
-- For all languages, Compiler_Driver needs to be specified. This is -- 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) -- instance)
if Compiler_Driver_Mandatory if Compiler_Driver_Mandatory
...@@ -2698,10 +2687,10 @@ package body Prj.Nmsc is ...@@ -2698,10 +2687,10 @@ package body Prj.Nmsc is
end Check_And_Normalize_Unit_Names; end Check_And_Normalize_Unit_Names;
-------------------------- --------------------------
-- Check_Naming_Schemes -- -- Check_Package_Naming --
-------------------------- --------------------------
procedure Check_Naming_Schemes procedure Check_Package_Naming
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Is_Config_File : Boolean; Is_Config_File : Boolean;
...@@ -2712,6 +2701,9 @@ package body Prj.Nmsc is ...@@ -2712,6 +2701,9 @@ package body Prj.Nmsc is
Util.Value_Of (Name_Naming, Project.Decl.Packages, In_Tree); Util.Value_Of (Name_Naming, Project.Decl.Packages, In_Tree);
Naming : Package_Element; Naming : Package_Element;
Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
Ada_Spec_Suffix_Loc : Source_Ptr := No_Location;
procedure Check_Naming_Ada_Only; procedure Check_Naming_Ada_Only;
-- Does Check_Naming_Schemes processing in Ada_Only mode. -- Does Check_Naming_Schemes processing in Ada_Only mode.
-- If there is a package Naming, puts in Data.Naming the contents of -- If there is a package Naming, puts in Data.Naming the contents of
...@@ -2737,6 +2729,9 @@ package body Prj.Nmsc is ...@@ -2737,6 +2729,9 @@ package body Prj.Nmsc is
-- In Multi_Lang mode, process the naming exceptions for the two types -- In Multi_Lang mode, process the naming exceptions for the two types
-- of languages we can have. -- of languages we can have.
procedure Initialize_Naming_Data;
-- Initialize internal naming data for the various languages
------------------ ------------------
-- Check_Common -- -- Check_Common --
------------------ ------------------
...@@ -3122,129 +3117,98 @@ package body Prj.Nmsc is ...@@ -3122,129 +3117,98 @@ package body Prj.Nmsc is
--------------------------- ---------------------------
procedure Check_Naming_Ada_Only is procedure Check_Naming_Ada_Only is
Ada : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
Casing_Defined : Boolean; Casing_Defined : Boolean;
Spec_Suffix : File_Name_Type;
Body_Suffix : File_Name_Type;
Sep_Suffix_Loc : Source_Ptr; 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 begin
-- The default value of separate suffix should be the same as the if Ada = null then
-- body suffix, so we need to compute that first. -- No language, thus nothing to do
return;
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);
end if; 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 -- We'll need the dot replacement below, so compute it now
(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);
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 Bodies := Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree);
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 Bodies /= No_Array_Element then
Check_And_Normalize_Unit_Names
(Project, In_Tree, Bodies, "Naming.Bodies");
end if;
if Specs /= No_Array_Element then Specs := Util.Value_Of (Name_Spec, Naming.Decl.Arrays, In_Tree);
Check_And_Normalize_Unit_Names
(Project, In_Tree, Specs, "Naming.Specs");
end if;
-- 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 -- Check Spec_Suffix
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);
if Is_Illegal_Suffix if Is_Illegal_Suffix (Data.Spec_Suffix, Data.Dot_Replacement) then
(Spec_Suffix, Project.Naming.Dot_Replacement) Err_Vars.Error_Msg_File_1 := Data.Spec_Suffix;
then
Err_Vars.Error_Msg_File_1 := Spec_Suffix;
Error_Msg Error_Msg
(Project, In_Tree, (Project, In_Tree,
"{ is illegal for Spec_Suffix", "{ is illegal for Spec_Suffix",
Ada_Spec_Suffix.Location); Ada_Spec_Suffix_Loc);
end if; end if;
else Write_Attr ("Spec_Suffix", Get_Name_String (Data.Spec_Suffix));
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));
-- Check Body_Suffix -- Check Body_Suffix
if Is_Illegal_Suffix if Is_Illegal_Suffix (Data.Body_Suffix, Data.Dot_Replacement) then
(Body_Suffix, Project.Naming.Dot_Replacement) Err_Vars.Error_Msg_File_1 := Data.Body_Suffix;
then Error_Msg
Err_Vars.Error_Msg_File_1 := Body_Suffix; (Project, In_Tree,
Error_Msg "{ is illegal for Body_Suffix",
(Project, In_Tree, Ada_Body_Suffix_Loc);
"{ is illegal for Body_Suffix", end if;
Ada_Body_Suffix.Location);
end if;
-- Spec_Suffix cannot be equal to Body_Suffix or Separate_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 -- since that would cause a clear ambiguity. Note that we do allow
-- Spec_Suffix to have the same termination as one of these, which -- a Spec_Suffix to have the same termination as one of these,
-- causes a potential ambiguity, but we resolve that my matching the -- which causes a potential ambiguity, but we resolve that my
-- longest possible suffix. -- matching the longest possible suffix.
if Spec_Suffix = Body_Suffix then if Data.Spec_Suffix = Data.Body_Suffix then
Error_Msg Error_Msg
(Project, In_Tree, (Project, In_Tree,
"Body_Suffix (""" & "Body_Suffix (""" &
Get_Name_String (Body_Suffix) & Get_Name_String (Data.Body_Suffix) &
""") cannot be the same as Spec_Suffix.", """) cannot be the same as Spec_Suffix.",
Ada_Body_Suffix.Location); Ada_Body_Suffix_Loc);
end if; end if;
if Body_Suffix /= Project.Naming.Separate_Suffix if Data.Body_Suffix /= Data.Separate_Suffix
and then Spec_Suffix = Project.Naming.Separate_Suffix and then Data.Spec_Suffix = Data.Separate_Suffix
then then
Error_Msg Error_Msg
(Project, In_Tree, (Project, In_Tree,
"Separate_Suffix (""" & "Separate_Suffix (""" &
Get_Name_String (Project.Naming.Separate_Suffix) & Get_Name_String (Data.Separate_Suffix) &
""") cannot be the same as Spec_Suffix.", """) cannot be the same as Spec_Suffix.",
Sep_Suffix_Loc); Sep_Suffix_Loc);
end if; end if;
end;
end Check_Naming_Ada_Only; end Check_Naming_Ada_Only;
----------------------------- -----------------------------
...@@ -3375,10 +3339,92 @@ package body Prj.Nmsc is ...@@ -3375,10 +3339,92 @@ package body Prj.Nmsc is
end loop; end loop;
end Check_Naming_Multi_Lang; 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 -- Start of processing for Check_Naming_Schemes
begin begin
Specs := No_Array_Element; Specs := No_Array_Element;
Bodies := No_Array_Element; Bodies := No_Array_Element;
-- No Naming package or parsing a configuration file? nothing to do -- No Naming package or parsing a configuration file? nothing to do
...@@ -3387,9 +3433,12 @@ package body Prj.Nmsc is ...@@ -3387,9 +3433,12 @@ package body Prj.Nmsc is
Naming := In_Tree.Packages.Table (Naming_Id); Naming := In_Tree.Packages.Table (Naming_Id);
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Line ("Checking package Naming."); Write_Line ("Checking package Naming for project "
& Get_Name_String (Project.Name));
end if; end if;
Initialize_Naming_Data;
case Get_Mode is case Get_Mode is
when Ada_Only => when Ada_Only =>
Check_Naming_Ada_Only; Check_Naming_Ada_Only;
...@@ -3397,7 +3446,7 @@ package body Prj.Nmsc is ...@@ -3397,7 +3446,7 @@ package body Prj.Nmsc is
Check_Naming_Multi_Lang; Check_Naming_Multi_Lang;
end case; end case;
end if; end if;
end Check_Naming_Schemes; end Check_Package_Naming;
------------------------------ ------------------------------
-- Check_Library_Attributes -- -- Check_Library_Attributes --
...@@ -4091,154 +4140,6 @@ package body Prj.Nmsc is ...@@ -4091,154 +4140,6 @@ package body Prj.Nmsc is
end if; end if;
end Check_Library_Attributes; 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 -- -- Check_Programming_Languages --
--------------------------------- ---------------------------------
...@@ -4251,8 +4152,53 @@ package body Prj.Nmsc is ...@@ -4251,8 +4152,53 @@ package body Prj.Nmsc is
Def_Lang : Variable_Value := Nil_Variable_Value; Def_Lang : Variable_Value := Nil_Variable_Value;
Def_Lang_Id : Name_Id; 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 begin
Project.Languages := No_Language_Index; Project.Languages := null;
Languages := Languages :=
Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, In_Tree); Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, In_Tree);
Def_Lang := Def_Lang :=
...@@ -4296,27 +4242,17 @@ package body Prj.Nmsc is ...@@ -4296,27 +4242,17 @@ package body Prj.Nmsc is
end if; end if;
if Def_Lang_Id /= No_Name then 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); Get_Name_String (Def_Lang_Id);
Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1)); Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
Project.Languages.Display_Name := Name_Find; Add_Language
(Name => Def_Lang_Id,
if Def_Lang_Id = Name_Ada then Display_Name => Name_Find);
Project.Languages.Config.Kind := Unit_Based;
Project.Languages.Config.Dependency_Kind := ALI_File;
else
Project.Languages.Config.Kind := File_Based;
end if;
end if; end if;
else else
declare declare
Current : String_List_Id := Languages.Values; Current : String_List_Id := Languages.Values;
Element : String_Element; Element : String_Element;
Lang_Name : Name_Id;
Index : Language_Ptr;
NL_Id : Language_Ptr;
begin begin
-- If there are no languages declared, there are no sources -- If there are no languages declared, there are no sources
...@@ -4340,34 +4276,10 @@ package body Prj.Nmsc is ...@@ -4340,34 +4276,10 @@ package body Prj.Nmsc is
Element := In_Tree.String_Elements.Table (Current); Element := In_Tree.String_Elements.Table (Current);
Get_Name_String (Element.Value); Get_Name_String (Element.Value);
To_Lower (Name_Buffer (1 .. Name_Len)); To_Lower (Name_Buffer (1 .. Name_Len));
Lang_Name := Name_Find;
-- If the language was not already specified (duplicates Add_Language
-- are simply ignored). (Name => Name_Find,
Display_Name => Element.Value);
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;
Current := Element.Next; Current := Element.Next;
end loop; end loop;
...@@ -6115,11 +6027,7 @@ package body Prj.Nmsc is ...@@ -6115,11 +6027,7 @@ package body Prj.Nmsc is
procedure Compute_Unit_Name procedure Compute_Unit_Name
(File_Name : File_Name_Type; (File_Name : File_Name_Type;
Dot_Replacement : File_Name_Type; Naming : Lang_Naming_Data;
Separate_Suffix : File_Name_Type;
Body_Suffix : File_Name_Type;
Spec_Suffix : File_Name_Type;
Casing : Casing_Type;
Kind : out Source_Kind; Kind : out Source_Kind;
Unit : out Name_Id; Unit : out Name_Id;
In_Tree : Project_Tree_Ref) In_Tree : Project_Tree_Ref)
...@@ -6127,16 +6035,16 @@ package body Prj.Nmsc is ...@@ -6127,16 +6035,16 @@ package body Prj.Nmsc is
Filename : constant String := Get_Name_String (File_Name); Filename : constant String := Get_Name_String (File_Name);
Last : Integer := Filename'Last; Last : Integer := Filename'Last;
Sep_Len : constant Integer := Sep_Len : constant Integer :=
Integer (Length_Of_Name (Separate_Suffix)); Integer (Length_Of_Name (Naming.Separate_Suffix));
Body_Len : constant Integer := Body_Len : constant Integer :=
Integer (Length_Of_Name (Body_Suffix)); Integer (Length_Of_Name (Naming.Body_Suffix));
Spec_Len : constant Integer := Spec_Len : constant Integer :=
Integer (Length_Of_Name (Spec_Suffix)); Integer (Length_Of_Name (Naming.Spec_Suffix));
Standard_GNAT : constant Boolean := Standard_GNAT : constant Boolean :=
Spec_Suffix = Default_Ada_Spec_Suffix Naming.Spec_Suffix = Default_Ada_Spec_Suffix
and then and then
Body_Suffix = Default_Ada_Body_Suffix; Naming.Body_Suffix = Default_Ada_Body_Suffix;
Unit_Except : Unit_Exception; Unit_Except : Unit_Exception;
Masked : Boolean := False; Masked : Boolean := False;
...@@ -6144,7 +6052,7 @@ package body Prj.Nmsc is ...@@ -6144,7 +6052,7 @@ package body Prj.Nmsc is
Unit := No_Name; Unit := No_Name;
Kind := Spec; Kind := Spec;
if Dot_Replacement = No_File then if Naming.Dot_Replacement = No_File then
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Line (" No dot_replacement specified"); Write_Line (" No dot_replacement specified");
end if; end if;
...@@ -6154,22 +6062,22 @@ package body Prj.Nmsc is ...@@ -6154,22 +6062,22 @@ package body Prj.Nmsc is
-- Choose the longest suffix that matches. If there are several matches, -- Choose the longest suffix that matches. If there are several matches,
-- give priority to specs, then bodies, then separates. -- give priority to specs, then bodies, then separates.
if Separate_Suffix /= Body_Suffix if Naming.Separate_Suffix /= Naming.Body_Suffix
and then Suffix_Matches (Filename, Separate_Suffix) and then Suffix_Matches (Filename, Naming.Separate_Suffix)
then then
Last := Filename'Last - Sep_Len; Last := Filename'Last - Sep_Len;
Kind := Sep; Kind := Sep;
end if; end if;
if Filename'Last - Body_Len <= Last if Filename'Last - Body_Len <= Last
and then Suffix_Matches (Filename, Body_Suffix) and then Suffix_Matches (Filename, Naming.Body_Suffix)
then then
Last := Natural'Min (Last, Filename'Last - Body_Len); Last := Natural'Min (Last, Filename'Last - Body_Len);
Kind := Impl; Kind := Impl;
end if; end if;
if Filename'Last - Spec_Len <= Last if Filename'Last - Spec_Len <= Last
and then Suffix_Matches (Filename, Spec_Suffix) and then Suffix_Matches (Filename, Naming.Spec_Suffix)
then then
Last := Natural'Min (Last, Filename'Last - Spec_Len); Last := Natural'Min (Last, Filename'Last - Spec_Len);
Kind := Spec; Kind := Spec;
...@@ -6185,7 +6093,7 @@ package body Prj.Nmsc is ...@@ -6185,7 +6093,7 @@ package body Prj.Nmsc is
-- Check that the casing matches -- Check that the casing matches
if File_Names_Case_Sensitive then if File_Names_Case_Sensitive then
case Casing is case Naming.Casing is
when All_Lower_Case => when All_Lower_Case =>
for J in Filename'First .. Last loop for J in Filename'First .. Last loop
if Is_Letter (Filename (J)) if Is_Letter (Filename (J))
...@@ -6219,7 +6127,8 @@ package body Prj.Nmsc is ...@@ -6219,7 +6127,8 @@ package body Prj.Nmsc is
-- be any dot in the name. -- be any dot in the name.
declare declare
Dot_Repl : constant String := Get_Name_String (Dot_Replacement); Dot_Repl : constant String :=
Get_Name_String (Naming.Dot_Replacement);
begin begin
if Dot_Repl /= "." then if Dot_Repl /= "." then
...@@ -6345,7 +6254,7 @@ package body Prj.Nmsc is ...@@ -6345,7 +6254,7 @@ package body Prj.Nmsc is
procedure Get_Unit procedure Get_Unit
(In_Tree : Project_Tree_Ref; (In_Tree : Project_Tree_Ref;
Canonical_File_Name : File_Name_Type; Canonical_File_Name : File_Name_Type;
Naming : Naming_Data; Project : Project_Id;
Exception_Id : out Ada_Naming_Exception_Id; Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id; Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body) Unit_Kind : out Spec_Or_Body)
...@@ -6354,6 +6263,7 @@ package body Prj.Nmsc is ...@@ -6354,6 +6263,7 @@ package body Prj.Nmsc is
Ada_Naming_Exceptions.Get (Canonical_File_Name); Ada_Naming_Exceptions.Get (Canonical_File_Name);
VMS_Name : File_Name_Type; VMS_Name : File_Name_Type;
Kind : Source_Kind; Kind : Source_Kind;
Lang : Language_Ptr;
begin begin
if Info_Id = No_Ada_Naming_Exception if Info_Id = No_Ada_Naming_Exception
...@@ -6377,21 +6287,24 @@ package body Prj.Nmsc is ...@@ -6377,21 +6287,24 @@ package body Prj.Nmsc is
else else
Exception_Id := No_Ada_Naming_Exception; Exception_Id := No_Ada_Naming_Exception;
Compute_Unit_Name Lang := Get_Language_From_Name (Project, "ada");
(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);
case Kind is if Lang = null then
when Spec => Unit_Kind := Spec; Unit_Name := No_Name;
when Impl | Sep => Unit_Kind := Impl; Unit_Kind := Spec;
end case; 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 if;
end Get_Unit; end Get_Unit;
...@@ -7286,11 +7199,7 @@ package body Prj.Nmsc is ...@@ -7286,11 +7199,7 @@ package body Prj.Nmsc is
if not Header_File then if not Header_File then
Compute_Unit_Name Compute_Unit_Name
(File_Name => File_Name, (File_Name => File_Name,
Dot_Replacement => Config.Naming_Data.Dot_Replacement, Naming => Config.Naming_Data,
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,
Kind => Kind, Kind => Kind,
Unit => Unit, Unit => Unit,
In_Tree => In_Tree); In_Tree => In_Tree);
...@@ -8219,7 +8128,7 @@ package body Prj.Nmsc is ...@@ -8219,7 +8128,7 @@ package body Prj.Nmsc is
Get_Unit Get_Unit
(In_Tree => In_Tree, (In_Tree => In_Tree,
Canonical_File_Name => Canonical_File, Canonical_File_Name => Canonical_File,
Naming => Project.Naming, Project => Project,
Exception_Id => Exception_Id, Exception_Id => Exception_Id,
Unit_Name => Unit_Name, Unit_Name => Unit_Name,
Unit_Kind => Unit_Kind); Unit_Kind => Unit_Kind);
......
...@@ -2336,6 +2336,7 @@ package body Prj.Proc is ...@@ -2336,6 +2336,7 @@ package body Prj.Proc is
begin begin
Error_Report := Report_Error; Error_Report := Report_Error;
Success := True; Success := True;
if Project /= No_Project then if Project /= No_Project then
...@@ -2581,7 +2582,7 @@ package body Prj.Proc is ...@@ -2581,7 +2582,7 @@ package body Prj.Proc is
return; return;
end if; end if;
Project := new Project_Data'(Empty_Project (In_Tree)); Project := new Project_Data'(Empty_Project);
In_Tree.Projects := new Project_List_Element' In_Tree.Projects := new Project_List_Element'
(Project => Project, (Project => Project,
Next => In_Tree.Projects); Next => In_Tree.Projects);
......
...@@ -134,7 +134,7 @@ package body Prj.Util is ...@@ -134,7 +134,7 @@ package body Prj.Util is
Executable_Suffix_Name : Name_Id := No_Name; Executable_Suffix_Name : Name_Id := No_Name;
Naming : constant Naming_Data := Project.Naming; Lang : Language_Ptr;
Spec_Suffix : Name_Id := No_Name; Spec_Suffix : Name_Id := No_Name;
Body_Suffix : Name_Id := No_Name; Body_Suffix : Name_Id := No_Name;
...@@ -143,8 +143,8 @@ package body Prj.Util is ...@@ -143,8 +143,8 @@ package body Prj.Util is
Body_Suffix_Length : Natural := 0; Body_Suffix_Length : Natural := 0;
procedure Get_Suffixes procedure Get_Suffixes
(B_Suffix : String; (B_Suffix : File_Name_Type;
S_Suffix : String); S_Suffix : File_Name_Type);
-- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
------------------ ------------------
...@@ -152,22 +152,18 @@ package body Prj.Util is ...@@ -152,22 +152,18 @@ package body Prj.Util is
------------------ ------------------
procedure Get_Suffixes procedure Get_Suffixes
(B_Suffix : String; (B_Suffix : File_Name_Type;
S_Suffix : String) S_Suffix : File_Name_Type)
is is
begin begin
if B_Suffix'Length > 0 then if B_Suffix /= No_File then
Name_Len := B_Suffix'Length; Body_Suffix := Name_Id (B_Suffix);
Name_Buffer (1 .. Name_Len) := B_Suffix; Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
Body_Suffix := Name_Find;
Body_Suffix_Length := B_Suffix'Length;
end if; end if;
if S_Suffix'Length > 0 then if S_Suffix /= No_File then
Name_Len := S_Suffix'Length; Spec_Suffix := Name_Id (S_Suffix);
Name_Buffer (1 .. Name_Len) := S_Suffix; Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
Spec_Suffix := Name_Find;
Spec_Suffix_Length := S_Suffix'Length;
end if; end if;
end Get_Suffixes; end Get_Suffixes;
...@@ -175,14 +171,15 @@ package body Prj.Util is ...@@ -175,14 +171,15 @@ package body Prj.Util is
begin begin
if Ada_Main then if Ada_Main then
Get_Suffixes Lang := Get_Language_From_Name (Project, "ada");
(B_Suffix => Body_Suffix_Of (In_Tree, "ada", Naming),
S_Suffix => Spec_Suffix_Of (In_Tree, "ada", Naming));
elsif Language /= "" then elsif Language /= "" then
Lang := Get_Language_From_Name (Project, Language);
end if;
if Lang /= null then
Get_Suffixes Get_Suffixes
(B_Suffix => Body_Suffix_Of (In_Tree, Language, Naming), (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
S_Suffix => Spec_Suffix_Of (In_Tree, Language, Naming)); S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
end if; end if;
if Builder_Package /= No_Package then if Builder_Package /= No_Package then
...@@ -217,7 +214,8 @@ package body Prj.Util is ...@@ -217,7 +214,8 @@ package body Prj.Util is
Truncated : Boolean := False; Truncated : Boolean := False;
begin 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) = and then Name (Last - Body_Suffix_Length + 1 .. Last) =
Get_Name_String (Body_Suffix) Get_Name_String (Body_Suffix)
then then
...@@ -225,7 +223,8 @@ package body Prj.Util is ...@@ -225,7 +223,8 @@ package body Prj.Util is
Last := Last - Body_Suffix_Length; Last := Last - Body_Suffix_Length;
end if; end if;
if not Truncated if Spec_Suffix /= No_Name
and then not Truncated
and then Last > Spec_Suffix_Length and then Last > Spec_Suffix_Length
and then Name (Last - Spec_Suffix_Length + 1 .. Last) = and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
Get_Name_String (Spec_Suffix) Get_Name_String (Spec_Suffix)
......
...@@ -64,17 +64,6 @@ package body Prj is ...@@ -64,17 +64,6 @@ package body Prj is
Initialized : Boolean := False; 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 := Project_Empty : constant Project_Data :=
(Qualifier => Unspecified, (Qualifier => Unspecified,
Externally_Built => False, Externally_Built => False,
...@@ -108,8 +97,7 @@ package body Prj is ...@@ -108,8 +97,7 @@ package body Prj is
Exec_Directory => No_Path_Information, Exec_Directory => No_Path_Information,
Extends => No_Project, Extends => No_Project,
Extended_By => No_Project, Extended_By => No_Project,
Naming => Std_Naming_Data, Languages => No_Language_Index,
Languages => No_Language_Index,
Decl => No_Declarations, Decl => No_Declarations,
Imported_Projects => null, Imported_Projects => null,
All_Imported_Projects => null, All_Imported_Projects => null,
...@@ -187,67 +175,6 @@ package body Prj is ...@@ -187,67 +175,6 @@ package body Prj is
Last := Last + S'Length; Last := Last + S'Length;
end Add_To_Buffer; 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 -- -- Default_Ada_Body_Suffix --
----------------------------- -----------------------------
...@@ -322,15 +249,10 @@ package body Prj is ...@@ -322,15 +249,10 @@ package body Prj is
-- Empty_Project -- -- Empty_Project --
------------------- -------------------
function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is function Empty_Project return Project_Data is
Value : Project_Data;
begin begin
Prj.Initialize (Tree => No_Project_Tree); Prj.Initialize (Tree => No_Project_Tree);
Value := Project_Empty; return Project_Empty;
Value.Naming := Tree.Private_Part.Default_Naming;
return Value;
end Empty_Project; end Empty_Project;
------------------ ------------------
...@@ -690,110 +612,6 @@ package body Prj is ...@@ -690,110 +612,6 @@ package body Prj is
Temp_Files.Table (Temp_Files.Last) := Path; Temp_Files.Table (Temp_Files.Last) := Path;
end Record_Temp_File; 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 -- -- Free --
---------- ----------
...@@ -955,7 +773,6 @@ package body Prj is ...@@ -955,7 +773,6 @@ package body Prj is
-- Private part -- Private part
Naming_Table.Free (Tree.Private_Part.Namings);
Path_File_Table.Free (Tree.Private_Part.Path_Files); Path_File_Table.Free (Tree.Private_Part.Path_Files);
Source_Path_Table.Free (Tree.Private_Part.Source_Paths); Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
Object_Path_Table.Free (Tree.Private_Part.Object_Paths); Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
...@@ -992,24 +809,11 @@ package body Prj is ...@@ -992,24 +809,11 @@ package body Prj is
-- Private part table -- 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); Path_File_Table.Init (Tree.Private_Part.Path_Files);
Source_Path_Table.Init (Tree.Private_Part.Source_Paths); Source_Path_Table.Init (Tree.Private_Part.Source_Paths);
Object_Path_Table.Init (Tree.Private_Part.Object_Paths); Object_Path_Table.Init (Tree.Private_Part.Object_Paths);
Tree.Private_Part.Default_Naming := Std_Naming_Data;
if Current_Mode = Ada_Only then 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_Source_Path_File := No_Path;
Tree.Private_Part.Current_Object_Path_File := No_Path; Tree.Private_Part.Current_Object_Path_File := No_Path;
Tree.Private_Part.Ada_Path_Length := 0; Tree.Private_Part.Ada_Path_Length := 0;
...@@ -1019,57 +823,6 @@ package body Prj is ...@@ -1019,57 +823,6 @@ package body Prj is
end if; end if;
end Reset; 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 -- -- Set_Mode --
-------------- --------------
...@@ -1088,120 +841,6 @@ package body Prj is ...@@ -1088,120 +841,6 @@ package body Prj is
end case; end case;
end Set_Mode; 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 -- -- Switches_Name --
------------------- -------------------
......
...@@ -830,61 +830,6 @@ package Prj is ...@@ -830,61 +830,6 @@ package Prj is
-- The following record contains data for a naming scheme -- 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 function Get_Object_Directory
(Project : Project_Id; (Project : Project_Id;
Including_Libraries : Boolean; Including_Libraries : Boolean;
...@@ -906,18 +851,6 @@ package Prj is ...@@ -906,18 +851,6 @@ package Prj is
-- Returns the ultimate extending project of project Proj. If project Proj -- Returns the ultimate extending project of project Proj. If project Proj
-- is not extended, returns 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_Element;
type Project_List is access all Project_List_Element; type Project_List is access all Project_List_Element;
type Project_List_Element is record type Project_List_Element is record
...@@ -1121,9 +1054,6 @@ package Prj is ...@@ -1121,9 +1054,6 @@ package Prj is
Location : Source_Ptr := No_Location; Location : Source_Ptr := No_Location;
-- The location in the project file source of the reserved word project -- 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 -- -- Languages --
--------------- ---------------
...@@ -1305,9 +1235,9 @@ package Prj is ...@@ -1305,9 +1235,9 @@ package Prj is
end record; end record;
function Empty_Project (Tree : Project_Tree_Ref) return Project_Data; function Empty_Project return Project_Data;
-- Return the representation of an empty project in project Tree tree. -- Return the representation of an empty project.
-- The project tree Tree must have been Initialized and/or Reset. -- In Ada-only mode, the Ada language is also partly initialized
function Is_Extending function Is_Extending
(Extending : Project_Id; (Extending : Project_Id;
...@@ -1410,18 +1340,6 @@ package Prj is ...@@ -1410,18 +1340,6 @@ package Prj is
-- This procedure resets all the tables that are used when processing a -- This procedure resets all the tables that are used when processing a
-- project file tree. Initialize must be called before the call to Reset. -- 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 package Project_Boolean_Htable is new Simple_HTable
(Header_Num => Header_Num, (Header_Num => Header_Num,
Element => Boolean, Element => Boolean,
...@@ -1531,16 +1449,6 @@ private ...@@ -1531,16 +1449,6 @@ private
Last : in out Natural); Last : in out Natural);
-- Append a String to the Buffer -- 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 package Path_File_Table is new GNAT.Dynamic_Tables
(Table_Component_Type => Path_Name_Type, (Table_Component_Type => Path_Name_Type,
Table_Index_Type => Natural, Table_Index_Type => Natural,
...@@ -1567,26 +1475,28 @@ private ...@@ -1567,26 +1475,28 @@ private
-- A table to store the object dirs, before creating the object path file -- A table to store the object dirs, before creating the object path file
type Private_Project_Tree_Data is record type Private_Project_Tree_Data is record
Namings : Naming_Table.Instance;
Path_Files : Path_File_Table.Instance; Path_Files : Path_File_Table.Instance;
Source_Paths : Source_Path_Table.Instance; Source_Paths : Source_Path_Table.Instance;
Object_Paths : Object_Path_Table.Instance; Object_Paths : Object_Path_Table.Instance;
Default_Naming : Naming_Data;
Current_Source_Path_File : Path_Name_Type := No_Path; Current_Source_Path_File : Path_Name_Type := No_Path;
-- Current value of project source path file env var. Used to avoid -- Current value of project source path file env var. Used to avoid
-- setting the env var to the same value. -- setting the env var to the same value.
-- gnatmake only
Current_Object_Path_File : Path_Name_Type := No_Path; Current_Object_Path_File : Path_Name_Type := No_Path;
-- Current value of project object path file env var. Used to avoid -- Current value of project object path file env var. Used to avoid
-- setting the env var to the same value. -- setting the env var to the same value.
-- gnatmake only
Ada_Path_Buffer : String_Access := new String (1 .. 1024); Ada_Path_Buffer : String_Access := new String (1 .. 1024);
-- A buffer where values for ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are -- A buffer where values for ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are
-- stored. -- stored.
-- gnatmake only
Ada_Path_Length : Natural := 0; Ada_Path_Length : Natural := 0;
-- Index of the last valid character in Ada_Path_Buffer -- Index of the last valid character in Ada_Path_Buffer
-- gnatmake only
Ada_Prj_Include_File_Set : Boolean := False; Ada_Prj_Include_File_Set : Boolean := False;
Ada_Prj_Objects_File_Set : Boolean := False; Ada_Prj_Objects_File_Set : Boolean := False;
...@@ -1596,8 +1506,10 @@ private ...@@ -1596,8 +1506,10 @@ private
-- effect on most platforms, except on VMS where the logical names are -- effect on most platforms, except on VMS where the logical names are
-- deassigned, thus avoiding the pollution of the environment of the -- deassigned, thus avoiding the pollution of the environment of the
-- caller. -- caller.
-- gnatmake only
Fill_Mapping_File : Boolean := True; Fill_Mapping_File : Boolean := True;
-- gnatmake only
end record; end record;
-- Type to represent the part of a project tree which is private to the -- Type to represent the part of a project tree which is private to the
......
...@@ -3979,9 +3979,17 @@ package body Sem_Res is ...@@ -3979,9 +3979,17 @@ package body Sem_Res is
Check_Unset_Reference (Expression (E)); Check_Unset_Reference (Expression (E));
-- A qualified expression requires an exact match of the type, -- 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))) or else Is_Class_Wide_Type (Etype (E)))
and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
then then
......
...@@ -820,6 +820,13 @@ package VMS_Data is ...@@ -820,6 +820,13 @@ package VMS_Data is
-- --
-- Work quietly, only output warnings and errors. -- 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=" & S_Check_Sections : aliased constant S := "/SECTIONS=" &
"DEFAULT " & "DEFAULT " &
"-s123 " & "-s123 " &
...@@ -893,6 +900,7 @@ package VMS_Data is ...@@ -893,6 +900,7 @@ package VMS_Data is
S_Check_Mess 'Access, S_Check_Mess 'Access,
S_Check_Project 'Access, S_Check_Project 'Access,
S_Check_Quiet 'Access, S_Check_Quiet 'Access,
S_Check_Time 'Access,
S_Check_Sections 'Access, S_Check_Sections 'Access,
S_Check_Short 'Access, S_Check_Short 'Access,
S_Check_Subdirs 'Access, S_Check_Subdirs 'Access,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment