From: Arnaud Charlet Date: Mon, 29 Aug 2011 08:30:02 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: releases/gcc-4.7.0~4226 X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=cf161d662097ee21f515df7c3cf407c1891c07f6;p=thirdparty%2Fgcc.git [multiple changes] 2011-08-29 Yannick Moy * sem_ch3.adb (Array_Type_Declaration): Insert a subtype declaration for every index type and component type that is not a subtype_mark. (Process_Subtype): Set Etype of subtype. 2011-08-29 Robert Dewar * a-cbmutr.adb, a-cimutr.adb, a-comutr.adb, prj-nmsc.adb: Minor code reorganization. Minor reformatting. From-SVN: r178159 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9dc41919b662..65e36ed2c849 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2011-08-29 Yannick Moy + + * sem_ch3.adb (Array_Type_Declaration): Insert a subtype declaration + for every index type and component type that is not a subtype_mark. + (Process_Subtype): Set Etype of subtype. + +2011-08-29 Robert Dewar + + * a-cbmutr.adb, a-cimutr.adb, a-comutr.adb, prj-nmsc.adb: Minor code + reorganization. Minor reformatting. + 2011-08-29 Steve Baird * exp_ch4.adb (Expand_N_Op_Expon): Suppress N_Op_Expon node expansion diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index cc569e836733..738097ff4683 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -435,14 +435,14 @@ package body Ada.Containers.Bounded_Multiway_Trees is begin if Parent = No_Element then return 0; - end if; - if Parent.Container.Count = 0 then + elsif Parent.Container.Count = 0 then pragma Assert (Is_Root (Parent)); return 0; - end if; - return Child_Count (Parent.Container.all, Parent.Node); + else + return Child_Count (Parent.Container.all, Parent.Node); + end if; end Child_Count; function Child_Count diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index a7f16ae15746..8f310a310261 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -303,9 +303,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is begin if Parent = No_Element then return 0; + else + return Child_Count (Parent.Node.Children); end if; - - return Child_Count (Parent.Node.Children); end Child_Count; function Child_Count (Children : Children_Type) return Count_Type is diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index f3c77ed6211e..f718eb8d31cb 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -299,9 +299,9 @@ package body Ada.Containers.Multiway_Trees is begin if Parent = No_Element then return 0; + else + return Child_Count (Parent.Node.Children); end if; - - return Child_Count (Parent.Node.Children); end Child_Count; function Child_Count (Children : Children_Type) return Count_Type is diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 7f36ded27df6..41121476fd85 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -281,14 +281,10 @@ package body Prj.Nmsc is -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is -- converted to lower-case at the same time. - procedure Check_Unit_Name (Name : String; Unit : out Name_Id); - -- Check that a name is a valid unit name - - procedure Check_Package_Naming + procedure Check_Abstract_Project (Project : Project_Id; Data : in out Tree_Processing_Data); - -- Check the naming scheme part of Data, and initialize the naming scheme - -- data in the config of the various languages. + -- Check abstract projects attributes procedure Check_Configuration (Project : Project_Id; @@ -313,10 +309,11 @@ package body Prj.Nmsc is -- Check the library attributes of project Project in project tree -- and modify its data Data accordingly. - procedure Check_Abstract_Project + procedure Check_Package_Naming (Project : Project_Id; Data : in out Tree_Processing_Data); - -- Check abstract projects attributes + -- Check the naming scheme part of Data, and initialize the naming scheme + -- data in the config of the various languages. procedure Check_Programming_Languages (Project : Project_Id; @@ -331,6 +328,9 @@ package body Prj.Nmsc is -- Check if project Project in project tree Data.Tree is a Stand-Alone -- Library project, and modify its data Data accordingly if it is one. + procedure Check_Unit_Name (Name : String; Unit : out Name_Id); + -- Check that a name is a valid unit name + function Compute_Directory_Last (Dir : String) return Natural; -- Return the index of the last significant character in Dir. This is used -- to avoid duplicate '/' (slash) characters at the end of directory names. @@ -1010,52 +1010,6 @@ package body Prj.Nmsc is Free (Project_Path_For_Aggregate); end Process_Aggregated_Projects; - ---------------------------- - -- Check_Abstract_Project -- - ---------------------------- - - procedure Check_Abstract_Project - (Project : Project_Id; - Data : in out Tree_Processing_Data) - is - Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; - - Source_Dirs : constant Variable_Value := - Util.Value_Of - (Name_Source_Dirs, - Project.Decl.Attributes, Shared); - Source_Files : constant Variable_Value := - Util.Value_Of - (Name_Source_Files, - Project.Decl.Attributes, Shared); - Source_List_File : constant Variable_Value := - Util.Value_Of - (Name_Source_List_File, - Project.Decl.Attributes, Shared); - Languages : constant Variable_Value := - Util.Value_Of - (Name_Languages, - Project.Decl.Attributes, Shared); - - begin - if Project.Source_Dirs /= Nil_String then - if Source_Dirs.Values = Nil_String - and then Source_Files.Values = Nil_String - and then Languages.Values = Nil_String - and then Source_List_File.Default - then - Project.Source_Dirs := Nil_String; - - else - Error_Msg - (Data.Flags, - "at least one of Source_Files, Source_Dirs or Languages " - & "must be declared empty for an abstract project", - Project.Location, Project); - end if; - end if; - end Check_Abstract_Project; - ----------- -- Check -- ----------- @@ -1112,262 +1066,125 @@ package body Prj.Nmsc is Debug_Decrease_Indent ("done check"); end Check; - --------------------- - -- Check_Unit_Name -- - --------------------- - - procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is - The_Name : String := Name; - Real_Name : Name_Id; - Need_Letter : Boolean := True; - Last_Underscore : Boolean := False; - OK : Boolean := The_Name'Length > 0; - First : Positive; - - function Is_Reserved (Name : Name_Id) return Boolean; - function Is_Reserved (S : String) return Boolean; - -- Check that the given name is not an Ada 95 reserved word. The reason - -- for the Ada 95 here is that we do not want to exclude the case of an - -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit - -- name would be rejected anyway by the compiler. That means there is no - -- requirement that the project file parser reject this. - - ----------------- - -- Is_Reserved -- - ----------------- + ---------------------------- + -- Check_Abstract_Project -- + ---------------------------- - function Is_Reserved (S : String) return Boolean is - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (S); - return Is_Reserved (Name_Find); - end Is_Reserved; + procedure Check_Abstract_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; - ----------------- - -- Is_Reserved -- - ----------------- + Source_Dirs : constant Variable_Value := + Util.Value_Of + (Name_Source_Dirs, + Project.Decl.Attributes, Shared); + Source_Files : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Project.Decl.Attributes, Shared); + Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Source_List_File, + Project.Decl.Attributes, Shared); + Languages : constant Variable_Value := + Util.Value_Of + (Name_Languages, + Project.Decl.Attributes, Shared); - function Is_Reserved (Name : Name_Id) return Boolean is - begin - if Get_Name_Table_Byte (Name) /= 0 - and then Name /= Name_Project - and then Name /= Name_Extends - and then Name /= Name_External - and then Name not in Ada_2005_Reserved_Words + begin + if Project.Source_Dirs /= Nil_String then + if Source_Dirs.Values = Nil_String + and then Source_Files.Values = Nil_String + and then Languages.Values = Nil_String + and then Source_List_File.Default then - Unit := No_Name; - Debug_Output ("Ada reserved word: ", Name); - return True; + Project.Source_Dirs := Nil_String; else - return False; + Error_Msg + (Data.Flags, + "at least one of Source_Files, Source_Dirs or Languages " + & "must be declared empty for an abstract project", + Project.Location, Project); end if; - end Is_Reserved; + end if; + end Check_Abstract_Project; - -- Start of processing for Check_Unit_Name + ------------------------- + -- Check_Configuration -- + ------------------------- - begin - To_Lower (The_Name); + procedure Check_Configuration + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Shared : constant Shared_Project_Tree_Data_Access := + Data.Tree.Shared; - Name_Len := The_Name'Length; - Name_Buffer (1 .. Name_Len) := The_Name; + Dot_Replacement : File_Name_Type := No_File; + Casing : Casing_Type := All_Lower_Case; + Separate_Suffix : File_Name_Type := No_File; - -- Special cases of children of packages A, G, I and S on VMS + Lang_Index : Language_Ptr := No_Language_Index; + -- The index of the language data being checked - if OpenVMS_On_Target - and then Name_Len > 3 - and then Name_Buffer (2 .. 3) = "__" - and then - ((Name_Buffer (1) = 'a') or else - (Name_Buffer (1) = 'g') or else - (Name_Buffer (1) = 'i') or else - (Name_Buffer (1) = 's')) - then - Name_Buffer (2) := '.'; - Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len); - Name_Len := Name_Len - 1; - end if; + Prev_Index : Language_Ptr := No_Language_Index; + -- The index of the previous language - Real_Name := Name_Find; + procedure Process_Project_Level_Simple_Attributes; + -- Process the simple attributes at the project level - if Is_Reserved (Real_Name) then - return; - end if; + procedure Process_Project_Level_Array_Attributes; + -- Process the associate array attributes at the project level - First := The_Name'First; + procedure Process_Packages; + -- Read the packages of the project - for Index in The_Name'Range loop - if Need_Letter then + ---------------------- + -- Process_Packages -- + ---------------------- - -- We need a letter (at the beginning, and following a dot), - -- but we don't have one. + procedure Process_Packages is + Packages : Package_Id; + Element : Package_Element; - if Is_Letter (The_Name (Index)) then - Need_Letter := False; + procedure Process_Binder (Arrays : Array_Id); + -- Process the associate array attributes of package Binder - else - OK := False; + procedure Process_Builder (Attributes : Variable_Id); + -- Process the simple attributes of package Builder - if Current_Verbosity = High then - Debug_Indent; - Write_Int (Types.Int (Index)); - Write_Str (": '"); - Write_Char (The_Name (Index)); - Write_Line ("' is not a letter."); - end if; + procedure Process_Compiler (Arrays : Array_Id); + -- Process the associate array attributes of package Compiler - exit; - end if; + procedure Process_Naming (Attributes : Variable_Id); + -- Process the simple attributes of package Naming - elsif Last_Underscore - and then (The_Name (Index) = '_' or else The_Name (Index) = '.') - then - -- Two underscores are illegal, and a dot cannot follow - -- an underscore. + procedure Process_Naming (Arrays : Array_Id); + -- Process the associate array attributes of package Naming - OK := False; + procedure Process_Linker (Attributes : Variable_Id); + -- Process the simple attributes of package Linker of a + -- configuration project. - if Current_Verbosity = High then - Debug_Indent; - Write_Int (Types.Int (Index)); - Write_Str (": '"); - Write_Char (The_Name (Index)); - Write_Line ("' is illegal here."); - end if; + -------------------- + -- Process_Binder -- + -------------------- - exit; + procedure Process_Binder (Arrays : Array_Id) is + Current_Array_Id : Array_Id; + Current_Array : Array_Data; + Element_Id : Array_Element_Id; + Element : Array_Element; - elsif The_Name (Index) = '.' then + begin + -- Process the associative array attribute of package Binder - -- First, check if the name before the dot is not a reserved word - - if Is_Reserved (The_Name (First .. Index - 1)) then - return; - end if; - - First := Index + 1; - - -- We need a letter after a dot - - Need_Letter := True; - - elsif The_Name (Index) = '_' then - Last_Underscore := True; - - else - -- We need an letter or a digit - - Last_Underscore := False; - - if not Is_Alphanumeric (The_Name (Index)) then - OK := False; - - if Current_Verbosity = High then - Debug_Indent; - Write_Int (Types.Int (Index)); - Write_Str (": '"); - Write_Char (The_Name (Index)); - Write_Line ("' is not alphanumeric."); - end if; - - exit; - end if; - end if; - end loop; - - -- Cannot end with an underscore or a dot - - OK := OK and then not Need_Letter and then not Last_Underscore; - - if OK then - if First /= Name'First and then - Is_Reserved (The_Name (First .. The_Name'Last)) - then - return; - end if; - - Unit := Real_Name; - - else - -- Signal a problem with No_Name - - Unit := No_Name; - end if; - end Check_Unit_Name; - - ------------------------- - -- Check_Configuration -- - ------------------------- - - procedure Check_Configuration - (Project : Project_Id; - Data : in out Tree_Processing_Data) - is - Shared : constant Shared_Project_Tree_Data_Access := - Data.Tree.Shared; - - Dot_Replacement : File_Name_Type := No_File; - Casing : Casing_Type := All_Lower_Case; - Separate_Suffix : File_Name_Type := No_File; - - Lang_Index : Language_Ptr := No_Language_Index; - -- The index of the language data being checked - - Prev_Index : Language_Ptr := No_Language_Index; - -- The index of the previous language - - procedure Process_Project_Level_Simple_Attributes; - -- Process the simple attributes at the project level - - procedure Process_Project_Level_Array_Attributes; - -- Process the associate array attributes at the project level - - procedure Process_Packages; - -- Read the packages of the project - - ---------------------- - -- Process_Packages -- - ---------------------- - - procedure Process_Packages is - Packages : Package_Id; - Element : Package_Element; - - procedure Process_Binder (Arrays : Array_Id); - -- Process the associate array attributes of package Binder - - procedure Process_Builder (Attributes : Variable_Id); - -- Process the simple attributes of package Builder - - procedure Process_Compiler (Arrays : Array_Id); - -- Process the associate array attributes of package Compiler - - procedure Process_Naming (Attributes : Variable_Id); - -- Process the simple attributes of package Naming - - procedure Process_Naming (Arrays : Array_Id); - -- Process the associate array attributes of package Naming - - procedure Process_Linker (Attributes : Variable_Id); - -- Process the simple attributes of package Linker of a - -- configuration project. - - -------------------- - -- Process_Binder -- - -------------------- - - procedure Process_Binder (Arrays : Array_Id) is - Current_Array_Id : Array_Id; - Current_Array : Array_Data; - Element_Id : Array_Element_Id; - Element : Array_Element; - - begin - -- Process the associative array attribute of package Binder - - Current_Array_Id := Arrays; - while Current_Array_Id /= No_Array loop - Current_Array := Shared.Arrays.Table (Current_Array_Id); + Current_Array_Id := Arrays; + while Current_Array_Id /= No_Array loop + Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop @@ -1492,10 +1309,10 @@ package body Prj.Nmsc is if Lang_Index /= No_Language_Index then case Current_Array.Name is - when Name_Dependency_Kind => - -- Attribute Dependency_Kind () + -- Attribute Dependency_Kind () + when Name_Dependency_Kind => Get_Name_String (Element.Value.Value); begin @@ -1512,10 +1329,9 @@ package body Prj.Nmsc is Project); end; - when Name_Dependency_Switches => - - -- Attribute Dependency_Switches () + -- Attribute Dependency_Switches () + when Name_Dependency_Switches => if Lang_Index.Config.Dependency_Kind = None then Lang_Index.Config.Dependency_Kind := Makefile; end if; @@ -1529,10 +1345,9 @@ package body Prj.Nmsc is In_Tree => Data.Tree); end if; - when Name_Dependency_Driver => - - -- Attribute Dependency_Driver () + -- Attribute Dependency_Driver () + when Name_Dependency_Driver => if Lang_Index.Config.Dependency_Kind = None then Lang_Index.Config.Dependency_Kind := Makefile; end if; @@ -1546,9 +1361,9 @@ package body Prj.Nmsc is In_Tree => Data.Tree); end if; - when Name_Language_Kind => - -- Attribute Language_Kind () + -- Attribute Language_Kind () + when Name_Language_Kind => Get_Name_String (Element.Value.Value); begin @@ -1565,10 +1380,9 @@ package body Prj.Nmsc is Project); end; - when Name_Include_Switches => - - -- Attribute Include_Switches () + -- Attribute Include_Switches () + when Name_Include_Switches => List := Element.Value.Values; if List = Nil_String then @@ -1581,39 +1395,36 @@ package body Prj.Nmsc is From_List => List, In_Tree => Data.Tree); - when Name_Include_Path => - - -- Attribute Include_Path () + -- Attribute Include_Path () + when Name_Include_Path => Lang_Index.Config.Include_Path := Element.Value.Value; - when Name_Include_Path_File => - - -- Attribute Include_Path_File () + -- Attribute Include_Path_File () + when Name_Include_Path_File => Lang_Index.Config.Include_Path_File := Element.Value.Value; - when Name_Driver => - - -- Attribute Driver () + -- Attribute Driver () + when Name_Driver => Lang_Index.Config.Compiler_Driver := File_Name_Type (Element.Value.Value); when Name_Required_Switches | Name_Leading_Required_Switches => Put (Into_List => - Lang_Index.Config. - Compiler_Leading_Required_Switches, + Lang_Index.Config. + Compiler_Leading_Required_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); when Name_Trailing_Required_Switches => Put (Into_List => - Lang_Index.Config. - Compiler_Trailing_Required_Switches, + Lang_Index.Config. + Compiler_Trailing_Required_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); @@ -1677,10 +1488,9 @@ package body Prj.Nmsc is From_List => Element.Value.Values, In_Tree => Data.Tree); - when Name_Pic_Option => - - -- Attribute Compiler_Pic_Option () + -- Attribute Compiler_Pic_Option () + when Name_Pic_Option => List := Element.Value.Values; if List = Nil_String then @@ -1695,10 +1505,9 @@ package body Prj.Nmsc is From_List => List, In_Tree => Data.Tree); - when Name_Mapping_File_Switches => - - -- Attribute Mapping_File_Switches () + -- Attribute Mapping_File_Switches () + when Name_Mapping_File_Switches => List := Element.Value.Values; if List = Nil_String then @@ -1713,24 +1522,21 @@ package body Prj.Nmsc is From_List => List, In_Tree => Data.Tree); - when Name_Mapping_Spec_Suffix => - - -- Attribute Mapping_Spec_Suffix () + -- Attribute Mapping_Spec_Suffix () + when Name_Mapping_Spec_Suffix => Lang_Index.Config.Mapping_Spec_Suffix := File_Name_Type (Element.Value.Value); - when Name_Mapping_Body_Suffix => - - -- Attribute Mapping_Body_Suffix () + -- Attribute Mapping_Body_Suffix () + when Name_Mapping_Body_Suffix => Lang_Index.Config.Mapping_Body_Suffix := File_Name_Type (Element.Value.Value); - when Name_Config_File_Switches => - - -- Attribute Config_File_Switches () + -- Attribute Config_File_Switches () + when Name_Config_File_Switches => List := Element.Value.Values; if List = Nil_String then @@ -1745,70 +1551,57 @@ package body Prj.Nmsc is From_List => List, In_Tree => Data.Tree); - when Name_Objects_Path => - - -- Attribute Objects_Path () + -- Attribute Objects_Path () + when Name_Objects_Path => Lang_Index.Config.Objects_Path := Element.Value.Value; - when Name_Objects_Path_File => - - -- Attribute Objects_Path_File () + -- Attribute Objects_Path_File () + when Name_Objects_Path_File => Lang_Index.Config.Objects_Path_File := Element.Value.Value; - when Name_Config_Body_File_Name => - - -- Attribute Config_Body_File_Name () + -- Attribute Config_Body_File_Name () + when Name_Config_Body_File_Name => Lang_Index.Config.Config_Body := Element.Value.Value; - when Name_Config_Body_File_Name_Index => - - -- Attribute Config_Body_File_Name_Index - -- ( < Language > ) + -- Attribute Config_Body_File_Name_Index (< Language>) + when Name_Config_Body_File_Name_Index => Lang_Index.Config.Config_Body_Index := Element.Value.Value; - when Name_Config_Body_File_Name_Pattern => - - -- Attribute Config_Body_File_Name_Pattern - -- () + -- Attribute Config_Body_File_Name_Pattern() + when Name_Config_Body_File_Name_Pattern => Lang_Index.Config.Config_Body_Pattern := Element.Value.Value; - when Name_Config_Spec_File_Name => - -- Attribute Config_Spec_File_Name () + when Name_Config_Spec_File_Name => Lang_Index.Config.Config_Spec := Element.Value.Value; - when Name_Config_Spec_File_Name_Index => - - -- Attribute Config_Spec_File_Name_Index - -- ( < Language > ) + -- Attribute Config_Spec_File_Name_Index () + when Name_Config_Spec_File_Name_Index => Lang_Index.Config.Config_Spec_Index := Element.Value.Value; - when Name_Config_Spec_File_Name_Pattern => - - -- Attribute Config_Spec_File_Name_Pattern - -- () + -- Attribute Config_Spec_File_Name_Pattern() + when Name_Config_Spec_File_Name_Pattern => Lang_Index.Config.Config_Spec_Pattern := Element.Value.Value; - when Name_Config_File_Unique => - - -- Attribute Config_File_Unique () + -- Attribute Config_File_Unique () + when Name_Config_File_Unique => begin Lang_Index.Config.Config_File_Unique := Boolean'Value @@ -2950,1397 +2743,1397 @@ package body Prj.Nmsc is end if; end Check_Interfaces; - -------------------------- - -- Check_Package_Naming -- - -------------------------- + ------------------------------ + -- Check_Library_Attributes -- + ------------------------------ - procedure Check_Package_Naming + -- This procedure is awfully long (over 700 lines) should be broken up??? + + procedure Check_Library_Attributes (Project : Project_Id; Data : in out Tree_Processing_Data) is - Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; - Naming_Id : constant Package_Id := - Util.Value_Of - (Name_Naming, Project.Decl.Packages, Shared); - Naming : Package_Element; + Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; - Ada_Body_Suffix_Loc : Source_Ptr := No_Location; + Attributes : constant Prj.Variable_Id := Project.Decl.Attributes; - procedure Check_Naming; - -- Check the validity of the Naming package (suffixes valid, ...) + Lib_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Dir, Attributes, Shared); - procedure Check_Common - (Dot_Replacement : in out File_Name_Type; - Casing : in out Casing_Type; - Casing_Defined : out Boolean; - Separate_Suffix : in out File_Name_Type; - Sep_Suffix_Loc : out Source_Ptr); - -- Check attributes common + Lib_Name : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Name, Attributes, Shared); - procedure Process_Exceptions_File_Based - (Lang_Id : Language_Ptr; - Kind : Source_Kind); - procedure Process_Exceptions_Unit_Based - (Lang_Id : Language_Ptr; - Kind : Source_Kind); - -- Process the naming exceptions for the two types of languages + Lib_Version : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Version, Attributes, Shared); - procedure Initialize_Naming_Data; - -- Initialize internal naming data for the various languages + Lib_ALI_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Ali_Dir, Attributes, Shared); - ------------------ - -- Check_Common -- - ------------------ + Lib_GCC : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_GCC, Attributes, Shared); - procedure Check_Common - (Dot_Replacement : in out File_Name_Type; - Casing : in out Casing_Type; - Casing_Defined : out Boolean; - Separate_Suffix : in out File_Name_Type; - Sep_Suffix_Loc : out Source_Ptr) - is - Dot_Repl : constant Variable_Value := - Util.Value_Of - (Name_Dot_Replacement, - Naming.Decl.Attributes, - Shared); - Casing_String : constant Variable_Value := - Util.Value_Of - (Name_Casing, - Naming.Decl.Attributes, - Shared); - Sep_Suffix : constant Variable_Value := - Util.Value_Of - (Name_Separate_Suffix, - Naming.Decl.Attributes, - Shared); - Dot_Repl_Loc : Source_Ptr; + The_Lib_Kind : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Kind, Attributes, Shared); - begin - Sep_Suffix_Loc := No_Location; + Imported_Project_List : Project_List; - if not Dot_Repl.Default then - pragma Assert - (Dot_Repl.Kind = Single, "Dot_Replacement is not a string"); + Continuation : String_Access := No_Continuation_String'Access; - if Length_Of_Name (Dot_Repl.Value) = 0 then - Error_Msg - (Data.Flags, "Dot_Replacement cannot be empty", - Dot_Repl.Location, Project); - end if; + Support_For_Libraries : Library_Support; - Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); - Dot_Repl_Loc := Dot_Repl.Location; + Library_Directory_Present : Boolean; - declare - Repl : constant String := Get_Name_String (Dot_Replacement); + procedure Check_Library (Proj : Project_Id; Extends : Boolean); + -- Check if an imported or extended project if also a library project - begin - -- Dot_Replacement cannot - -- - be empty - -- - start or end with an alphanumeric - -- - be a single '_' - -- - start with an '_' followed by an alphanumeric - -- - contain a '.' except if it is "." + ------------------- + -- Check_Library -- + ------------------- - if Repl'Length = 0 - or else Is_Alphanumeric (Repl (Repl'First)) - or else Is_Alphanumeric (Repl (Repl'Last)) - or else (Repl (Repl'First) = '_' - and then - (Repl'Length = 1 - or else - Is_Alphanumeric (Repl (Repl'First + 1)))) - or else (Repl'Length > 1 - and then - Index (Source => Repl, Pattern => ".") /= 0) - then - Error_Msg - (Data.Flags, - '"' & Repl & - """ is illegal for Dot_Replacement.", - Dot_Repl_Loc, Project); - end if; - end; - end if; + procedure Check_Library (Proj : Project_Id; Extends : Boolean) is + Src_Id : Source_Id; + Iter : Source_Iterator; - if Dot_Replacement /= No_File then - Write_Attr - ("Dot_Replacement", Get_Name_String (Dot_Replacement)); - end if; + begin + if Proj /= No_Project then + if not Proj.Library then - Casing_Defined := False; + -- The only not library projects that are OK are those that + -- have no sources. However, header files from non-Ada + -- languages are OK, as there is nothing to compile. - if not Casing_String.Default then - pragma Assert - (Casing_String.Kind = Single, "Casing is not a string"); + Iter := For_Each_Source (Data.Tree, Proj); + loop + Src_Id := Prj.Element (Iter); + exit when Src_Id = No_Source + or else Src_Id.Language.Config.Kind /= File_Based + or else Src_Id.Kind /= Spec; + Next (Iter); + end loop; - declare - Casing_Image : constant String := - Get_Name_String (Casing_String.Value); + if Src_Id /= No_Source then + Error_Msg_Name_1 := Project.Name; + Error_Msg_Name_2 := Proj.Name; - begin - if Casing_Image'Length = 0 then - Error_Msg - (Data.Flags, - "Casing cannot be an empty string", - Casing_String.Location, Project); + if Extends then + if Project.Library_Kind /= Static then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot extend " & + "project %% that is not a library project", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + + elsif (not Unchecked_Shared_Lib_Imports) + and then Project.Library_Kind /= Static + then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot import project %% " & + "that is not a shared library project", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; end if; - Casing := Value (Casing_Image); - Casing_Defined := True; + elsif Project.Library_Kind /= Static and then + Proj.Library_Kind = Static + then + Error_Msg_Name_1 := Project.Name; + Error_Msg_Name_2 := Proj.Name; - exception - when Constraint_Error => - Name_Len := Casing_Image'Length; - Name_Buffer (1 .. Name_Len) := Casing_Image; - Err_Vars.Error_Msg_Name_1 := Name_Find; + if Extends then Error_Msg (Data.Flags, - "%% is not a correct Casing", - Casing_String.Location, Project); - end; + Continuation.all & + "shared library project %% cannot extend static " & + "library project %%", + Project.Location, Project); + Continuation := Continuation_String'Access; + + elsif not Unchecked_Shared_Lib_Imports then + Error_Msg + (Data.Flags, + Continuation.all & + "shared library project %% cannot import static " & + "library project %%", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + + end if; end if; + end Check_Library; - Write_Attr ("Casing", Image (Casing)); + Dir_Exists : Boolean; - if not Sep_Suffix.Default then - if Length_Of_Name (Sep_Suffix.Value) = 0 then + -- Start of processing for Check_Library_Attributes + + begin + Library_Directory_Present := Lib_Dir.Value /= Empty_String; + + -- Special case of extending project + + if Project.Extends /= No_Project then + + -- If the project extended is a library project, we inherit the + -- library name, if it is not redefined; we check that the library + -- directory is specified. + + if Project.Extends.Library then + if Project.Qualifier = Standard then Error_Msg (Data.Flags, - "Separate_Suffix cannot be empty", - Sep_Suffix.Location, Project); + "a standard project cannot extend a library project", + Project.Location, Project); else - Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); - Sep_Suffix_Loc := Sep_Suffix.Location; + if Lib_Name.Default then + Project.Library_Name := Project.Extends.Library_Name; + end if; - Check_Illegal_Suffix - (Project, Separate_Suffix, - Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location, - Data); + if Lib_Dir.Default then + if not Project.Virtual then + Error_Msg + (Data.Flags, + "a project extending a library project must " & + "specify an attribute Library_Dir", + Project.Location, Project); + + else + -- For a virtual project extending a library project, + -- inherit library directory and library kind. + + Project.Library_Dir := Project.Extends.Library_Dir; + Library_Directory_Present := True; + Project.Library_Kind := Project.Extends.Library_Kind; + end if; + end if; end if; end if; + end if; - if Separate_Suffix /= No_File then - Write_Attr - ("Separate_Suffix", Get_Name_String (Separate_Suffix)); + pragma Assert (Lib_Name.Kind = Single); + + if Lib_Name.Value = Empty_String then + if Current_Verbosity = High + and then Project.Library_Name = No_Name + then + Debug_Indent; + Write_Line ("no library name"); end if; - end Check_Common; - ----------------------------------- - -- Process_Exceptions_File_Based -- - ----------------------------------- + else + -- There is no restriction on the syntax of library names - procedure Process_Exceptions_File_Based - (Lang_Id : Language_Ptr; - Kind : Source_Kind) - is - Lang : constant Name_Id := Lang_Id.Name; - Exceptions : Array_Element_Id; - Exception_List : Variable_Value; - Element_Id : String_List_Id; - Element : String_Element; - File_Name : File_Name_Type; - Source : Source_Id; + Project.Library_Name := Lib_Name.Value; + end if; - begin - case Kind is - when Impl | Sep => - Exceptions := - Value_Of - (Name_Implementation_Exceptions, - In_Arrays => Naming.Decl.Arrays, - Shared => Shared); + if Project.Library_Name /= No_Name then + if Current_Verbosity = High then + Write_Attr ("Library name: ", + Get_Name_String (Project.Library_Name)); + end if; - when Spec => - Exceptions := - Value_Of - (Name_Specification_Exceptions, - In_Arrays => Naming.Decl.Arrays, - Shared => Shared); - end case; - - Exception_List := - Value_Of - (Index => Lang, - In_Array => Exceptions, - Shared => Shared); - - if Exception_List /= Nil_Variable_Value then - Element_Id := Exception_List.Values; - while Element_Id /= Nil_String loop - Element := Shared.String_Elements.Table (Element_Id); - File_Name := Canonical_Case_File_Name (Element.Value); - - Source := - Source_Files_Htable.Get - (Data.Tree.Source_Files_HT, File_Name); - while Source /= No_Source - and then Source.Project /= Project - loop - Source := Source.Next_With_File_Name; - end loop; - - if Source = No_Source then - Add_Source - (Id => Source, - Data => Data, - Project => Project, - Source_Dir_Rank => 0, - Lang_Id => Lang_Id, - Kind => Kind, - File_Name => File_Name, - Display_File => File_Name_Type (Element.Value), - Naming_Exception => True, - Location => Element.Location); - - else - -- Check if the file name is already recorded for another - -- language or another kind. - - if Source.Language /= Lang_Id then - Error_Msg - (Data.Flags, - "the same file cannot be a source of two languages", - Element.Location, Project); - - elsif Source.Kind /= Kind then - Error_Msg - (Data.Flags, - "the same file cannot be a source and a template", - Element.Location, Project); - end if; - - -- If the file is already recorded for the same - -- language and the same kind, it means that the file - -- name appears several times in the *_Exceptions - -- attribute; so there is nothing to do. - end if; - - Element_Id := Element.Next; - end loop; - end if; - end Process_Exceptions_File_Based; - - ----------------------------------- - -- Process_Exceptions_Unit_Based -- - ----------------------------------- - - procedure Process_Exceptions_Unit_Based - (Lang_Id : Language_Ptr; - Kind : Source_Kind) - is - Exceptions : Array_Element_Id; - Element : Array_Element; - Unit : Name_Id; - Index : Int; - File_Name : File_Name_Type; - Source : Source_Id; - - begin - case Kind is - when Impl | Sep => - Exceptions := - Value_Of - (Name_Body, - In_Arrays => Naming.Decl.Arrays, - Shared => Shared); - - if Exceptions = No_Array_Element then - Exceptions := - Value_Of - (Name_Implementation, - In_Arrays => Naming.Decl.Arrays, - Shared => Shared); - end if; + pragma Assert (Lib_Dir.Kind = Single); - when Spec => - Exceptions := - Value_Of - (Name_Spec, - In_Arrays => Naming.Decl.Arrays, - Shared => Shared); + if not Library_Directory_Present then + Debug_Output ("no library directory"); - if Exceptions = No_Array_Element then - Exceptions := - Value_Of - (Name_Spec, - In_Arrays => Naming.Decl.Arrays, - Shared => Shared); - end if; - end case; + else + -- Find path name (unless inherited), check that it is a directory - while Exceptions /= No_Array_Element loop - Element := Shared.Array_Elements.Table (Exceptions); - File_Name := Canonical_Case_File_Name (Element.Value.Value); + if Project.Library_Dir = No_Path_Information then + Locate_Directory + (Project, + File_Name_Type (Lib_Dir.Value), + Path => Project.Library_Dir, + Dir_Exists => Dir_Exists, + Data => Data, + Create => "library", + Must_Exist => False, + Location => Lib_Dir.Location, + Externally_Built => Project.Externally_Built); - Get_Name_String (Element.Index); - To_Lower (Name_Buffer (1 .. Name_Len)); - Index := Element.Value.Index; + else + Dir_Exists := + Is_Directory + (Get_Name_String (Project.Library_Dir.Display_Name)); + end if; - -- Check if it is a valid unit name + if not Dir_Exists then - Get_Name_String (Element.Index); - Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit); + -- Get the absolute name of the library directory that + -- does not exist, to report an error. - if Unit = No_Name then - Err_Vars.Error_Msg_Name_1 := Element.Index; + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_Dir.Display_Name); Error_Msg (Data.Flags, - "%% is not a valid unit name.", - Element.Value.Location, Project); - end if; - - if Unit /= No_Name then - Add_Source - (Id => Source, - Data => Data, - Project => Project, - Source_Dir_Rank => 0, - Lang_Id => Lang_Id, - Kind => Kind, - File_Name => File_Name, - Display_File => File_Name_Type (Element.Value.Value), - Unit => Unit, - Index => Index, - Location => Element.Value.Location, - Naming_Exception => True); - end if; - - Exceptions := Element.Next; - end loop; - end Process_Exceptions_Unit_Based; - - ------------------ - -- Check_Naming -- - ------------------ + "library directory { does not exist", + Lib_Dir.Location, Project); - procedure Check_Naming is - Dot_Replacement : File_Name_Type := - File_Name_Type - (First_Name_Id + Character'Pos ('-')); - Separate_Suffix : File_Name_Type := No_File; - Casing : Casing_Type := All_Lower_Case; - Casing_Defined : Boolean; - Lang_Id : Language_Ptr; - Sep_Suffix_Loc : Source_Ptr; - Suffix : Variable_Value; - Lang : Name_Id; + elsif not Project.Externally_Built then - begin - Check_Common - (Dot_Replacement => Dot_Replacement, - Casing => Casing, - Casing_Defined => Casing_Defined, - Separate_Suffix => Separate_Suffix, - Sep_Suffix_Loc => Sep_Suffix_Loc); + -- Library directory cannot be the same as Object directory - -- For all unit based languages, if any, set the specified value - -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not - -- systematically overwrite, since the defaults come from the - -- configuration file. + if Project.Library_Dir.Name = Project.Object_Directory.Name then + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as object directory", + Lib_Dir.Location, Project); + Project.Library_Dir := No_Path_Information; - if Dot_Replacement /= No_File - or else Casing_Defined - or else Separate_Suffix /= No_File - then - Lang_Id := Project.Languages; - while Lang_Id /= No_Language_Index loop - if Lang_Id.Config.Kind = Unit_Based then - if Dot_Replacement /= No_File then - Lang_Id.Config.Naming_Data.Dot_Replacement := - Dot_Replacement; - end if; + else + declare + OK : Boolean := True; + Dirs_Id : String_List_Id; + Dir_Elem : String_Element; + Pid : Project_List; - if Casing_Defined then - Lang_Id.Config.Naming_Data.Casing := Casing; - end if; - end if; + begin + -- The library directory cannot be the same as a source + -- directory of the current project. - Lang_Id := Lang_Id.Next; - end loop; - end if; + Dirs_Id := Project.Source_Dirs; + while Dirs_Id /= Nil_String loop + Dir_Elem := Shared.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; - -- Next, get the spec and body suffixes + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as source directory {", + Lib_Dir.Location, Project); + OK := False; + exit; + end if; + end loop; - Lang_Id := Project.Languages; - while Lang_Id /= No_Language_Index loop - Lang := Lang_Id.Name; + if OK then - -- Spec_Suffix + -- The library directory cannot be the same as a + -- source directory of another project either. - Suffix := Value_Of - (Name => Lang, - Attribute_Or_Array_Name => Name_Spec_Suffix, - In_Package => Naming_Id, - Shared => Shared); + Pid := Data.Tree.Projects; + Project_Loop : loop + exit Project_Loop when Pid = null; - if Suffix = Nil_Variable_Value then - Suffix := Value_Of - (Name => Lang, - Attribute_Or_Array_Name => Name_Specification_Suffix, - In_Package => Naming_Id, - Shared => Shared); - end if; + if Pid.Project /= Project then + Dirs_Id := Pid.Project.Source_Dirs; - if Suffix /= Nil_Variable_Value then - Lang_Id.Config.Naming_Data.Spec_Suffix := - File_Name_Type (Suffix.Value); + Dir_Loop : while Dirs_Id /= Nil_String loop + Dir_Elem := + Shared.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; - Check_Illegal_Suffix - (Project, - Lang_Id.Config.Naming_Data.Spec_Suffix, - Lang_Id.Config.Naming_Data.Dot_Replacement, - "Spec_Suffix", Suffix.Location, Data); + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Err_Vars.Error_Msg_Name_1 := + Pid.Project.Name; - Write_Attr - ("Spec_Suffix", - Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix)); - end if; + Error_Msg + (Data.Flags, + "library directory cannot be the same" & + " as source directory { of project %%", + Lib_Dir.Location, Project); + OK := False; + exit Project_Loop; + end if; + end loop Dir_Loop; + end if; - -- Body_Suffix + Pid := Pid.Next; + end loop Project_Loop; + end if; - Suffix := - Value_Of - (Name => Lang, - Attribute_Or_Array_Name => Name_Body_Suffix, - In_Package => Naming_Id, - Shared => Shared); + if not OK then + Project.Library_Dir := No_Path_Information; - if Suffix = Nil_Variable_Value then - Suffix := - Value_Of - (Name => Lang, - Attribute_Or_Array_Name => Name_Implementation_Suffix, - In_Package => Naming_Id, - Shared => Shared); + elsif Current_Verbosity = High then + + -- Display the Library directory in high verbosity + + Write_Attr + ("Library directory", + Get_Name_String (Project.Library_Dir.Display_Name)); + end if; + end; + end if; end if; + end if; - if Suffix /= Nil_Variable_Value then - Lang_Id.Config.Naming_Data.Body_Suffix := - File_Name_Type (Suffix.Value); + end if; - -- The default value of separate suffix should be the same as - -- the body suffix, so we need to compute that first. + Project.Library := + Project.Library_Dir /= No_Path_Information + and then Project.Library_Name /= No_Name; - if Separate_Suffix = No_File then - Lang_Id.Config.Naming_Data.Separate_Suffix := - Lang_Id.Config.Naming_Data.Body_Suffix; - Write_Attr - ("Sep_Suffix", - Get_Name_String - (Lang_Id.Config.Naming_Data.Separate_Suffix)); - else - Lang_Id.Config.Naming_Data.Separate_Suffix := - Separate_Suffix; + if Project.Extends = No_Project then + case Project.Qualifier is + when Standard => + if Project.Library then + Error_Msg + (Data.Flags, + "a standard project cannot be a library project", + Lib_Name.Location, Project); end if; - Check_Illegal_Suffix - (Project, - Lang_Id.Config.Naming_Data.Body_Suffix, - Lang_Id.Config.Naming_Data.Dot_Replacement, - "Body_Suffix", Suffix.Location, Data); + when Library => + if not Project.Library then + if Project.Library_Name = No_Name then + Error_Msg + (Data.Flags, + "attribute Library_Name not declared", + Project.Location, Project); - Write_Attr - ("Body_Suffix", - Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)); + if not Library_Directory_Present then + Error_Msg + (Data.Flags, + "\attribute Library_Dir not declared", + Project.Location, Project); + end if; - elsif Separate_Suffix /= No_File then - Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; - end if; + elsif Project.Library_Dir = No_Path_Information then + Error_Msg + (Data.Flags, + "attribute Library_Dir not declared", + Project.Location, Project); + end if; + 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 by - -- matching the longest possible suffix. + when others => + null; - if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File - and then Lang_Id.Config.Naming_Data.Spec_Suffix = - Lang_Id.Config.Naming_Data.Body_Suffix - then - Error_Msg - (Data.Flags, - "Body_Suffix (""" - & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix) - & """) cannot be the same as Spec_Suffix.", - Ada_Body_Suffix_Loc, Project); - end if; + end case; + end if; - if Lang_Id.Config.Naming_Data.Body_Suffix /= - Lang_Id.Config.Naming_Data.Separate_Suffix - and then Lang_Id.Config.Naming_Data.Spec_Suffix = - Lang_Id.Config.Naming_Data.Separate_Suffix - then - Error_Msg - (Data.Flags, - "Separate_Suffix (""" - & Get_Name_String - (Lang_Id.Config.Naming_Data.Separate_Suffix) - & """) cannot be the same as Spec_Suffix.", - Sep_Suffix_Loc, Project); - end if; + if Project.Library then + Support_For_Libraries := Project.Config.Lib_Support; - Lang_Id := Lang_Id.Next; - end loop; + if Support_For_Libraries = Prj.None then + Error_Msg + (Data.Flags, + "?libraries are not supported on this platform", + Lib_Name.Location, Project); + Project.Library := False; - -- Get the naming exceptions for all languages + else + if Lib_ALI_Dir.Value = Empty_String then + Debug_Output ("no library ALI directory specified"); + Project.Library_ALI_Dir := Project.Library_Dir; - for Kind in Spec_Or_Body loop - Lang_Id := Project.Languages; - while Lang_Id /= No_Language_Index loop - case Lang_Id.Config.Kind is - when File_Based => - Process_Exceptions_File_Based (Lang_Id, Kind); + else + -- Find path name, check that it is a directory - when Unit_Based => - Process_Exceptions_Unit_Based (Lang_Id, Kind); - end case; + Locate_Directory + (Project, + File_Name_Type (Lib_ALI_Dir.Value), + Path => Project.Library_ALI_Dir, + Create => "library ALI", + Dir_Exists => Dir_Exists, + Data => Data, + Must_Exist => False, + Location => Lib_ALI_Dir.Location, + Externally_Built => Project.Externally_Built); - Lang_Id := Lang_Id.Next; - end loop; - end loop; - end Check_Naming; + if not Dir_Exists then - ---------------------------- - -- Initialize_Naming_Data -- - ---------------------------- + -- Get the absolute name of the library ALI directory that + -- does not exist, to report an error. - procedure Initialize_Naming_Data is - Specs : Array_Element_Id := - Util.Value_Of - (Name_Spec_Suffix, - Naming.Decl.Arrays, - Shared); + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_ALI_Dir.Display_Name); + Error_Msg + (Data.Flags, + "library 'A'L'I directory { does not exist", + Lib_ALI_Dir.Location, Project); + end if; - Impls : Array_Element_Id := - Util.Value_Of - (Name_Body_Suffix, - Naming.Decl.Arrays, - Shared); + if (not Project.Externally_Built) and then + Project.Library_ALI_Dir /= Project.Library_Dir + then + -- The library ALI directory cannot be the same as the + -- Object directory. - Lang : Language_Ptr; - Lang_Name : Name_Id; - Value : Variable_Value; - Extended : Project_Id; + if Project.Library_ALI_Dir = Project.Object_Directory then + Error_Msg + (Data.Flags, + "library 'A'L'I directory cannot be the same " & + "as object directory", + Lib_ALI_Dir.Location, Project); + Project.Library_ALI_Dir := No_Path_Information; - 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. + else + declare + OK : Boolean := True; + Dirs_Id : String_List_Id; + Dir_Elem : String_Element; + Pid : Project_List; - while Specs /= No_Array_Element loop - Lang_Name := Shared.Array_Elements.Table (Specs).Index; - Lang := - Get_Language_From_Name - (Project, Name => Get_Name_String (Lang_Name)); + begin + -- The library ALI directory cannot be the same as + -- a source directory of the current project. - -- An extending project inherits its parent projects' languages - -- so if needed we should create entries for those languages + Dirs_Id := Project.Source_Dirs; + while Dirs_Id /= Nil_String loop + Dir_Elem := Shared.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; - if Lang = null then - Extended := Project.Extends; - while Extended /= null loop - Lang := Get_Language_From_Name - (Extended, Name => Get_Name_String (Lang_Name)); - exit when Lang /= null; + if Project.Library_ALI_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Error_Msg + (Data.Flags, + "library 'A'L'I directory cannot be " & + "the same as source directory {", + Lib_ALI_Dir.Location, Project); + OK := False; + exit; + end if; + end loop; - Extended := Extended.Extends; - end loop; + if OK then - if Lang /= null then - Lang := new Language_Data'(Lang.all); - Lang.First_Source := null; - Lang.Next := Project.Languages; - Project.Languages := Lang; - end if; - end if; + -- The library ALI directory cannot be the same as + -- a source directory of another project either. - -- If language was not found in project or the projects it extends + Pid := Data.Tree.Projects; + ALI_Project_Loop : loop + exit ALI_Project_Loop when Pid = null; - if Lang = null then - Debug_Output - ("ignoring spec naming data (lang. not in project): ", - Lang_Name); + if Pid.Project /= Project then + Dirs_Id := Pid.Project.Source_Dirs; - else - Value := Shared.Array_Elements.Table (Specs).Value; + ALI_Dir_Loop : + while Dirs_Id /= Nil_String loop + Dir_Elem := + Shared.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; - if Value.Kind = Single then - Lang.Config.Naming_Data.Spec_Suffix := - Canonical_Case_File_Name (Value.Value); - end if; - end if; + if Project.Library_ALI_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Err_Vars.Error_Msg_Name_1 := + Pid.Project.Name; - Specs := Shared.Array_Elements.Table (Specs).Next; - end loop; + Error_Msg + (Data.Flags, + "library 'A'L'I directory cannot " & + "be the same as source directory " & + "{ of project %%", + Lib_ALI_Dir.Location, Project); + OK := False; + exit ALI_Project_Loop; + end if; + end loop ALI_Dir_Loop; + end if; + Pid := Pid.Next; + end loop ALI_Project_Loop; + end if; - while Impls /= No_Array_Element loop - Lang_Name := Shared.Array_Elements.Table (Impls).Index; - Lang := - Get_Language_From_Name - (Project, Name => Get_Name_String (Lang_Name)); + if not OK then + Project.Library_ALI_Dir := No_Path_Information; - if Lang = null then - Debug_Output - ("ignoring impl naming data (lang. not in project): ", - Lang_Name); - else - Value := Shared.Array_Elements.Table (Impls).Value; + elsif Current_Verbosity = High then - if Lang.Name = Name_Ada then - Ada_Body_Suffix_Loc := Value.Location; - end if; + -- Display Library ALI directory in high verbosity - if Value.Kind = Single then - Lang.Config.Naming_Data.Body_Suffix := - Canonical_Case_File_Name (Value.Value); + Write_Attr + ("Library ALI dir", + Get_Name_String + (Project.Library_ALI_Dir.Display_Name)); + end if; + end; + end if; end if; end if; - Impls := Shared.Array_Elements.Table (Impls).Next; - end loop; - end Initialize_Naming_Data; - - -- Start of processing for Check_Naming_Schemes - - begin - -- No Naming package or parsing a configuration file? nothing to do + pragma Assert (Lib_Version.Kind = Single); - if Naming_Id /= No_Package - and then Project.Qualifier /= Configuration - then - Naming := Shared.Packages.Table (Naming_Id); - Debug_Increase_Indent ("checking package Naming for ", Project.Name); - Initialize_Naming_Data; - Check_Naming; - Debug_Decrease_Indent ("done checking package naming"); - end if; - end Check_Package_Naming; + if Lib_Version.Value = Empty_String then + Debug_Output ("no library version specified"); - ------------------------------ - -- Check_Library_Attributes -- - ------------------------------ + else + Project.Lib_Internal_Name := Lib_Version.Value; + end if; - procedure Check_Library_Attributes - (Project : Project_Id; - Data : in out Tree_Processing_Data) - is - Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; + pragma Assert (The_Lib_Kind.Kind = Single); - Attributes : constant Prj.Variable_Id := Project.Decl.Attributes; + if The_Lib_Kind.Value = Empty_String then + Debug_Output ("no library kind specified"); - Lib_Dir : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Dir, Attributes, Shared); + else + Get_Name_String (The_Lib_Kind.Value); - Lib_Name : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Name, Attributes, Shared); + declare + Kind_Name : constant String := + To_Lower (Name_Buffer (1 .. Name_Len)); - Lib_Version : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Version, Attributes, Shared); + OK : Boolean := True; - Lib_ALI_Dir : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Ali_Dir, Attributes, Shared); + begin + if Kind_Name = "static" then + Project.Library_Kind := Static; - Lib_GCC : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_GCC, Attributes, Shared); + elsif Kind_Name = "dynamic" then + Project.Library_Kind := Dynamic; - The_Lib_Kind : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Kind, Attributes, Shared); + elsif Kind_Name = "relocatable" then + Project.Library_Kind := Relocatable; - Imported_Project_List : Project_List; + else + Error_Msg + (Data.Flags, + "illegal value for Library_Kind", + The_Lib_Kind.Location, Project); + OK := False; + end if; - Continuation : String_Access := No_Continuation_String'Access; + if Current_Verbosity = High and then OK then + Write_Attr ("Library kind", Kind_Name); + end if; - Support_For_Libraries : Library_Support; + if Project.Library_Kind /= Static then + if Support_For_Libraries = Prj.Static_Only then + Error_Msg + (Data.Flags, + "only static libraries are supported " & + "on this platform", + The_Lib_Kind.Location, Project); + Project.Library := False; - Library_Directory_Present : Boolean; + else + -- Check if (obsolescent) attribute Library_GCC or + -- Linker'Driver is declared. - procedure Check_Library (Proj : Project_Id; Extends : Boolean); - -- Check if an imported or extended project if also a library project + if Lib_GCC.Value /= Empty_String then + Error_Msg + (Data.Flags, + "?Library_'G'C'C is an obsolescent attribute, " & + "use Linker''Driver instead", + Lib_GCC.Location, Project); + Project.Config.Shared_Lib_Driver := + File_Name_Type (Lib_GCC.Value); - ------------------- - -- Check_Library -- - ------------------- + else + declare + Linker : constant Package_Id := + Value_Of + (Name_Linker, + Project.Decl.Packages, + Shared); + Driver : constant Variable_Value := + Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Driver, + In_Package => Linker, + Shared => Shared); - procedure Check_Library (Proj : Project_Id; Extends : Boolean) is - Src_Id : Source_Id; - Iter : Source_Iterator; + begin + if Driver /= Nil_Variable_Value + and then Driver.Value /= Empty_String + then + Project.Config.Shared_Lib_Driver := + File_Name_Type (Driver.Value); + end if; + end; + end if; + end if; + end if; + end; + end if; - begin - if Proj /= No_Project then - if not Proj.Library then + if Project.Library then + Debug_Output ("this is a library project file"); - -- The only not library projects that are OK are those that - -- have no sources. However, header files from non-Ada - -- languages are OK, as there is nothing to compile. + Check_Library (Project.Extends, Extends => True); - Iter := For_Each_Source (Data.Tree, Proj); - loop - Src_Id := Prj.Element (Iter); - exit when Src_Id = No_Source - or else Src_Id.Language.Config.Kind /= File_Based - or else Src_Id.Kind /= Spec; - Next (Iter); + Imported_Project_List := Project.Imported_Projects; + while Imported_Project_List /= null loop + Check_Library + (Imported_Project_List.Project, + Extends => False); + Imported_Project_List := Imported_Project_List.Next; end loop; + end if; - if Src_Id /= No_Source then - Error_Msg_Name_1 := Project.Name; - Error_Msg_Name_2 := Proj.Name; + end if; + end if; - if Extends then - if Project.Library_Kind /= Static then - Error_Msg - (Data.Flags, - Continuation.all & - "shared library project %% cannot extend " & - "project %% that is not a library project", - Project.Location, Project); - Continuation := Continuation_String'Access; - end if; + -- Check if Linker'Switches or Linker'Default_Switches are declared. + -- Warn if they are declared, as it is a common error to think that + -- library are "linked" with Linker switches. - elsif (not Unchecked_Shared_Lib_Imports) - and then Project.Library_Kind /= Static - then - Error_Msg - (Data.Flags, - Continuation.all & - "shared library project %% cannot import project %% " & - "that is not a shared library project", - Project.Location, Project); - Continuation := Continuation_String'Access; - end if; - end if; + if Project.Library then + declare + Linker_Package_Id : constant Package_Id := + Util.Value_Of + (Name_Linker, + Project.Decl.Packages, Shared); + Linker_Package : Package_Element; + Switches : Array_Element_Id := No_Array_Element; - elsif Project.Library_Kind /= Static and then - Proj.Library_Kind = Static - then - Error_Msg_Name_1 := Project.Name; - Error_Msg_Name_2 := Proj.Name; + begin + if Linker_Package_Id /= No_Package then + Linker_Package := Shared.Packages.Table (Linker_Package_Id); - if Extends then - Error_Msg - (Data.Flags, - Continuation.all & - "shared library project %% cannot extend static " & - "library project %%", - Project.Location, Project); - Continuation := Continuation_String'Access; + Switches := + Value_Of + (Name => Name_Switches, + In_Arrays => Linker_Package.Decl.Arrays, + Shared => Shared); - elsif not Unchecked_Shared_Lib_Imports then + if Switches = No_Array_Element then + Switches := + Value_Of + (Name => Name_Default_Switches, + In_Arrays => Linker_Package.Decl.Arrays, + Shared => Shared); + end if; + + if Switches /= No_Array_Element then Error_Msg (Data.Flags, - Continuation.all & - "shared library project %% cannot import static " & - "library project %%", - Project.Location, Project); - Continuation := Continuation_String'Access; + "?Linker switches not taken into account in library " & + "projects", + No_Location, Project); end if; - end if; - end if; - end Check_Library; - - Dir_Exists : Boolean; + end; + end if; - -- Start of processing for Check_Library_Attributes + if Project.Extends /= No_Project and then Project.Extends.Library then - begin - Library_Directory_Present := Lib_Dir.Value /= Empty_String; + -- Remove the library name from Lib_Data_Table - -- Special case of extending project + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Proj = Project.Extends then + Lib_Data_Table.Table (J) := + Lib_Data_Table.Table (Lib_Data_Table.Last); + Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); + exit; + end if; + end loop; + end if; - if Project.Extends /= No_Project then + if Project.Library and then not Lib_Name.Default then - -- If the project extended is a library project, we inherit the - -- library name, if it is not redefined; we check that the library - -- directory is specified. + -- Check if the same library name is used in an other library project - if Project.Extends.Library then - if Project.Qualifier = Standard then + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Name = Project.Library_Name then + Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; Error_Msg (Data.Flags, - "a standard project cannot extend a library project", - Project.Location, Project); - - else - if Lib_Name.Default then - Project.Library_Name := Project.Extends.Library_Name; - end if; + "Library name cannot be the same as in project %%", + Lib_Name.Location, Project); + Project.Library := False; + exit; + end if; + end loop; + end if; - if Lib_Dir.Default then - if not Project.Virtual then - Error_Msg - (Data.Flags, - "a project extending a library project must " & - "specify an attribute Library_Dir", - Project.Location, Project); + if Project.Library then - else - -- For a virtual project extending a library project, - -- inherit library directory and library kind. + -- Record the library name - Project.Library_Dir := Project.Extends.Library_Dir; - Library_Directory_Present := True; - Project.Library_Kind := Project.Extends.Library_Kind; - end if; - end if; - end if; - end if; + Lib_Data_Table.Append + ((Name => Project.Library_Name, Proj => Project)); end if; + end Check_Library_Attributes; - pragma Assert (Lib_Name.Kind = Single); + -------------------------- + -- Check_Package_Naming -- + -------------------------- - if Lib_Name.Value = Empty_String then - if Current_Verbosity = High - and then Project.Library_Name = No_Name - then - Debug_Indent; - Write_Line ("no library name"); - end if; + procedure Check_Package_Naming + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; + Naming_Id : constant Package_Id := + Util.Value_Of + (Name_Naming, Project.Decl.Packages, Shared); + Naming : Package_Element; - else - -- There is no restriction on the syntax of library names + Ada_Body_Suffix_Loc : Source_Ptr := No_Location; - Project.Library_Name := Lib_Name.Value; - end if; + procedure Check_Naming; + -- Check the validity of the Naming package (suffixes valid, ...) - if Project.Library_Name /= No_Name then - if Current_Verbosity = High then - Write_Attr ("Library name: ", - Get_Name_String (Project.Library_Name)); - end if; + procedure Check_Common + (Dot_Replacement : in out File_Name_Type; + Casing : in out Casing_Type; + Casing_Defined : out Boolean; + Separate_Suffix : in out File_Name_Type; + Sep_Suffix_Loc : out Source_Ptr); + -- Check attributes common - pragma Assert (Lib_Dir.Kind = Single); + procedure Process_Exceptions_File_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind); + procedure Process_Exceptions_Unit_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind); + -- Process the naming exceptions for the two types of languages - if not Library_Directory_Present then - Debug_Output ("no library directory"); + procedure Initialize_Naming_Data; + -- Initialize internal naming data for the various languages - else - -- Find path name (unless inherited), check that it is a directory + ------------------ + -- Check_Common -- + ------------------ - if Project.Library_Dir = No_Path_Information then - Locate_Directory - (Project, - File_Name_Type (Lib_Dir.Value), - Path => Project.Library_Dir, - Dir_Exists => Dir_Exists, - Data => Data, - Create => "library", - Must_Exist => False, - Location => Lib_Dir.Location, - Externally_Built => Project.Externally_Built); + procedure Check_Common + (Dot_Replacement : in out File_Name_Type; + Casing : in out Casing_Type; + Casing_Defined : out Boolean; + Separate_Suffix : in out File_Name_Type; + Sep_Suffix_Loc : out Source_Ptr) + is + Dot_Repl : constant Variable_Value := + Util.Value_Of + (Name_Dot_Replacement, + Naming.Decl.Attributes, + Shared); + Casing_String : constant Variable_Value := + Util.Value_Of + (Name_Casing, + Naming.Decl.Attributes, + Shared); + Sep_Suffix : constant Variable_Value := + Util.Value_Of + (Name_Separate_Suffix, + Naming.Decl.Attributes, + Shared); + Dot_Repl_Loc : Source_Ptr; - else - Dir_Exists := - Is_Directory - (Get_Name_String - (Project.Library_Dir.Display_Name)); + begin + Sep_Suffix_Loc := No_Location; + + if not Dot_Repl.Default then + pragma Assert + (Dot_Repl.Kind = Single, "Dot_Replacement is not a string"); + + if Length_Of_Name (Dot_Repl.Value) = 0 then + Error_Msg + (Data.Flags, "Dot_Replacement cannot be empty", + Dot_Repl.Location, Project); end if; - if not Dir_Exists then + Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); + Dot_Repl_Loc := Dot_Repl.Location; - -- Get the absolute name of the library directory that - -- does not exist, to report an error. + declare + Repl : constant String := Get_Name_String (Dot_Replacement); + + begin + -- Dot_Replacement cannot + -- - be empty + -- - start or end with an alphanumeric + -- - be a single '_' + -- - start with an '_' followed by an alphanumeric + -- - contain a '.' except if it is "." + + if Repl'Length = 0 + or else Is_Alphanumeric (Repl (Repl'First)) + or else Is_Alphanumeric (Repl (Repl'Last)) + or else (Repl (Repl'First) = '_' + and then + (Repl'Length = 1 + or else + Is_Alphanumeric (Repl (Repl'First + 1)))) + or else (Repl'Length > 1 + and then + Index (Source => Repl, Pattern => ".") /= 0) + then + Error_Msg + (Data.Flags, + '"' & Repl & + """ is illegal for Dot_Replacement.", + Dot_Repl_Loc, Project); + end if; + end; + end if; + + if Dot_Replacement /= No_File then + Write_Attr + ("Dot_Replacement", Get_Name_String (Dot_Replacement)); + end if; - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Project.Library_Dir.Display_Name); - Error_Msg - (Data.Flags, - "library directory { does not exist", - Lib_Dir.Location, Project); + Casing_Defined := False; - elsif not Project.Externally_Built then + if not Casing_String.Default then + pragma Assert + (Casing_String.Kind = Single, "Casing is not a string"); - -- The library directory cannot be the same as the Object - -- directory. + declare + Casing_Image : constant String := + Get_Name_String (Casing_String.Value); - if Project.Library_Dir.Name = Project.Object_Directory.Name then + begin + if Casing_Image'Length = 0 then Error_Msg (Data.Flags, - "library directory cannot be the same " & - "as object directory", - Lib_Dir.Location, Project); - Project.Library_Dir := No_Path_Information; + "Casing cannot be an empty string", + Casing_String.Location, Project); + end if; - else - declare - OK : Boolean := True; - Dirs_Id : String_List_Id; - Dir_Elem : String_Element; - Pid : Project_List; + Casing := Value (Casing_Image); + Casing_Defined := True; - begin - -- The library directory cannot be the same as a source - -- directory of the current project. + exception + when Constraint_Error => + Name_Len := Casing_Image'Length; + Name_Buffer (1 .. Name_Len) := Casing_Image; + Err_Vars.Error_Msg_Name_1 := Name_Find; + Error_Msg + (Data.Flags, + "%% is not a correct Casing", + Casing_String.Location, Project); + end; + end if; - Dirs_Id := Project.Source_Dirs; - while Dirs_Id /= Nil_String loop - Dir_Elem := Shared.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; + Write_Attr ("Casing", Image (Casing)); - if Project.Library_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as source directory {", - Lib_Dir.Location, Project); - OK := False; - exit; - end if; - end loop; + if not Sep_Suffix.Default then + if Length_Of_Name (Sep_Suffix.Value) = 0 then + Error_Msg + (Data.Flags, + "Separate_Suffix cannot be empty", + Sep_Suffix.Location, Project); - if OK then + else + Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); + Sep_Suffix_Loc := Sep_Suffix.Location; - -- The library directory cannot be the same as a - -- source directory of another project either. + Check_Illegal_Suffix + (Project, Separate_Suffix, + Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location, + Data); + end if; + end if; - Pid := Data.Tree.Projects; - Project_Loop : loop - exit Project_Loop when Pid = null; + if Separate_Suffix /= No_File then + Write_Attr + ("Separate_Suffix", Get_Name_String (Separate_Suffix)); + end if; + end Check_Common; - if Pid.Project /= Project then - Dirs_Id := Pid.Project.Source_Dirs; + ----------------------------------- + -- Process_Exceptions_File_Based -- + ----------------------------------- - Dir_Loop : while Dirs_Id /= Nil_String loop - Dir_Elem := - Shared.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; + procedure Process_Exceptions_File_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind) + is + Lang : constant Name_Id := Lang_Id.Name; + Exceptions : Array_Element_Id; + Exception_List : Variable_Value; + Element_Id : String_List_Id; + Element : String_Element; + File_Name : File_Name_Type; + Source : Source_Id; - if Project.Library_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Err_Vars.Error_Msg_Name_1 := - Pid.Project.Name; + begin + case Kind is + when Impl | Sep => + Exceptions := + Value_Of + (Name_Implementation_Exceptions, + In_Arrays => Naming.Decl.Arrays, + Shared => Shared); - Error_Msg - (Data.Flags, - "library directory cannot be the same" & - " as source directory { of project %%", - Lib_Dir.Location, Project); - OK := False; - exit Project_Loop; - end if; - end loop Dir_Loop; - end if; + when Spec => + Exceptions := + Value_Of + (Name_Specification_Exceptions, + In_Arrays => Naming.Decl.Arrays, + Shared => Shared); + end case; - Pid := Pid.Next; - end loop Project_Loop; - end if; + Exception_List := + Value_Of + (Index => Lang, + In_Array => Exceptions, + Shared => Shared); - if not OK then - Project.Library_Dir := No_Path_Information; + if Exception_List /= Nil_Variable_Value then + Element_Id := Exception_List.Values; + while Element_Id /= Nil_String loop + Element := Shared.String_Elements.Table (Element_Id); + File_Name := Canonical_Case_File_Name (Element.Value); - elsif Current_Verbosity = High then + Source := + Source_Files_Htable.Get + (Data.Tree.Source_Files_HT, File_Name); + while Source /= No_Source + and then Source.Project /= Project + loop + Source := Source.Next_With_File_Name; + end loop; - -- Display the Library directory in high verbosity + if Source = No_Source then + Add_Source + (Id => Source, + Data => Data, + Project => Project, + Source_Dir_Rank => 0, + Lang_Id => Lang_Id, + Kind => Kind, + File_Name => File_Name, + Display_File => File_Name_Type (Element.Value), + Naming_Exception => True, + Location => Element.Location); - Write_Attr - ("Library directory", - Get_Name_String (Project.Library_Dir.Display_Name)); - end if; - end; - end if; - end if; - end if; + else + -- Check if the file name is already recorded for another + -- language or another kind. - end if; + if Source.Language /= Lang_Id then + Error_Msg + (Data.Flags, + "the same file cannot be a source of two languages", + Element.Location, Project); - Project.Library := - Project.Library_Dir /= No_Path_Information - and then Project.Library_Name /= No_Name; + elsif Source.Kind /= Kind then + Error_Msg + (Data.Flags, + "the same file cannot be a source and a template", + Element.Location, Project); + end if; - if Project.Extends = No_Project then - case Project.Qualifier is - when Standard => - if Project.Library then - Error_Msg - (Data.Flags, - "a standard project cannot be a library project", - Lib_Name.Location, Project); + -- If the file is already recorded for the same + -- language and the same kind, it means that the file + -- name appears several times in the *_Exceptions + -- attribute; so there is nothing to do. end if; - when Library => - if not Project.Library then - if Project.Library_Name = No_Name then - Error_Msg - (Data.Flags, - "attribute Library_Name not declared", - Project.Location, Project); + Element_Id := Element.Next; + end loop; + end if; + end Process_Exceptions_File_Based; - if not Library_Directory_Present then - Error_Msg - (Data.Flags, - "\attribute Library_Dir not declared", - Project.Location, Project); - end if; + ----------------------------------- + -- Process_Exceptions_Unit_Based -- + ----------------------------------- + + procedure Process_Exceptions_Unit_Based + (Lang_Id : Language_Ptr; + Kind : Source_Kind) + is + Exceptions : Array_Element_Id; + Element : Array_Element; + Unit : Name_Id; + Index : Int; + File_Name : File_Name_Type; + Source : Source_Id; + + begin + case Kind is + when Impl | Sep => + Exceptions := + Value_Of + (Name_Body, + In_Arrays => Naming.Decl.Arrays, + Shared => Shared); - elsif Project.Library_Dir = No_Path_Information then - Error_Msg - (Data.Flags, - "attribute Library_Dir not declared", - Project.Location, Project); - end if; + if Exceptions = No_Array_Element then + Exceptions := + Value_Of + (Name_Implementation, + In_Arrays => Naming.Decl.Arrays, + Shared => Shared); end if; - when others => - null; + when Spec => + Exceptions := + Value_Of + (Name_Spec, + In_Arrays => Naming.Decl.Arrays, + Shared => Shared); + if Exceptions = No_Array_Element then + Exceptions := + Value_Of + (Name_Spec, + In_Arrays => Naming.Decl.Arrays, + Shared => Shared); + end if; end case; - end if; - - if Project.Library then - Support_For_Libraries := Project.Config.Lib_Support; - - if Support_For_Libraries = Prj.None then - Error_Msg - (Data.Flags, - "?libraries are not supported on this platform", - Lib_Name.Location, Project); - Project.Library := False; - else - if Lib_ALI_Dir.Value = Empty_String then - Debug_Output ("no library ALI directory specified"); - Project.Library_ALI_Dir := Project.Library_Dir; - - else - -- Find path name, check that it is a directory + while Exceptions /= No_Array_Element loop + Element := Shared.Array_Elements.Table (Exceptions); + File_Name := Canonical_Case_File_Name (Element.Value.Value); - Locate_Directory - (Project, - File_Name_Type (Lib_ALI_Dir.Value), - Path => Project.Library_ALI_Dir, - Create => "library ALI", - Dir_Exists => Dir_Exists, - Data => Data, - Must_Exist => False, - Location => Lib_ALI_Dir.Location, - Externally_Built => Project.Externally_Built); + Get_Name_String (Element.Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + Index := Element.Value.Index; - if not Dir_Exists then + -- Check if it is a valid unit name - -- Get the absolute name of the library ALI directory that - -- does not exist, to report an error. + Get_Name_String (Element.Index); + Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit); - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Project.Library_ALI_Dir.Display_Name); - Error_Msg - (Data.Flags, - "library 'A'L'I directory { does not exist", - Lib_ALI_Dir.Location, Project); - end if; + if Unit = No_Name then + Err_Vars.Error_Msg_Name_1 := Element.Index; + Error_Msg + (Data.Flags, + "%% is not a valid unit name.", + Element.Value.Location, Project); + end if; - if (not Project.Externally_Built) and then - Project.Library_ALI_Dir /= Project.Library_Dir - then - -- The library ALI directory cannot be the same as the - -- Object directory. + if Unit /= No_Name then + Add_Source + (Id => Source, + Data => Data, + Project => Project, + Source_Dir_Rank => 0, + Lang_Id => Lang_Id, + Kind => Kind, + File_Name => File_Name, + Display_File => File_Name_Type (Element.Value.Value), + Unit => Unit, + Index => Index, + Location => Element.Value.Location, + Naming_Exception => True); + end if; - if Project.Library_ALI_Dir = Project.Object_Directory then - Error_Msg - (Data.Flags, - "library 'A'L'I directory cannot be the same " & - "as object directory", - Lib_ALI_Dir.Location, Project); - Project.Library_ALI_Dir := No_Path_Information; + Exceptions := Element.Next; + end loop; + end Process_Exceptions_Unit_Based; - else - declare - OK : Boolean := True; - Dirs_Id : String_List_Id; - Dir_Elem : String_Element; - Pid : Project_List; + ------------------ + -- Check_Naming -- + ------------------ - begin - -- The library ALI directory cannot be the same as - -- a source directory of the current project. + procedure Check_Naming is + Dot_Replacement : File_Name_Type := + File_Name_Type + (First_Name_Id + Character'Pos ('-')); + Separate_Suffix : File_Name_Type := No_File; + Casing : Casing_Type := All_Lower_Case; + Casing_Defined : Boolean; + Lang_Id : Language_Ptr; + Sep_Suffix_Loc : Source_Ptr; + Suffix : Variable_Value; + Lang : Name_Id; - Dirs_Id := Project.Source_Dirs; - while Dirs_Id /= Nil_String loop - Dir_Elem := Shared.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; + begin + Check_Common + (Dot_Replacement => Dot_Replacement, + Casing => Casing, + Casing_Defined => Casing_Defined, + Separate_Suffix => Separate_Suffix, + Sep_Suffix_Loc => Sep_Suffix_Loc); - if Project.Library_ALI_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Error_Msg - (Data.Flags, - "library 'A'L'I directory cannot be " & - "the same as source directory {", - Lib_ALI_Dir.Location, Project); - OK := False; - exit; - end if; - end loop; + -- For all unit based languages, if any, set the specified value + -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not + -- systematically overwrite, since the defaults come from the + -- configuration file. - if OK then + if Dot_Replacement /= No_File + or else Casing_Defined + or else Separate_Suffix /= No_File + then + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + if Lang_Id.Config.Kind = Unit_Based then + if Dot_Replacement /= No_File then + Lang_Id.Config.Naming_Data.Dot_Replacement := + Dot_Replacement; + end if; - -- The library ALI directory cannot be the same as - -- a source directory of another project either. + if Casing_Defined then + Lang_Id.Config.Naming_Data.Casing := Casing; + end if; + end if; - Pid := Data.Tree.Projects; - ALI_Project_Loop : loop - exit ALI_Project_Loop when Pid = null; + Lang_Id := Lang_Id.Next; + end loop; + end if; - if Pid.Project /= Project then - Dirs_Id := Pid.Project.Source_Dirs; + -- Next, get the spec and body suffixes - ALI_Dir_Loop : - while Dirs_Id /= Nil_String loop - Dir_Elem := - Shared.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + Lang := Lang_Id.Name; - if Project.Library_ALI_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Err_Vars.Error_Msg_Name_1 := - Pid.Project.Name; + -- Spec_Suffix - Error_Msg - (Data.Flags, - "library 'A'L'I directory cannot " & - "be the same as source directory " & - "{ of project %%", - Lib_ALI_Dir.Location, Project); - OK := False; - exit ALI_Project_Loop; - end if; - end loop ALI_Dir_Loop; - end if; - Pid := Pid.Next; - end loop ALI_Project_Loop; - end if; + Suffix := Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Spec_Suffix, + In_Package => Naming_Id, + Shared => Shared); - if not OK then - Project.Library_ALI_Dir := No_Path_Information; + if Suffix = Nil_Variable_Value then + Suffix := Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Specification_Suffix, + In_Package => Naming_Id, + Shared => Shared); + end if; - elsif Current_Verbosity = High then + if Suffix /= Nil_Variable_Value then + Lang_Id.Config.Naming_Data.Spec_Suffix := + File_Name_Type (Suffix.Value); - -- Display Library ALI directory in high verbosity + Check_Illegal_Suffix + (Project, + Lang_Id.Config.Naming_Data.Spec_Suffix, + Lang_Id.Config.Naming_Data.Dot_Replacement, + "Spec_Suffix", Suffix.Location, Data); - Write_Attr - ("Library ALI dir", - Get_Name_String - (Project.Library_ALI_Dir.Display_Name)); - end if; - end; - end if; - end if; + Write_Attr + ("Spec_Suffix", + Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix)); end if; - pragma Assert (Lib_Version.Kind = Single); + -- Body_Suffix - if Lib_Version.Value = Empty_String then - Debug_Output ("no library version specified"); + Suffix := + Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Body_Suffix, + In_Package => Naming_Id, + Shared => Shared); - else - Project.Lib_Internal_Name := Lib_Version.Value; + if Suffix = Nil_Variable_Value then + Suffix := + Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Implementation_Suffix, + In_Package => Naming_Id, + Shared => Shared); end if; - pragma Assert (The_Lib_Kind.Kind = Single); - - if The_Lib_Kind.Value = Empty_String then - Debug_Output ("no library kind specified"); + if Suffix /= Nil_Variable_Value then + Lang_Id.Config.Naming_Data.Body_Suffix := + File_Name_Type (Suffix.Value); - else - Get_Name_String (The_Lib_Kind.Value); + -- The default value of separate suffix should be the same as + -- the body suffix, so we need to compute that first. - declare - Kind_Name : constant String := - To_Lower (Name_Buffer (1 .. Name_Len)); + if Separate_Suffix = No_File then + Lang_Id.Config.Naming_Data.Separate_Suffix := + Lang_Id.Config.Naming_Data.Body_Suffix; + Write_Attr + ("Sep_Suffix", + Get_Name_String + (Lang_Id.Config.Naming_Data.Separate_Suffix)); + else + Lang_Id.Config.Naming_Data.Separate_Suffix := + Separate_Suffix; + end if; - OK : Boolean := True; + Check_Illegal_Suffix + (Project, + Lang_Id.Config.Naming_Data.Body_Suffix, + Lang_Id.Config.Naming_Data.Dot_Replacement, + "Body_Suffix", Suffix.Location, Data); - begin - if Kind_Name = "static" then - Project.Library_Kind := Static; + Write_Attr + ("Body_Suffix", + Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)); - elsif Kind_Name = "dynamic" then - Project.Library_Kind := Dynamic; + elsif Separate_Suffix /= No_File then + Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; + end if; - elsif Kind_Name = "relocatable" then - Project.Library_Kind := Relocatable; + -- 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 by + -- matching the longest possible suffix. - else - Error_Msg - (Data.Flags, - "illegal value for Library_Kind", - The_Lib_Kind.Location, Project); - OK := False; - end if; + if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File + and then Lang_Id.Config.Naming_Data.Spec_Suffix = + Lang_Id.Config.Naming_Data.Body_Suffix + then + Error_Msg + (Data.Flags, + "Body_Suffix (""" + & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix) + & """) cannot be the same as Spec_Suffix.", + Ada_Body_Suffix_Loc, Project); + end if; - if Current_Verbosity = High and then OK then - Write_Attr ("Library kind", Kind_Name); - end if; + if Lang_Id.Config.Naming_Data.Body_Suffix /= + Lang_Id.Config.Naming_Data.Separate_Suffix + and then Lang_Id.Config.Naming_Data.Spec_Suffix = + Lang_Id.Config.Naming_Data.Separate_Suffix + then + Error_Msg + (Data.Flags, + "Separate_Suffix (""" + & Get_Name_String + (Lang_Id.Config.Naming_Data.Separate_Suffix) + & """) cannot be the same as Spec_Suffix.", + Sep_Suffix_Loc, Project); + end if; - if Project.Library_Kind /= Static then - if Support_For_Libraries = Prj.Static_Only then - Error_Msg - (Data.Flags, - "only static libraries are supported " & - "on this platform", - The_Lib_Kind.Location, Project); - Project.Library := False; + Lang_Id := Lang_Id.Next; + end loop; - else - -- Check if (obsolescent) attribute Library_GCC or - -- Linker'Driver is declared. + -- Get the naming exceptions for all languages - if Lib_GCC.Value /= Empty_String then - Error_Msg - (Data.Flags, - "?Library_'G'C'C is an obsolescent attribute, " & - "use Linker''Driver instead", - Lib_GCC.Location, Project); - Project.Config.Shared_Lib_Driver := - File_Name_Type (Lib_GCC.Value); + for Kind in Spec_Or_Body loop + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + case Lang_Id.Config.Kind is + when File_Based => + Process_Exceptions_File_Based (Lang_Id, Kind); - else - declare - Linker : constant Package_Id := - Value_Of - (Name_Linker, - Project.Decl.Packages, - Shared); - Driver : constant Variable_Value := - Value_Of - (Name => No_Name, - Attribute_Or_Array_Name => - Name_Driver, - In_Package => Linker, - Shared => Shared); + when Unit_Based => + Process_Exceptions_Unit_Based (Lang_Id, Kind); + end case; - begin - if Driver /= Nil_Variable_Value - and then Driver.Value /= Empty_String - then - Project.Config.Shared_Lib_Driver := - File_Name_Type (Driver.Value); - end if; - end; - end if; - end if; - end if; - end; - end if; + Lang_Id := Lang_Id.Next; + end loop; + end loop; + end Check_Naming; - if Project.Library then - Debug_Output ("this is a library project file"); + ---------------------------- + -- Initialize_Naming_Data -- + ---------------------------- - Check_Library (Project.Extends, Extends => True); + procedure Initialize_Naming_Data is + Specs : Array_Element_Id := + Util.Value_Of + (Name_Spec_Suffix, + Naming.Decl.Arrays, + Shared); - Imported_Project_List := Project.Imported_Projects; - while Imported_Project_List /= null loop - Check_Library - (Imported_Project_List.Project, - Extends => False); - Imported_Project_List := Imported_Project_List.Next; - end loop; - end if; + Impls : Array_Element_Id := + Util.Value_Of + (Name_Body_Suffix, + Naming.Decl.Arrays, + Shared); - end if; - end if; + Lang : Language_Ptr; + Lang_Name : Name_Id; + Value : Variable_Value; + Extended : Project_Id; - -- Check if Linker'Switches or Linker'Default_Switches are declared. - -- Warn if they are declared, as it is a common error to think that - -- library are "linked" with Linker switches. + 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. - if Project.Library then - declare - Linker_Package_Id : constant Package_Id := - Util.Value_Of - (Name_Linker, - Project.Decl.Packages, Shared); - Linker_Package : Package_Element; - Switches : Array_Element_Id := No_Array_Element; + while Specs /= No_Array_Element loop + Lang_Name := Shared.Array_Elements.Table (Specs).Index; + Lang := + Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); - begin - if Linker_Package_Id /= No_Package then - Linker_Package := Shared.Packages.Table (Linker_Package_Id); + -- An extending project inherits its parent projects' languages + -- so if needed we should create entries for those languages - Switches := - Value_Of - (Name => Name_Switches, - In_Arrays => Linker_Package.Decl.Arrays, - Shared => Shared); + if Lang = null then + Extended := Project.Extends; + while Extended /= null loop + Lang := Get_Language_From_Name + (Extended, Name => Get_Name_String (Lang_Name)); + exit when Lang /= null; - if Switches = No_Array_Element then - Switches := - Value_Of - (Name => Name_Default_Switches, - In_Arrays => Linker_Package.Decl.Arrays, - Shared => Shared); - end if; + Extended := Extended.Extends; + end loop; - if Switches /= No_Array_Element then - Error_Msg - (Data.Flags, - "?Linker switches not taken into account in library " & - "projects", - No_Location, Project); + if Lang /= null then + Lang := new Language_Data'(Lang.all); + Lang.First_Source := null; + Lang.Next := Project.Languages; + Project.Languages := Lang; end if; end if; - end; - end if; - if Project.Extends /= No_Project and then Project.Extends.Library then + -- If language was not found in project or the projects it extends + + if Lang = null then + Debug_Output + ("ignoring spec naming data (lang. not in project): ", + Lang_Name); - -- Remove the library name from Lib_Data_Table + else + Value := Shared.Array_Elements.Table (Specs).Value; - for J in 1 .. Lib_Data_Table.Last loop - if Lib_Data_Table.Table (J).Proj = Project.Extends then - Lib_Data_Table.Table (J) := - Lib_Data_Table.Table (Lib_Data_Table.Last); - Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); - exit; + if Value.Kind = Single then + Lang.Config.Naming_Data.Spec_Suffix := + Canonical_Case_File_Name (Value.Value); + end if; end if; + + Specs := Shared.Array_Elements.Table (Specs).Next; end loop; - end if; - if Project.Library and then not Lib_Name.Default then + while Impls /= No_Array_Element loop + Lang_Name := Shared.Array_Elements.Table (Impls).Index; + Lang := + Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); - -- Check if the same library name is used in an other library project + if Lang = null then + Debug_Output + ("ignoring impl naming data (lang. not in project): ", + Lang_Name); + else + Value := Shared.Array_Elements.Table (Impls).Value; - for J in 1 .. Lib_Data_Table.Last loop - if Lib_Data_Table.Table (J).Name = Project.Library_Name then - Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; - Error_Msg - (Data.Flags, - "Library name cannot be the same as in project %%", - Lib_Name.Location, Project); - Project.Library := False; - exit; + 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 := Shared.Array_Elements.Table (Impls).Next; end loop; - end if; + end Initialize_Naming_Data; - if Project.Library then + -- Start of processing for Check_Naming_Schemes - -- Record the library name + begin + -- No Naming package or parsing a configuration file? nothing to do - Lib_Data_Table.Append - ((Name => Project.Library_Name, Proj => Project)); + if Naming_Id /= No_Package + and then Project.Qualifier /= Configuration + then + Naming := Shared.Packages.Table (Naming_Id); + Debug_Increase_Indent ("checking package Naming for ", Project.Name); + Initialize_Naming_Data; + Check_Naming; + Debug_Decrease_Indent ("done checking package naming"); end if; - end Check_Library_Attributes; + end Check_Package_Naming; --------------------------------- -- Check_Programming_Languages -- @@ -5011,6 +4804,189 @@ package body Prj.Nmsc is end if; end Check_Stand_Alone_Library; + --------------------- + -- Check_Unit_Name -- + --------------------- + + procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is + The_Name : String := Name; + Real_Name : Name_Id; + Need_Letter : Boolean := True; + Last_Underscore : Boolean := False; + OK : Boolean := The_Name'Length > 0; + First : Positive; + + function Is_Reserved (Name : Name_Id) return Boolean; + function Is_Reserved (S : String) return Boolean; + -- Check that the given name is not an Ada 95 reserved word. The reason + -- for the Ada 95 here is that we do not want to exclude the case of an + -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit + -- name would be rejected anyway by the compiler. That means there is no + -- requirement that the project file parser reject this. + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (S : String) return Boolean is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (S); + return Is_Reserved (Name_Find); + end Is_Reserved; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Name : Name_Id) return Boolean is + begin + if Get_Name_Table_Byte (Name) /= 0 + and then Name /= Name_Project + and then Name /= Name_Extends + and then Name /= Name_External + and then Name not in Ada_2005_Reserved_Words + then + Unit := No_Name; + Debug_Output ("Ada reserved word: ", Name); + return True; + + else + return False; + end if; + end Is_Reserved; + + -- Start of processing for Check_Unit_Name + + begin + To_Lower (The_Name); + + Name_Len := The_Name'Length; + Name_Buffer (1 .. Name_Len) := The_Name; + + -- Special cases of children of packages A, G, I and S on VMS + + if OpenVMS_On_Target + and then Name_Len > 3 + and then Name_Buffer (2 .. 3) = "__" + and then + ((Name_Buffer (1) = 'a') or else + (Name_Buffer (1) = 'g') or else + (Name_Buffer (1) = 'i') or else + (Name_Buffer (1) = 's')) + then + Name_Buffer (2) := '.'; + Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len); + Name_Len := Name_Len - 1; + end if; + + Real_Name := Name_Find; + + if Is_Reserved (Real_Name) then + return; + end if; + + First := The_Name'First; + + for Index in The_Name'Range loop + if Need_Letter then + + -- We need a letter (at the beginning, and following a dot), + -- but we don't have one. + + if Is_Letter (The_Name (Index)) then + Need_Letter := False; + + else + OK := False; + + if Current_Verbosity = High then + Debug_Indent; + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is not a letter."); + end if; + + exit; + end if; + + elsif Last_Underscore + and then (The_Name (Index) = '_' or else The_Name (Index) = '.') + then + -- Two underscores are illegal, and a dot cannot follow + -- an underscore. + + OK := False; + + if Current_Verbosity = High then + Debug_Indent; + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is illegal here."); + end if; + + exit; + + elsif The_Name (Index) = '.' then + + -- First, check if the name before the dot is not a reserved word + + if Is_Reserved (The_Name (First .. Index - 1)) then + return; + end if; + + First := Index + 1; + + -- We need a letter after a dot + + Need_Letter := True; + + elsif The_Name (Index) = '_' then + Last_Underscore := True; + + else + -- We need an letter or a digit + + Last_Underscore := False; + + if not Is_Alphanumeric (The_Name (Index)) then + OK := False; + + if Current_Verbosity = High then + Debug_Indent; + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is not alphanumeric."); + end if; + + exit; + end if; + end if; + end loop; + + -- Cannot end with an underscore or a dot + + OK := OK and then not Need_Letter and then not Last_Underscore; + + if OK then + if First /= Name'First and then + Is_Reserved (The_Name (First .. The_Name'Last)) + then + return; + end if; + + Unit := Real_Name; + + else + -- Signal a problem with No_Name + + Unit := No_Name; + end if; + end Check_Unit_Name; + ---------------------------- -- Compute_Directory_Last -- ---------------------------- @@ -7723,6 +7699,7 @@ package body Prj.Nmsc is Src : Source_Info; Id : Source_Id; Lang_Id : Language_Ptr; + begin Initialize (Iter, Project.Project.Name); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ea54583e7182..15f89ef89459 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4741,6 +4741,47 @@ package body Sem_Ch3 is Make_Index (Index, P, Related_Id, Nb_Index); + -- In formal verification mode, create an explicit subtype for every + -- index if not already a subtype_mark, and replace the existing type + -- of index by this new type. Why are we doing this ??? + + if ALFA_Mode + and then not Nkind_In (Index, N_Identifier, N_Expanded_Name) + then + declare + Loc : constant Source_Ptr := Sloc (Def); + New_E : Entity_Id; + Decl : Entity_Id; + Sub_Ind : Node_Id; + + begin + New_E := + New_External_Entity + (E_Void, Current_Scope, Sloc (P), Related_Id, 'D', + Nb_Index, 'T'); + + if Nkind (Index) = N_Subtype_Indication then + Sub_Ind := Relocate_Node (Index); + else + Sub_Ind := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Etype (Index)), Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => Relocate_Node (Index))); + end if; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_E, + Subtype_Indication => Sub_Ind); + + Insert_Action (Parent (Def), Decl); + Set_Etype (Index, New_E); + end; + end if; + -- Check error of subtype with predicate for index type Bad_Predicated_Subtype_Use @@ -4756,7 +4797,36 @@ package body Sem_Ch3 is -- Process subtype indication if one is present if Present (Component_Typ) then - Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); + + -- In formal verification mode, create an explicit subtype for the + -- component type if not already a subtype_mark. Why do this ??? + + if ALFA_Mode + and then Nkind (Component_Typ) = N_Subtype_Indication + then + declare + Loc : constant Source_Ptr := Sloc (Def); + Decl : Entity_Id; + + begin + Element_Type := + New_External_Entity + (E_Void, Current_Scope, Sloc (P), Related_Id, 'C', 0, 'T'); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Element_Type, + Subtype_Indication => Relocate_Node (Component_Typ)); + + Insert_Action (Parent (Def), Decl); + end; + + else + Element_Type := + Process_Subtype (Component_Typ, P, Related_Id, 'C'); + end if; + + Set_Etype (Component_Typ, Element_Type); if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then Check_SPARK_Restriction ("subtype mark required", Component_Typ);