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>
* 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.
......
......@@ -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
......
......@@ -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");
......
......@@ -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
......
......@@ -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,42 +446,34 @@ 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 Lang = null then
if Current_Verbosity = High then
Write_Str ("Languages does not contain Ada, nothing to do");
end if;
return;
end if;
if Current_Project = null then
First_Project := new Project_List_Element'
(Project => Project,
Next => First_Project);
Naming := Lang.Config.Naming_Data;
-- 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
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;
-- If we don't know it, add it
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;
if Current_Naming > Naming_Table.Last (Namings) then
Naming_Table.Increment_Last (Namings);
Namings.Table (Naming_Table.Last (Namings)) := Naming;
-- We need a temporary file to be created
......@@ -490,15 +487,13 @@ package body Prj.Env is
(File, "pragma Source_File_Name_Project");
Put_Line
(File, " (Spec_File_Name => ""*" &
Spec_Suffix_Of (In_Tree, "ada", Project.Naming) &
""",");
Get_Name_String (Naming.Spec_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 body
......@@ -506,51 +501,31 @@ package body Prj.Env is
(File, "pragma Source_File_Name_Project");
Put_Line
(File, " (Body_File_Name => ""*" &
Body_Suffix_Of (In_Tree, "ada", Project.Naming) &
""",");
Get_Name_String (Naming.Body_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");
if Naming.Body_Suffix /= 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) &
""",");
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) &
""");");
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
......@@ -836,17 +813,18 @@ package body Prj.Env is
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,11 +984,20 @@ 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;
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;
......@@ -1024,6 +1007,15 @@ package body Prj.Env is
Name_Len := Extended_Body_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
The_Body_Name := Name_Find;
end;
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,11 +1445,20 @@ 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;
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;
......@@ -1469,6 +1468,11 @@ package body Prj.Env is
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);
......
......@@ -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;
......
......@@ -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,51 +3117,34 @@ 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
if Ada = null then
-- No language, thus nothing to do
return;
end if;
declare
Data : Lang_Naming_Data renames Ada.Config.Naming_Data;
begin
-- The default value of separate suffix should be the same as the
-- body suffix, so we need to compute that first.
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;
Write_Attr ("Body_Suffix", Get_Name_String (Body_Suffix));
Data.Separate_Suffix := Data.Body_Suffix;
Write_Attr ("Body_Suffix", Get_Name_String (Data.Body_Suffix));
-- We'll need the dot replacement below, so compute it now
Check_Common
(Dot_Replacement => Project.Naming.Dot_Replacement,
Casing => Project.Naming.Casing,
(Dot_Replacement => Data.Dot_Replacement,
Casing => Data.Casing,
Casing_Defined => Casing_Defined,
Separate_Suffix => Project.Naming.Separate_Suffix,
Separate_Suffix => Data.Separate_Suffix,
Sep_Suffix_Loc => Sep_Suffix_Loc);
Bodies := Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree);
......@@ -3185,66 +3163,52 @@ package body Prj.Nmsc is
-- Check Spec_Suffix
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);
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
if Is_Illegal_Suffix
(Body_Suffix, Project.Naming.Dot_Replacement)
then
Err_Vars.Error_Msg_File_1 := Body_Suffix;
if Is_Illegal_Suffix (Data.Body_Suffix, Data.Dot_Replacement) then
Err_Vars.Error_Msg_File_1 := Data.Body_Suffix;
Error_Msg
(Project, In_Tree,
"{ is illegal for Body_Suffix",
Ada_Body_Suffix.Location);
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.
-- 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
if Data.Spec_Suffix = Data.Body_Suffix then
Error_Msg
(Project, In_Tree,
"Body_Suffix (""" &
Get_Name_String (Body_Suffix) &
Get_Name_String (Data.Body_Suffix) &
""") cannot be the same as Spec_Suffix.",
Ada_Body_Suffix.Location);
Ada_Body_Suffix_Loc);
end if;
if Body_Suffix /= Project.Naming.Separate_Suffix
and then Spec_Suffix = Project.Naming.Separate_Suffix
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 (Project.Naming.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,6 +3339,88 @@ 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
......@@ -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,168 +4140,65 @@ package body Prj.Nmsc is
end if;
end Check_Library_Attributes;
--------------------------
-- Check_Package_Naming --
--------------------------
---------------------------------
-- Check_Programming_Languages --
---------------------------------
procedure Check_Package_Naming
(Project : Project_Id;
In_Tree : Project_Tree_Ref)
procedure Check_Programming_Languages
(In_Tree : Project_Tree_Ref;
Project : Project_Id)
is
Naming_Id : constant Package_Id :=
Util.Value_Of (Name_Naming, Project.Decl.Packages, In_Tree);
Languages : Variable_Value := Nil_Variable_Value;
Def_Lang : Variable_Value := Nil_Variable_Value;
Def_Lang_Id : Name_Id;
Naming : Package_Element;
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
-- 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"".");
while Lang /= No_Language_Index loop
if Name = Lang.Name then
return;
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;
Lang := Lang.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;
Lang := new Language_Data'(No_Language_Data);
Lang.Next := Project.Languages;
Project.Languages := Lang;
Lang.Name := Name;
Lang.Display_Name := Display_Name;
-- 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;
if Name = Name_Ada then
Lang.Config.Kind := Unit_Based;
Lang.Config.Dependency_Kind := ALI_File;
-- Put the resulting array as the implementation suffixes
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
Project.Naming.Body_Suffix := Impl_Suffixs;
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;
end;
end if;
end Check_Package_Naming;
---------------------------------
-- Check_Programming_Languages --
---------------------------------
procedure Check_Programming_Languages
(In_Tree : Project_Tree_Ref;
Project : Project_Id)
is
Languages : Variable_Value := Nil_Variable_Value;
Def_Lang : Variable_Value := Nil_Variable_Value;
Def_Lang_Id : Name_Id;
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,13 +6287,15 @@ package body Prj.Nmsc is
else
Exception_Id := No_Ada_Naming_Exception;
Lang := Get_Language_From_Name (Project, "ada");
if Lang = null then
Unit_Name := No_Name;
Unit_Kind := Spec;
else
Compute_Unit_Name
(File_Name => Canonical_File_Name,
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,
Naming => Lang.Config.Naming_Data,
Kind => Kind,
Unit => Unit_Name,
In_Tree => In_Tree);
......@@ -6393,6 +6305,7 @@ package body Prj.Nmsc is
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);
......
......@@ -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);
......
......@@ -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)
......
......@@ -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,7 +97,6 @@ package body Prj is
Exec_Directory => No_Path_Information,
Extends => No_Project,
Extended_By => No_Project,
Naming => Std_Naming_Data,
Languages => No_Language_Index,
Decl => No_Declarations,
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 --
-------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
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