Skip to content

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

prj-proc.adb, [...] (Check_Naming_Schemes): split into several smaller subprograms. 

2009-04-22  Emmanuel Briot  <briot@adacore.com>

	* prj-proc.adb, prj-nmsc.adb (Check_Naming_Schemes): split into several
	smaller subprograms.
	Renamed to Check_File_Naming_Schemes to avoid confusion with the
	other Check_Naming_Schemes functions that plays a totally different
	role.
	(Check_Unit_Based_Lang, Check_File_Based_Lang): new subprograms,
	extracted from the above. These were partially rewritten to avoid
	unnecessary code and temporary variables.
	(Compute_Unit_Name): new subprogram, merge of Check_Unit_Based_Lang
	and Get_Unit (which for now still exist since they contain mode-specific
	code)

From-SVN: r146568
parent 347ab254
Showing with 472 additions and 656 deletions
gcc/ada/ChangeLog
2009-04-22 Emmanuel Briot <briot@adacore.com> 2009-04-22 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb, prj-nmsc.adb (Check_Naming_Schemes): split into several
smaller subprograms.
Renamed to Check_File_Naming_Schemes to avoid confusion with the
other Check_Naming_Schemes functions that plays a totally different
role.
(Check_Unit_Based_Lang, Check_File_Based_Lang): new subprograms,
extracted from the above. These were partially rewritten to avoid
unnecessary code and temporary variables.
(Compute_Unit_Name): new subprogram, merge of Check_Unit_Based_Lang
and Get_Unit (which for now still exist since they contain mode-specific
code)
2009-04-22 Emmanuel Briot <briot@adacore.com>
* prj.ads, prj.adb, prj-nmsc.adb, prj-proc.adb (Recursive_Process): * prj.ads, prj.adb, prj-nmsc.adb, prj-proc.adb (Recursive_Process):
Remove duplicated code. Remove duplicated code.
(Canonical_Case_File_Name): new subprogram (Canonical_Case_File_Name): new subprogram
......
gcc/ada/prj-nmsc.adb
...@@ -216,9 +216,9 @@ package body Prj.Nmsc is ...@@ -216,9 +216,9 @@ package body Prj.Nmsc is
-- with a file name following the naming convention. -- with a file name following the naming convention.
procedure Load_Naming_Exceptions procedure Load_Naming_Exceptions
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data); Data : in out Project_Data);
-- All source files in Data.First_Source are considered as naming -- All source files in Data.First_Source are considered as naming
-- exceptions, and copied into the Source_Names and Unit_Exceptions tables -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
-- as appropriate. -- as appropriate.
...@@ -254,6 +254,16 @@ package body Prj.Nmsc is ...@@ -254,6 +254,16 @@ package body Prj.Nmsc is
-- Same as Osint.Canonical_Case_File_Name but applies to Name_Id. -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
-- This alters Name_Buffer -- This alters Name_Buffer
function Suffix_Matches
(Filename : String; Suffix : File_Name_Type) return Boolean;
-- True if the filename ends with the given suffix. It always returns False
-- if Suffix is No_Name
procedure Replace_Into_Name_Buffer
(Str : String; Pattern : String; Replacement : Character);
-- Copy Str into Name_Buffer, replacing Pattern with Replacement.
-- Str is converted to lower-case at the same time
function ALI_File_Name (Source : String) return String; function ALI_File_Name (Source : String) return String;
-- Return the ALI file name corresponding to a source -- Return the ALI file name corresponding to a source
...@@ -354,6 +364,13 @@ package body Prj.Nmsc is ...@@ -354,6 +364,13 @@ package body Prj.Nmsc is
-- Find the path names of the source files in the Source_Names table -- Find the path names of the source files in the Source_Names table
-- in the source directories and record those that are Ada sources. -- in the source directories and record those that are Ada sources.
function Get_Language_Processing_From_Lang
(In_Tree : Project_Tree_Ref;
Data : Project_Data;
Lang : Name_List_Index) return Language_Index;
-- Return the language_processing description associated for the given
-- language.
function Compute_Directory_Last (Dir : String) return Natural; function Compute_Directory_Last (Dir : String) return Natural;
-- Return the index of the last significant character in Dir. This is used -- Return the index of the last significant character in Dir. This is used
-- to avoid duplicate '/' (slash) characters at the end of directory names. -- to avoid duplicate '/' (slash) characters at the end of directory names.
...@@ -414,7 +431,7 @@ package body Prj.Nmsc is ...@@ -414,7 +431,7 @@ package body Prj.Nmsc is
-- If For_All_Sources is True, then all possible file names are analyzed -- If For_All_Sources is True, then all possible file names are analyzed
-- otherwise only those currently set in the Source_Names htable. -- otherwise only those currently set in the Source_Names htable.
procedure Check_Naming_Schemes procedure Check_File_Naming_Schemes
(In_Tree : Project_Tree_Ref; (In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Filename : String; Filename : String;
...@@ -475,6 +492,19 @@ package body Prj.Nmsc is ...@@ -475,6 +492,19 @@ package body Prj.Nmsc is
-- Lang indicates which language is being processed when in Ada_Only mode -- Lang indicates which language is being processed when in Ada_Only mode
-- (all languages are processed anyway when in Multi_Language mode). -- (all languages are processed anyway when in Multi_Language mode).
procedure Compute_Unit_Name
(Filename : String;
Dot_Replacement : File_Name_Type;
Separate_Suffix : File_Name_Type;
Body_Suffix : File_Name_Type;
Spec_Suffix : File_Name_Type;
Casing : Casing_Type;
Kind : out Source_Kind;
Unit : out Name_Id);
-- Check whether the file matches the naming scheme. If it does,
-- compute its unit name. If Unit is set to No_Name on exit, none of the
-- other out parameters are relevant.
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;
...@@ -593,6 +623,54 @@ package body Prj.Nmsc is ...@@ -593,6 +623,54 @@ package body Prj.Nmsc is
-- Debug print a value for a specific property. Does nothing when not in -- Debug print a value for a specific property. Does nothing when not in
-- debug mode -- debug mode
------------------------------
-- Replace_Into_Name_Buffer --
------------------------------
procedure Replace_Into_Name_Buffer
(Str : String; Pattern : String; Replacement : Character)
is
Max : constant Integer := Str'Last - Pattern'Length + 1;
J : Positive := Str'First;
begin
Name_Len := 0;
while J <= Str'Last loop
Name_Len := Name_Len + 1;
if J <= Max
and then Str (J .. J + Pattern'Length - 1) = Pattern
then
Name_Buffer (Name_Len) := Replacement;
J := J + Pattern'Length;
else
Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
J := J + 1;
end if;
end loop;
end Replace_Into_Name_Buffer;
--------------------
-- Suffix_Matches --
--------------------
function Suffix_Matches
(Filename : String; Suffix : File_Name_Type) return Boolean is
begin
if Suffix = No_File then
return False;
end if;
declare
Suf : constant String := Get_Name_String (Suffix);
begin
return Filename'Length > Suf'Length
and then Filename
(Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
end;
end Suffix_Matches;
---------------- ----------------
-- Write_Attr -- -- Write_Attr --
---------------- ----------------
...@@ -2833,7 +2911,7 @@ package body Prj.Nmsc is ...@@ -2833,7 +2911,7 @@ package body Prj.Nmsc is
-- this package. -- this package.
procedure Check_Naming_Multi_Lang; procedure Check_Naming_Multi_Lang;
-- Does Check_Naming_Schemes processing for Multi_Language mode. -- Does Check_Naming_Schemes processing for Multi_Language mode
procedure Check_Common procedure Check_Common
(Dot_Replacement : in out File_Name_Type; (Dot_Replacement : in out File_Name_Type;
...@@ -6574,319 +6652,242 @@ package body Prj.Nmsc is ...@@ -6574,319 +6652,242 @@ package body Prj.Nmsc is
end if; end if;
end Get_Sources_From_File; end Get_Sources_From_File;
-------------- -----------------------
-- Get_Unit -- -- Compute_Unit_Name --
-------------- -----------------------
procedure Get_Unit procedure Compute_Unit_Name
(In_Tree : Project_Tree_Ref; (Filename : String;
Canonical_File_Name : File_Name_Type; Dot_Replacement : File_Name_Type;
Naming : Naming_Data; Separate_Suffix : File_Name_Type;
Exception_Id : out Ada_Naming_Exception_Id; Body_Suffix : File_Name_Type;
Unit_Name : out Name_Id; Spec_Suffix : File_Name_Type;
Unit_Kind : out Spec_Or_Body; Casing : Casing_Type;
Needs_Pragma : out Boolean) Kind : out Source_Kind;
Unit : out Name_Id)
is is
Info_Id : Ada_Naming_Exception_Id := Last : Integer := Filename'Last;
Ada_Naming_Exceptions.Get (Canonical_File_Name); Sep_Len : constant Integer := Integer (Length_Of_Name (Separate_Suffix));
VMS_Name : File_Name_Type; Body_Len : constant Integer := Integer (Length_Of_Name (Body_Suffix));
Spec_Len : constant Integer := Integer (Length_Of_Name (Spec_Suffix));
Standard_GNAT : constant Boolean := Spec_Suffix = Default_Ada_Spec_Suffix
and then Body_Suffix = Default_Ada_Body_Suffix;
begin begin
if Info_Id = No_Ada_Naming_Exception then Unit := No_Name;
if Hostparm.OpenVMS then Kind := Spec;
VMS_Name := Canonical_File_Name;
Get_Name_String (VMS_Name);
if Name_Buffer (Name_Len) = '.' then if Dot_Replacement = No_File then
Name_Len := Name_Len - 1; if Current_Verbosity = High then
VMS_Name := Name_Find; Write_Line (" No dot_replacement specified");
end if;
Info_Id := Ada_Naming_Exceptions.Get (VMS_Name);
end if; end if;
end if;
if Info_Id /= No_Ada_Naming_Exception then
Exception_Id := Info_Id;
Unit_Name := No_Name;
Unit_Kind := Specification;
Needs_Pragma := True;
return; return;
end if; end if;
Needs_Pragma := False; -- Choose the longest suffix that matches. If there are several matches,
Exception_Id := No_Ada_Naming_Exception; -- give priority to specs, then bodies, then separates.
Get_Name_String (Canonical_File_Name);
-- How about some comments and a name for this declare block ???
-- In fact the whole code below needs more comments ???
declare if Separate_Suffix /= Body_Suffix
File : String := Name_Buffer (1 .. Name_Len); and then Suffix_Matches (Filename, Separate_Suffix)
First : constant Positive := File'First; then
Last : Natural := File'Last; Last := Filename'Last - Sep_Len;
Standard_GNAT : Boolean; Kind := Sep;
Spec : constant File_Name_Type := end if;
Spec_Suffix_Id_Of (In_Tree, Name_Ada, Naming);
Body_Suff : constant File_Name_Type :=
Body_Suffix_Id_Of (In_Tree, Name_Ada, Naming);
begin if Filename'Last - Body_Len <= Last
Standard_GNAT := Spec = Default_Ada_Spec_Suffix and then Suffix_Matches (Filename, Body_Suffix)
and then Body_Suff = Default_Ada_Body_Suffix; then
Last := Natural'Min (Last, Filename'Last - Body_Len);
Kind := Impl;
end if;
declare if Filename'Last - Spec_Len <= Last
Spec_Suffix : constant String := Get_Name_String (Spec); and then Suffix_Matches (Filename, Spec_Suffix)
Body_Suffix : constant String := Get_Name_String (Body_Suff); then
Sep_Suffix : constant String := Last := Natural'Min (Last, Filename'Last - Spec_Len);
Get_Name_String (Naming.Separate_Suffix); Kind := Spec;
end if;
May_Be_Spec : Boolean; if Last = Filename'Last then
May_Be_Body : Boolean; if Current_Verbosity = High then
May_Be_Sep : Boolean; Write_Line (" No matching suffix");
end if;
return;
end if;
begin -- Check that the casing matches
May_Be_Spec :=
File'Length > Spec_Suffix'Length
and then
File (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix;
May_Be_Body :=
File'Length > Body_Suffix'Length
and then
File (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix;
May_Be_Sep :=
File'Length > Sep_Suffix'Length
and then
File (Last - Sep_Suffix'Length + 1 .. Last) = Sep_Suffix;
-- If two May_Be_ booleans are True, always choose the longer one
if May_Be_Spec then
if May_Be_Body and then
Spec_Suffix'Length < Body_Suffix'Length
then
Unit_Kind := Body_Part;
if May_Be_Sep and then if File_Names_Case_Sensitive then
Body_Suffix'Length < Sep_Suffix'Length case Casing is
when All_Lower_Case =>
for J in Filename'Range loop
if Is_Letter (Filename (J))
and then not Is_Lower (Filename (J))
then then
Last := Last - Sep_Suffix'Length; if Current_Verbosity = High then
May_Be_Body := False; Write_Line (" Invalid casing");
end if;
else return;
Last := Last - Body_Suffix'Length;
May_Be_Sep := False;
end if; end if;
end loop;
elsif May_Be_Sep and then when All_Upper_Case =>
Spec_Suffix'Length < Sep_Suffix'Length for J in Filename'Range loop
then if Is_Letter (Filename (J))
Unit_Kind := Body_Part; and then not Is_Upper (Filename (J))
Last := Last - Sep_Suffix'Length; then
if Current_Verbosity = High then
else Write_Line (" Invalid casing");
Unit_Kind := Specification; end if;
Last := Last - Spec_Suffix'Length; return;
end if;
elsif May_Be_Body then
Unit_Kind := Body_Part;
if May_Be_Sep and then
Body_Suffix'Length < Sep_Suffix'Length
then
Last := Last - Sep_Suffix'Length;
May_Be_Body := False;
else
Last := Last - Body_Suffix'Length;
May_Be_Sep := False;
end if;
elsif May_Be_Sep then
Unit_Kind := Body_Part;
Last := Last - Sep_Suffix'Length;
else
Last := 0;
end if;
if Last = 0 then
-- This is not a source file
Unit_Name := No_Name;
Unit_Kind := Specification;
if Current_Verbosity = High then
Write_Line (" Not a valid file name.");
end if;
return;
elsif Current_Verbosity = High then
case Unit_Kind is
when Specification =>
Write_Str (" Specification: ");
Write_Line (File (First .. Last + Spec_Suffix'Length));
when Body_Part =>
if May_Be_Body then
Write_Str (" Body: ");
Write_Line (File (First .. Last + Body_Suffix'Length));
else
Write_Str (" Separate: ");
Write_Line (File (First .. Last + Sep_Suffix'Length));
end if; end if;
end case; end loop;
end if;
end;
Get_Name_String (Naming.Dot_Replacement);
Standard_GNAT :=
Standard_GNAT and then Name_Buffer (1 .. Name_Len) = "-";
if Name_Buffer (1 .. Name_Len) /= "." then when Mixed_Case | Unknown =>
null;
end case;
end if;
-- If Dot_Replacement is not a single dot, then there should not -- If Dot_Replacement is not a single dot, then there should not
-- be any dot in the name. -- be any dot in the name.
for Index in First .. Last loop declare
if File (Index) = '.' then Dot_Repl : constant String := Get_Name_String (Dot_Replacement);
begin
if Dot_Repl /= "." then
for Index in Filename'First .. Last loop
if Filename (Index) = '.' then
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Line Write_Line (" Invalid name, contains dot");
(" Not a valid file name (some dot not replaced).");
end if; end if;
Unit_Name := No_Name;
return; return;
end if; end if;
end loop; end loop;
-- Replace the substring Dot_Replacement with dots Replace_Into_Name_Buffer
(Filename (Filename'First .. Last), Dot_Repl, '.');
declare else
Index : Positive := First; Name_Len := Last - Filename'First + 1;
Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
begin Fixed.Translate
while Index <= Last - Name_Len + 1 loop (Source => Name_Buffer (1 .. Name_Len),
Mapping => Lower_Case_Map);
if File (Index .. Index + Name_Len - 1) =
Name_Buffer (1 .. Name_Len)
then
File (Index) := '.';
if Name_Len > 1 and then Index < Last then
File (Index + 1 .. Last - Name_Len + 1) :=
File (Index + Name_Len .. Last);
end if;
Last := Last - Name_Len + 1;
end if;
Index := Index + 1;
end loop;
end;
end if; end if;
end;
-- Check if the file casing is right -- In the standard GNAT naming scheme, check for special cases: children
-- or separates of A, G, I or S, and run time sources.
if Standard_GNAT and then Name_Len >= 3 then
declare declare
Src : String := File (First .. Last); S1 : constant Character := Name_Buffer (1);
Src_Last : Positive := Last; S2 : constant Character := Name_Buffer (2);
S3 : constant Character := Name_Buffer (3);
begin begin
-- If casing is significant, deal with upper/lower case translate if S1 = 'a'
or else S1 = 'g'
if File_Names_Case_Sensitive then or else S1 = 'i'
case Naming.Casing is or else S1 = 's'
when All_Lower_Case => then
Fixed.Translate -- Children or separates of packages A, G, I or S. These names
(Source => Src, -- are x__ ... or x~... (where x is a, g, i, or s). Both
Mapping => Lower_Case_Map); -- versions (x__... and x~...) are allowed in all platforms,
-- because it is not possible to know the platform before
when All_Upper_Case => -- processing of the project files.
Fixed.Translate
(Source => Src, if S2 = '_' and then S3 = '_' then
Mapping => Upper_Case_Map); Name_Buffer (2) := '.';
Name_Buffer (3 .. Name_Len - 1) :=
when Mixed_Case | Unknown => Name_Buffer (4 .. Name_Len);
null; Name_Len := Name_Len - 1;
end case;
elsif S2 = '~' then
if Src /= File (First .. Last) then Name_Buffer (2) := '.';
if Current_Verbosity = High then
Write_Line (" Not a valid file name (casing)."); elsif S2 = '.' then
end if; -- If it is potentially a run time source, disable
-- filling of the mapping file to avoid warnings.
Unit_Name := No_Name; Set_Mapping_File_Initial_State_To_Empty;
return;
end if; end if;
end if; end if;
end;
end if;
-- Put the name in lower case -- Name_Buffer contains the name of the the unit in lower-cases. Check
-- that this is a valid unit name
Fixed.Translate Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit);
(Source => Src,
Mapping => Lower_Case_Map);
-- In the standard GNAT naming scheme, check for special cases: if Unit /= No_Name
-- children or separates of A, G, I or S, and run time sources. and then Current_Verbosity = High
then
case Kind is
when Spec => Write_Str (" spec of ");
when Impl => Write_Str (" body of ");
when Sep => Write_Str (" sep of ");
end case;
if Standard_GNAT and then Src'Length >= 3 then Write_Line (Get_Name_String (Unit));
declare end if;
S1 : constant Character := Src (Src'First); end Compute_Unit_Name;
S2 : constant Character := Src (Src'First + 1);
S3 : constant Character := Src (Src'First + 2);
begin --------------
if S1 = 'a' or else -- Get_Unit --
S1 = 'g' or else --------------
S1 = 'i' or else
S1 = 's'
then
-- Children or separates of packages A, G, I or S. These
-- names are x__ ... or x~... (where x is a, g, i, or s).
-- Both versions (x__... and x~...) are allowed in all
-- platforms, because it is not possible to know the
-- platform before processing of the project files.
if S2 = '_' and then S3 = '_' then
Src (Src'First + 1) := '.';
Src_Last := Src_Last - 1;
Src (Src'First + 2 .. Src_Last) :=
Src (Src'First + 3 .. Src_Last + 1);
elsif S2 = '~' then
Src (Src'First + 1) := '.';
-- If it is potentially a run time source, disable
-- filling of the mapping file to avoid warnings.
elsif S2 = '.' then
Set_Mapping_File_Initial_State_To_Empty;
end if;
end if;
end;
end if;
if Current_Verbosity = High then procedure Get_Unit
Write_Str (" "); (In_Tree : Project_Tree_Ref;
Write_Line (Src (Src'First .. Src_Last)); Canonical_File_Name : File_Name_Type;
Naming : Naming_Data;
Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body;
Needs_Pragma : out Boolean)
is
Info_Id : Ada_Naming_Exception_Id :=
Ada_Naming_Exceptions.Get (Canonical_File_Name);
VMS_Name : File_Name_Type;
Kind : Source_Kind;
begin
if Info_Id = No_Ada_Naming_Exception then
if Hostparm.OpenVMS then
VMS_Name := Canonical_File_Name;
Get_Name_String (VMS_Name);
if Name_Buffer (Name_Len) = '.' then
Name_Len := Name_Len - 1;
VMS_Name := Name_Find;
end if; end if;
-- Now, we check if this name is a valid unit name Info_Id := Ada_Naming_Exceptions.Get (VMS_Name);
end if;
Check_Ada_Name end if;
(Name => Src (Src'First .. Src_Last), Unit => Unit_Name);
end;
end; if Info_Id /= No_Ada_Naming_Exception then
Exception_Id := Info_Id;
Unit_Name := No_Name;
Unit_Kind := Specification;
Needs_Pragma := True;
else
Needs_Pragma := False;
Exception_Id := No_Ada_Naming_Exception;
Compute_Unit_Name
(Filename => Get_Name_String (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);
case Kind is
when Spec => Unit_Kind := Specification;
when Impl | Sep => Unit_Kind := Body_Part;
end case;
end if;
end Get_Unit; end Get_Unit;
---------- ----------
...@@ -7620,11 +7621,33 @@ package body Prj.Nmsc is ...@@ -7620,11 +7621,33 @@ package body Prj.Nmsc is
end loop; end loop;
end Get_Path_Names_And_Record_Ada_Sources; end Get_Path_Names_And_Record_Ada_Sources;
-------------------------- ---------------------------------------
-- Check_Naming_Schemes -- -- Get_Language_Processing_From_Lang --
-------------------------- ---------------------------------------
procedure Check_Naming_Schemes function Get_Language_Processing_From_Lang
(In_Tree : Project_Tree_Ref;
Data : Project_Data;
Lang : Name_List_Index) return Language_Index
is
Name : constant Name_Id := In_Tree.Name_Lists.Table (Lang).Name;
Language : Language_Index := Data.First_Language_Processing;
begin
while Language /= No_Language_Index loop
if In_Tree.Languages_Data.Table (Language).Name = Name then
return Language;
end if;
Language := In_Tree.Languages_Data.Table (Language).Next;
end loop;
return No_Language_Index;
end Get_Language_Processing_From_Lang;
-------------------------------
-- Check_File_Naming_Schemes --
-------------------------------
procedure Check_File_Naming_Schemes
(In_Tree : Project_Tree_Ref; (In_Tree : Project_Tree_Ref;
Data : in out Project_Data; Data : in out Project_Data;
Filename : String; Filename : String;
...@@ -7637,409 +7660,184 @@ package body Prj.Nmsc is ...@@ -7637,409 +7660,184 @@ package body Prj.Nmsc is
Lang_Kind : out Language_Kind; Lang_Kind : out Language_Kind;
Kind : out Source_Kind) Kind : out Source_Kind)
is is
Last : Positive := Filename'Last;
Config : Language_Config; Config : Language_Config;
Lang : Name_List_Index := Data.Languages; Lang : Name_List_Index := Data.Languages;
Tmp_Lang : Language_Index;
Header_File : Boolean := False; Header_File : Boolean := False;
First_Language : Language_Index := No_Language_Index; -- True if we found at least one language for which the file is a header
OK : Boolean; -- In such a case, we search for all possible languages where this is
-- also a header (C and C++ for instance), since the file might be used
-- for several such languages.
procedure Check_File_Based_Lang;
-- Does the naming scheme test for file-based languages. For those,
-- there is no Unit. Just check if the file name has the implementation
-- or, if it is specified, the template suffix of the language.
--
-- Returns True if the file belongs to the current language and we
-- should stop searching for matching languages. Not that a given header
-- file could belong to several languages (C and C++ for instance). Thus
-- if we found a header we'll check whether it matches other languages
procedure Check_Unit_Based_Lang;
-- Does the naming scheme test for unit-based languages
Last_Spec : Natural; ---------------------------
Last_Body : Natural; -- Check_File_Based_Lang --
Last_Sep : Natural; ---------------------------
begin procedure Check_File_Based_Lang is
-- Default values begin
if not Header_File
and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
then
Unit := No_Name;
Kind := Impl;
Language := Tmp_Lang;
Alternate_Languages := No_Alternate_Language; if Current_Verbosity = High then
Language := No_Language_Index; Write_Str (" implementation of language ");
Language_Name := No_Name; Write_Line (Get_Name_String (Display_Language_Name));
Display_Language_Name := No_Name; end if;
Unit := No_Name;
Lang_Kind := File_Based;
Kind := Spec;
while Lang /= No_Name_List loop elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
Language_Name := In_Tree.Name_Lists.Table (Lang).Name; if Current_Verbosity = High then
Language := Data.First_Language_Processing; Write_Str (" header of language ");
Write_Line (Get_Name_String (Display_Language_Name));
end if;
if Current_Verbosity = High then if Header_File then
Write_Line Alternate_Language_Table.Increment_Last (In_Tree.Alt_Langs);
(" Testing language " In_Tree.Alt_Langs.Table
& Get_Name_String (Language_Name) (Alternate_Language_Table.Last (In_Tree.Alt_Langs)) :=
& " Header_File=" & Header_File'Img); (Language => Language,
Next => Alternate_Languages);
Alternate_Languages :=
Alternate_Language_Table.Last (In_Tree.Alt_Langs);
else
Header_File := True;
Kind := Spec;
Unit := No_Name;
Language := Tmp_Lang;
end if;
end if; end if;
end Check_File_Based_Lang;
while Language /= No_Language_Index loop ---------------------------
if In_Tree.Languages_Data.Table (Language).Name = -- Check_Unit_Based_Lang --
Language_Name ---------------------------
then
Display_Language_Name :=
In_Tree.Languages_Data.Table (Language).Display_Name;
Config := In_Tree.Languages_Data.Table (Language).Config;
Lang_Kind := Config.Kind;
if Config.Kind = File_Based then
-- For file based languages, there is no Unit. Just
-- check if the file name has the implementation or,
-- if it is specified, the template suffix of the
-- language.
Unit := No_Name;
if not Header_File
and then Config.Naming_Data.Body_Suffix /= No_File
then
declare
Impl_Suffix : constant String :=
Get_Name_String (Config.Naming_Data.Body_Suffix);
begin
if Filename'Length > Impl_Suffix'Length
and then
Filename
(Last - Impl_Suffix'Length + 1 .. Last) =
Impl_Suffix
then
Kind := Impl;
if Current_Verbosity = High then
Write_Str (" source of language ");
Write_Line
(Get_Name_String (Display_Language_Name));
end if;
return;
end if;
end;
end if;
if Config.Naming_Data.Spec_Suffix /= No_File then
declare
Spec_Suffix : constant String :=
Get_Name_String
(Config.Naming_Data.Spec_Suffix);
begin
if Filename'Length > Spec_Suffix'Length
and then
Filename
(Last - Spec_Suffix'Length + 1 .. Last) =
Spec_Suffix
then
Kind := Spec;
if Current_Verbosity = High then
Write_Str (" header file of language ");
Write_Line
(Get_Name_String (Display_Language_Name));
end if;
if Header_File then
Alternate_Language_Table.Increment_Last
(In_Tree.Alt_Langs);
In_Tree.Alt_Langs.Table
(Alternate_Language_Table.Last
(In_Tree.Alt_Langs)) :=
(Language => Language,
Next => Alternate_Languages);
Alternate_Languages :=
Alternate_Language_Table.Last
(In_Tree.Alt_Langs);
else
Header_File := True;
First_Language := Language;
end if;
end if;
end;
end if;
elsif not Header_File then
-- Unit based language
OK := Config.Naming_Data.Dot_Replacement /= No_File;
if OK then
-- Check casing
-- ??? Are we doing this once per file in the project ?
-- It should be done only once per project.
case Config.Naming_Data.Casing is
when All_Lower_Case =>
for J in Filename'Range loop
if Is_Letter (Filename (J)) then
if not Is_Lower (Filename (J)) then
OK := False;
exit;
end if;
end if;
end loop;
when All_Upper_Case =>
for J in Filename'Range loop
if Is_Letter (Filename (J)) then
if not Is_Upper (Filename (J)) then
OK := False;
exit;
end if;
end if;
end loop;
when Mixed_Case =>
null;
when others =>
OK := False;
end case;
end if;
if OK then
Last_Spec := Natural'Last;
Last_Body := Natural'Last;
Last_Sep := Natural'Last;
if Config.Naming_Data.Separate_Suffix /= No_File
and then
Config.Naming_Data.Separate_Suffix /=
Config.Naming_Data.Body_Suffix
then
declare
Suffix : constant String :=
Get_Name_String
(Config.Naming_Data.Separate_Suffix);
begin
if Filename'Length > Suffix'Length
and then
Filename
(Last - Suffix'Length + 1 .. Last) =
Suffix
then
Last_Sep := Last - Suffix'Length;
end if;
end;
end if;
if Config.Naming_Data.Body_Suffix /= No_File then
declare
Suffix : constant String :=
Get_Name_String
(Config.Naming_Data.Body_Suffix);
begin
if Filename'Length > Suffix'Length
and then
Filename
(Last - Suffix'Length + 1 .. Last) =
Suffix
then
Last_Body := Last - Suffix'Length;
end if;
end;
end if;
if Config.Naming_Data.Spec_Suffix /= No_File then
declare
Suffix : constant String :=
Get_Name_String
(Config.Naming_Data.Spec_Suffix);
begin
if Filename'Length > Suffix'Length
and then
Filename
(Last - Suffix'Length + 1 .. Last) =
Suffix
then
Last_Spec := Last - Suffix'Length;
end if;
end;
end if;
declare
Last_Min : constant Natural :=
Natural'Min (Natural'Min (Last_Spec,
Last_Body),
Last_Sep);
begin procedure Check_Unit_Based_Lang is
OK := Last_Min < Last; Masked : Boolean := False;
Unit_Except : Unit_Exception;
begin
Compute_Unit_Name
(Filename => Filename,
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,
Kind => Kind,
Unit => Unit);
-- If there is a naming exception for the same unit, the file is not
-- a source for the unit
if OK then if Unit /= No_Name then
Last := Last_Min; Unit_Except := Unit_Exceptions.Get (Unit);
if Last_Min = Last_Spec then if Kind = Spec then
Kind := Spec; Masked := Unit_Except.Spec /= No_File
and then Unit_Except.Spec /= File_Name;
else
Masked := Unit_Except.Impl /= No_File
and then Unit_Except.Impl /= File_Name;
end if;
elsif Last_Min = Last_Body then if Masked then
Kind := Impl; if Current_Verbosity = High then
Write_Str (" """ & Filename & """ contains the ");
else if Kind = Spec then
Kind := Sep; Write_Str ("spec of a unit found in """);
end if; Write_Str (Get_Name_String (Unit_Except.Spec));
end if; else
end; Write_Str ("body of a unit found in """);
Write_Str (Get_Name_String (Unit_Except.Impl));
end if; end if;
if OK then Write_Line (""" (ignored)");
end if;
-- Replace dot replacements with dots
Name_Len := 0;
declare
J : Positive := Filename'First;
Dot_Replacement : constant String :=
Get_Name_String
(Config.Naming_Data.
Dot_Replacement);
Max : constant Positive :=
Last - Dot_Replacement'Length + 1;
begin
loop
Name_Len := Name_Len + 1;
if J <= Max and then
Filename
(J .. J + Dot_Replacement'Length - 1) =
Dot_Replacement
then
Name_Buffer (Name_Len) := '.';
J := J + Dot_Replacement'Length;
else
if Filename (J) = '.' then
OK := False;
exit;
end if;
Name_Buffer (Name_Len) :=
GNAT.Case_Util.To_Lower (Filename (J));
J := J + 1;
end if;
exit when J > Last; else
end loop; if Current_Verbosity = High then
end; if Kind = Spec then
Write_Str (" spec of ");
else
Write_Str (" body of ");
end if; end if;
if OK then Write_Str (Get_Name_String (Unit));
Write_Str (" language: ");
-- The name buffer should contain the name of the Write_Line (Get_Name_String (Display_Language_Name));
-- the unit, if it is one. end if;
-- Check that this is a valid unit name
Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit);
if Unit /= No_Name then
if Current_Verbosity = High then
if Kind = Spec then
Write_Str (" spec of ");
else
Write_Str (" body of ");
end if;
Write_Str (Get_Name_String (Unit));
Write_Str (" (language ");
Write_Str
(Get_Name_String (Display_Language_Name));
Write_Line (")");
end if;
-- Comments required, declare block should
-- be named ???
declare
Unit_Except : constant Unit_Exception :=
Unit_Exceptions.Get (Unit);
procedure Masked_Unit (Spec : Boolean);
-- Indicate that there is an exception for
-- the same unit, so the file is not a
-- source for the unit.
-----------------
-- Masked_Unit --
-----------------
procedure Masked_Unit (Spec : Boolean) is
begin
if Current_Verbosity = High then
Write_Str (" """);
Write_Str (Filename);
Write_Str (""" contains the ");
if Spec then
Write_Str ("spec");
else
Write_Str ("body");
end if;
Write_Str
(" of a unit that is found in """);
if Spec then
Write_Str
(Get_Name_String
(Unit_Except.Spec));
else
Write_Str
(Get_Name_String
(Unit_Except.Impl));
end if;
Write_Line (""" (ignored)"); Language := Tmp_Lang;
end if; end if;
end if;
end Check_Unit_Based_Lang;
Language := No_Language_Index; begin
end Masked_Unit; Language := No_Language_Index;
Alternate_Languages := No_Alternate_Language;
Display_Language_Name := No_Name;
Unit := No_Name;
Lang_Kind := File_Based;
Kind := Spec;
begin while Lang /= No_Name_List loop
if Kind = Spec then Language_Name := In_Tree.Name_Lists.Table (Lang).Name;
if Unit_Except.Spec /= No_File Tmp_Lang := Get_Language_Processing_From_Lang (In_Tree, Data, Lang);
and then Unit_Except.Spec /= File_Name
then
Masked_Unit (Spec => True);
end if;
else if Current_Verbosity = High then
if Unit_Except.Impl /= No_File Write_Line
and then Unit_Except.Impl /= File_Name (" Testing language "
then & Get_Name_String (Language_Name)
Masked_Unit (Spec => False); & " Header_File=" & Header_File'Img);
end if; end if;
end if;
end;
return; if Tmp_Lang /= No_Language_Index then
end if; Display_Language_Name :=
In_Tree.Languages_Data.Table (Tmp_Lang).Display_Name;
Config := In_Tree.Languages_Data.Table (Tmp_Lang).Config;
Lang_Kind := Config.Kind;
case Config.Kind is
when File_Based =>
Check_File_Based_Lang;
exit when Kind = Impl;
when Unit_Based =>
-- We know it belongs to a least a file_based language, no
-- need to check unit-based ones.
if not Header_File then
Check_Unit_Based_Lang;
exit when Language /= No_Language_Index;
end if; end if;
end if; end case;
end if; end if;
Language := In_Tree.Languages_Data.Table (Language).Next;
end loop;
Lang := In_Tree.Name_Lists.Table (Lang).Next; Lang := In_Tree.Name_Lists.Table (Lang).Next;
end loop; end loop;
-- Comment needed here ??? if Language = No_Language_Index
and then Current_Verbosity = High
if Header_File then then
Language := First_Language; Write_Line (" not a source of any language");
else
Language := No_Language_Index;
if Current_Verbosity = High then
Write_Line (" not a source of any language");
end if;
end if; end if;
end Check_Naming_Schemes; end Check_File_Naming_Schemes;
---------------- ----------------
-- Check_File -- -- Check_File --
...@@ -8145,7 +7943,7 @@ package body Prj.Nmsc is ...@@ -8145,7 +7943,7 @@ package body Prj.Nmsc is
if Check_Name then if Check_Name then
Other_Part := No_Source; Other_Part := No_Source;
Check_Naming_Schemes Check_File_Naming_Schemes
(In_Tree => In_Tree, (In_Tree => In_Tree,
Data => Data, Data => Data,
Filename => Get_Name_String (File_Name), Filename => Get_Name_String (File_Name),
...@@ -8425,13 +8223,13 @@ package body Prj.Nmsc is ...@@ -8425,13 +8223,13 @@ package body Prj.Nmsc is
---------------------------- ----------------------------
procedure Load_Naming_Exceptions procedure Load_Naming_Exceptions
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref; In_Tree : Project_Tree_Ref;
Data : in out Project_Data) Data : in out Project_Data)
is is
Source : Source_Id := Data.First_Source; Source : Source_Id := Data.First_Source;
File : File_Name_Type; File : File_Name_Type;
Unit : Name_Id; Unit : Name_Id;
begin begin
Unit_Exceptions.Reset; Unit_Exceptions.Reset;
......
gcc/ada/prj-proc.adb
...@@ -2527,6 +2527,10 @@ package body Prj.Proc is ...@@ -2527,6 +2527,10 @@ package body Prj.Proc is
-- only projects imported through a standard "with" are processed. -- only projects imported through a standard "with" are processed.
-- Imported is the id of the last imported project. -- Imported is the id of the last imported project.
-------------------------------
-- Process_Imported_Projects --
-------------------------------
procedure Process_Imported_Projects procedure Process_Imported_Projects
(Imported : in out Project_List; (Imported : in out Project_List;
Limited_With : Boolean) Limited_With : Boolean)
......
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