From patchwork Tue Oct 5 09:22:29 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 66774 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 81AB4B6EDD for ; Tue, 5 Oct 2010 20:22:55 +1100 (EST) Received: (qmail 10507 invoked by alias); 5 Oct 2010 09:22:52 -0000 Received: (qmail 10456 invoked by uid 22791); 5 Oct 2010 09:22:42 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, TW_PR, T_FILL_THIS_FORM_SHORT, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 05 Oct 2010 09:22:33 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 48E71CB0236; Tue, 5 Oct 2010 11:22:30 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id myUySefs8OyR; Tue, 5 Oct 2010 11:22:30 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 2C788CB01EC; Tue, 5 Oct 2010 11:22:30 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 03657D9BB5; Tue, 5 Oct 2010 11:22:29 +0200 (CEST) Date: Tue, 5 Oct 2010 11:22:29 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Emmanuel Briot Subject: [Ada] Adding support for aggregate projects Message-ID: <20101005092229.GA29754@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This check in starts the work on implementing aggregate projects. These projects are used to build one or more project trees through a single command, as well as control their shared environment. This check in is mostly refactoring work. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-05 Emmanuel Briot * prj-dect.adb, prj-nmsc.adb, prj-attr.adb, snames.ads-tmpl (Aggregate projects): added support for parsing aggregate projects. In particular, check the presence and value of the new attributes related to aggregate projects, ie Project_Files, Project_Path and External. (Check_Attribute_Allowed, Check_Package_Allowed, Rename_Obsolescent_Attributes): new subprogram, extracting code from existing subprogram to keep their sizes smaller. (Check_Aggregate_Project, Check_Abstract_Project, Check_Missing_Sources): new subprograms (Check): remove comments that duplicated either the name of the following subprogram call, or the comment on that subprogram. * prj-part.adb (Check_Extending_All_Imports): New subprogram, extracted from Parse_Single_Project. (Check_Aggregate_Imports): new subprogram. Index: prj-dect.adb =================================================================== --- prj-dect.adb (revision 164906) +++ prj-dect.adb (working copy) @@ -48,6 +48,31 @@ package body Prj.Dect is -- a case construction (In_Case_Construction) or none of those two -- (In_Project). + procedure Rename_Obsolescent_Attributes + (In_Tree : Project_Node_Tree_Ref; + Attribute : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Rename obsolescent attributes in the tree. + -- When the attribute has been renamed since its initial introduction in + -- the design of projects, we replace the old name in the tree with the + -- new name, so that the code does not have to check both names forever. + + procedure Check_Attribute_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Attribute : Project_Node_Id; + Flags : Processing_Flags); + -- Chech whether the attribute is valid in this project. + -- In particular, depending on the type of project (qualifier), some + -- attributes might be disabled. + + procedure Check_Package_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags); + -- Check whether the package is valid in this project + procedure Parse_Attribute_Declaration (In_Tree : Project_Node_Tree_Ref; Attribute : out Project_Node_Id; @@ -147,6 +172,111 @@ package body Prj.Dect is (Declarations, In_Tree, To => First_Declarative_Item); end Parse; + ----------------------------------- + -- Rename_Obsolescent_Attributes -- + ----------------------------------- + + procedure Rename_Obsolescent_Attributes + (In_Tree : Project_Node_Tree_Ref; + Attribute : Project_Node_Id; + Current_Package : Project_Node_Id) is + begin + if Present (Current_Package) + and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored + then + case Name_Of (Attribute, In_Tree) is + when Snames.Name_Specification => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); + + when Snames.Name_Specification_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); + + when Snames.Name_Implementation => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); + + when Snames.Name_Implementation_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); + + when others => + null; + end case; + end if; + end Rename_Obsolescent_Attributes; + + --------------------------- + -- Check_Package_Allowed -- + --------------------------- + + procedure Check_Package_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Flags : Processing_Flags) + is + Qualif : constant Project_Qualifier := + Project_Qualifier_Of (Project, In_Tree); + Name : constant Name_Id := Name_Of (Current_Package, In_Tree); + begin + if Qualif = Aggregate + and then Name /= Snames.Name_Builder + then + Error_Msg_Name_1 := Name; + Error_Msg + (Flags, + "package %% is forbidden in aggregate projects", + Location_Of (Current_Package, In_Tree)); + end if; + end Check_Package_Allowed; + + ----------------------------- + -- Check_Attribute_Allowed -- + ----------------------------- + + procedure Check_Attribute_Allowed + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Attribute : Project_Node_Id; + Flags : Processing_Flags) + is + Qualif : constant Project_Qualifier := + Project_Qualifier_Of (Project, In_Tree); + Name : constant Name_Id := Name_Of (Attribute, In_Tree); + begin + case Qualif is + when Aggregate => + if Name = Snames.Name_Languages + or else Name = Snames.Name_Source_Files + or else Name = Snames.Name_Source_List_File + or else Name = Snames.Name_Locally_Removed_Files + or else Name = Snames.Name_Excluded_Source_Files + or else Name = Snames.Name_Excluded_Source_List_File + or else Name = Snames.Name_Interfaces + or else Name = Snames.Name_Object_Dir + or else Name = Snames.Name_Exec_Dir + or else Name = Snames.Name_Source_Dirs + or else Name = Snames.Name_Inherit_Source_Path + then + Error_Msg_Name_1 := Name; + Error_Msg + (Flags, + "%% is not valid in aggregate projects", + Location_Of (Attribute, In_Tree)); + end if; + + when others => + if Name = Snames.Name_Project_Files + or else Name = Snames.Name_Project_Path + or else Name = Snames.Name_External + then + Error_Msg_Name_1 := Name; + Error_Msg + (Flags, + "%% is only valid in aggregate projects", + Location_Of (Attribute, In_Tree)); + end if; + end case; + end Check_Attribute_Allowed; + --------------------------------- -- Parse_Attribute_Declaration -- --------------------------------- @@ -165,37 +295,28 @@ package body Prj.Dect is Attribute_Name : Name_Id := No_Name; Optional_Index : Boolean := False; Pkg_Id : Package_Node_Id := Empty_Package; - Ignore : Boolean := False; - - begin - Attribute := - Default_Project_Node - (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree); - Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); - Set_Previous_Line_Node (Attribute); - -- Scan past "for" + procedure Process_Attribute_Name; + -- Read the name of the attribute, and check its type - Scan (In_Tree); - - -- Body may be an attribute name + procedure Process_Associative_Array_Index; + -- Read the index of the associative array and check its validity - if Token = Tok_Body then - Token := Tok_Identifier; - Token_Name := Snames.Name_Body; - end if; - - Expect (Tok_Identifier, "identifier"); - - if Token = Tok_Identifier then + ---------------------------- + -- Process_Attribute_Name -- + ---------------------------- + + procedure Process_Attribute_Name is + Ignore : Boolean; + begin Attribute_Name := Token_Name; - Set_Name_Of (Attribute, In_Tree, To => Token_Name); + Set_Name_Of (Attribute, In_Tree, To => Attribute_Name); Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); -- Find the attribute Current_Attribute := - Attribute_Node_Id_Of (Token_Name, First_Attribute); + Attribute_Node_Id_Of (Attribute_Name, First_Attribute); -- If the attribute cannot be found, create the attribute if inside -- an unknown package. @@ -254,35 +375,22 @@ package body Prj.Dect is end if; Scan (In_Tree); -- past the attribute name - end if; - - -- Change obsolete names of attributes to the new names - - if Present (Current_Package) - and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored - then - case Name_Of (Attribute, In_Tree) is - when Snames.Name_Specification => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); - when Snames.Name_Specification_Suffix => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); - - when Snames.Name_Implementation => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); - - when Snames.Name_Implementation_Suffix => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); - - when others => - null; - end case; - end if; + -- Set the expression kind of the attribute - -- Associative array attributes + if Current_Attribute /= Empty_Attribute then + Set_Expression_Kind_Of + (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute)); + Optional_Index := Optional_Index_Of (Current_Attribute); + end if; + end Process_Attribute_Name; - if Token = Tok_Left_Paren then + ------------------------------------- + -- Process_Associative_Array_Index -- + ------------------------------------- + procedure Process_Associative_Array_Index is + begin -- If the attribute is not an associative array attribute, report -- an error. If this information is still unknown, set the kind -- to Associative_Array. @@ -292,9 +400,8 @@ package body Prj.Dect is then Error_Msg (Flags, "the attribute """ & - Get_Name_String - (Attribute_Name_Of (Current_Attribute)) & - """ cannot be an associative array", + Get_Name_String (Attribute_Name_Of (Current_Attribute)) + & """ cannot be an associative array", Location_Of (Attribute, In_Tree)); elsif Attribute_Kind_Of (Current_Attribute) = Unknown then @@ -371,6 +478,35 @@ package body Prj.Dect is if Token = Tok_Right_Paren then Scan (In_Tree); -- past the right parenthesis end if; + end Process_Associative_Array_Index; + + begin + Attribute := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree); + Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); + Set_Previous_Line_Node (Attribute); + + -- Scan past "for" + + Scan (In_Tree); + + -- Body may be an attribute name + + if Token = Tok_Body then + Token := Tok_Identifier; + Token_Name := Snames.Name_Body; + end if; + + Expect (Tok_Identifier, "identifier"); + Process_Attribute_Name; + Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package); + Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags); + + -- Associative array attributes + + if Token = Tok_Left_Paren then + Process_Associative_Array_Index; else -- If it is an associative array attribute and there are no left @@ -390,14 +526,6 @@ package body Prj.Dect is end if; end if; - -- Set the expression kind of the attribute - - if Current_Attribute /= Empty_Attribute then - Set_Expression_Kind_Of - (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute)); - Optional_Index := Optional_Index_Of (Current_Attribute); - end if; - Expect (Tok_Use, "USE"); if Token = Tok_Use then @@ -1149,6 +1277,9 @@ package body Prj.Dect is Scan (In_Tree); end if; + Check_Package_Allowed + (In_Tree, Current_Project, Package_Declaration, Flags); + if Token = Tok_Renames then Renaming := True; elsif Token = Tok_Extends then Index: prj-nmsc.adb =================================================================== --- prj-nmsc.adb (revision 164937) +++ prj-nmsc.adb (working copy) @@ -282,6 +282,16 @@ package body Prj.Nmsc is -- Check the library attributes of project Project in project tree -- and modify its data Data accordingly. + procedure Check_Aggregate_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check aggregate projects attributes + + procedure Check_Abstract_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check abstract projects attributes + procedure Check_Programming_Languages (Project : Project_Id; Data : in out Tree_Processing_Data); @@ -432,9 +442,8 @@ package body Prj.Nmsc is (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data); -- Find all the sources of project Project in project tree Data.Tree and - -- update its Data accordingly. This assumes that Data.First_Source has - -- been initialized with the list of excluded sources and special naming - -- exceptions. + -- update its Data accordingly. This assumes that the special naming + -- exceptions have already been processed. function Path_Name_Of (File_Name : File_Name_Type; @@ -854,6 +863,73 @@ package body Prj.Nmsc is end if; end Canonical_Case_File_Name; + ----------------------------- + -- Check_Aggregate_Project -- + ----------------------------- + + procedure Check_Aggregate_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Project_Files : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Project_Files, + Project.Decl.Attributes, + Data.Tree); + begin + if Project_Files.Default then + Error_Msg_Name_1 := Snames.Name_Project_Files; + Error_Msg + (Data.Flags, + "Attribute %% must be specified in aggregate project", + Project.Location, Project); + end if; + end Check_Aggregate_Project; + + ---------------------------- + -- Check_Abstract_Project -- + ---------------------------- + + procedure Check_Abstract_Project + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + Source_Dirs : constant Variable_Value := + Util.Value_Of + (Name_Source_Dirs, + Project.Decl.Attributes, Data.Tree); + Source_Files : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Project.Decl.Attributes, Data.Tree); + Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Source_List_File, + Project.Decl.Attributes, Data.Tree); + Languages : constant Variable_Value := + Util.Value_Of + (Name_Languages, + Project.Decl.Attributes, Data.Tree); + + 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 -- ----------- @@ -862,60 +938,20 @@ package body Prj.Nmsc is (Project : Project_Id; Data : in out Tree_Processing_Data) is - Extending : Boolean := False; Prj_Data : Project_Processing_Data; begin Initialize (Prj_Data, Project); - Check_If_Externally_Built (Project, Data); - - -- Object, exec and source directories - - Get_Directories (Project, Data); - - -- Get the programming languages - + Check_If_Externally_Built (Project, Data); + Get_Directories (Project, Data); Check_Programming_Languages (Project, Data); - if Project.Qualifier = Dry - and then Project.Source_Dirs /= Nil_String - then - declare - Source_Dirs : constant Variable_Value := - Util.Value_Of - (Name_Source_Dirs, - Project.Decl.Attributes, Data.Tree); - Source_Files : constant Variable_Value := - Util.Value_Of - (Name_Source_Files, - Project.Decl.Attributes, Data.Tree); - Source_List_File : constant Variable_Value := - Util.Value_Of - (Name_Source_List_File, - Project.Decl.Attributes, Data.Tree); - Languages : constant Variable_Value := - Util.Value_Of - (Name_Languages, - Project.Decl.Attributes, Data.Tree); - - begin - 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; - end if; + case Project.Qualifier is + when Aggregate => Check_Aggregate_Project (Project, Data); + when Dry => Check_Abstract_Project (Project, Data); + when others => null; + end case; -- Check configuration. This must be done even for gnatmake (even though -- no user configuration file was provided) since the default config we @@ -923,91 +959,24 @@ package body Prj.Nmsc is Check_Configuration (Project, Data); - -- Library attributes - Check_Library_Attributes (Project, Data); if Current_Verbosity = High then Show_Source_Dirs (Project, Data.Tree); end if; - Extending := Project.Extends /= No_Project; - Check_Package_Naming (Project, Data); - -- Find the sources - - if Project.Source_Dirs /= Nil_String then + if Project.Qualifier /= Aggregate then Look_For_Sources (Prj_Data, Data); - - if not Project.Externally_Built - and then not Extending - then - declare - Language : Language_Ptr; - Source : Source_Id; - Alt_Lang : Language_List; - Continuation : Boolean := False; - Iter : Source_Iterator; - - begin - Language := Project.Languages; - while Language /= No_Language_Index loop - - -- If there are no sources for this language, check if there - -- are sources for which this is an alternate language. - - if Language.First_Source = No_Source - and then (Data.Flags.Require_Sources_Other_Lang - or else Language.Name = Name_Ada) - then - Iter := For_Each_Source (In_Tree => Data.Tree, - Project => Project); - Source_Loop : loop - Source := Element (Iter); - exit Source_Loop when Source = No_Source - or else Source.Language = Language; - - Alt_Lang := Source.Alternate_Languages; - while Alt_Lang /= null loop - exit Source_Loop when Alt_Lang.Language = Language; - Alt_Lang := Alt_Lang.Next; - end loop; - - Next (Iter); - end loop Source_Loop; - - if Source = No_Source then - - Report_No_Sources - (Project, - Get_Name_String (Language.Display_Name), - Data, - Prj_Data.Source_List_File_Location, - Continuation); - Continuation := True; - end if; - end if; - - Language := Language.Next; - end loop; - end; - end if; end if; - -- If a list of sources is specified in attribute Interfaces, set - -- In_Interfaces only for the sources specified in the list. - Check_Interfaces (Project, Data); - -- If it is a library project file, check if it is a standalone library - if Project.Library then Check_Stand_Alone_Library (Project, Data); end if; - -- Put the list of Mains, if any, in the project data - Get_Mains (Project, Data); Free (Prj_Data); @@ -7242,6 +7211,68 @@ package body Prj.Nmsc is procedure Mark_Excluded_Sources; -- Mark as such the sources that are declared as excluded + procedure Check_Missing_Sources; + -- Check whether one of the languages has no sources, and report an + -- error when appropriate + + --------------------------- + -- Check_Missing_Sources -- + --------------------------- + + procedure Check_Missing_Sources is + Extending : constant Boolean := + Project.Project.Extends /= No_Project; + Language : Language_Ptr; + Source : Source_Id; + Alt_Lang : Language_List; + Continuation : Boolean := False; + Iter : Source_Iterator; + begin + if not Project.Project.Externally_Built + and then not Extending + then + Language := Project.Project.Languages; + while Language /= No_Language_Index loop + + -- If there are no sources for this language, check if there + -- are sources for which this is an alternate language. + + if Language.First_Source = No_Source + and then (Data.Flags.Require_Sources_Other_Lang + or else Language.Name = Name_Ada) + then + Iter := For_Each_Source (In_Tree => Data.Tree, + Project => Project.Project); + Source_Loop : loop + Source := Element (Iter); + exit Source_Loop when Source = No_Source + or else Source.Language = Language; + + Alt_Lang := Source.Alternate_Languages; + while Alt_Lang /= null loop + exit Source_Loop when Alt_Lang.Language = Language; + Alt_Lang := Alt_Lang.Next; + end loop; + + Next (Iter); + end loop Source_Loop; + + if Source = No_Source then + Report_No_Sources + (Project.Project, + Get_Name_String (Language.Display_Name), + Data, + Project.Source_List_File_Location, + Continuation); + Continuation := True; + end if; + end if; + + Language := Language.Next; + end loop; + end if; + end Check_Missing_Sources; + ------------------ -- Check_Object -- ------------------ @@ -7416,13 +7447,16 @@ package body Prj.Nmsc is -- Start of processing for Look_For_Sources begin - Find_Excluded_Sources (Project, Data); + if Project.Project.Source_Dirs /= Nil_String then + Find_Excluded_Sources (Project, Data); - if Project.Project.Languages /= No_Language_Index then - Load_Naming_Exceptions (Project, Data); - Find_Sources (Project, Data); - Mark_Excluded_Sources; - Check_Object_Files; + if Project.Project.Languages /= No_Language_Index then + Load_Naming_Exceptions (Project, Data); + Find_Sources (Project, Data); + Mark_Excluded_Sources; + Check_Object_Files; + Check_Missing_Sources; + end if; end if; Object_File_Names_Htable.Reset (Object_Files); Index: prj-attr.adb =================================================================== --- prj-attr.adb (revision 164906) +++ prj-attr.adb (working copy) @@ -91,6 +91,12 @@ package body Prj.Attr is "SVexcluded_source_list_file#" & "LVinterfaces#" & + -- Projects (in aggregate projects) + + "LVproject_files#" & + "LVproject_path#" & + "SAexternal#" & + -- Libraries "SVlibrary_dir#" & @@ -147,18 +153,20 @@ package body Prj.Attr is "Saruntime_source_dir#" & -- package Naming + -- Some attributes are obsolescent, and renamed in the tree (see + -- Prj.Dect.Rename_Obsolescent_Attributes). "Pnaming#" & - "Saspecification_suffix#" & + "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree "Saspec_suffix#" & - "Saimplementation_suffix#" & + "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree "Sabody_suffix#" & "SVseparate_suffix#" & "SVcasing#" & "SVdot_replacement#" & - "sAspecification#" & + "sAspecification#" & -- Always renamed to "spec" in project tree "sAspec#" & - "sAimplementation#" & + "sAimplementation#" & -- Always renamed to "body" in project tree "sAbody#" & "Laspecification_exceptions#" & "Laimplementation_exceptions#" & Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 164906) +++ snames.ads-tmpl (working copy) @@ -1133,6 +1133,8 @@ package Snames is Name_Prefix : constant Name_Id := N + $; Name_Project : constant Name_Id := N + $; Name_Project_Dir : constant Name_Id := N + $; + Name_Project_Files : constant Name_Id := N + $; + Name_Project_Path : constant Name_Id := N + $; Name_Response_File_Format : constant Name_Id := N + $; Name_Response_File_Switches : constant Name_Id := N + $; Name_Roots : constant Name_Id := N + $; -- GPR Index: prj-part.adb =================================================================== --- prj-part.adb (revision 164906) +++ prj-part.adb (working copy) @@ -125,8 +125,37 @@ package body Prj.Part is Key => Name_Id, Hash => Hash, Equal => "="); + + function Has_Circular_Dependencies + (Flags : Processing_Flags; + Normed_Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type) return Boolean; + -- Check for a circular dependency in the loaded project. + -- Generates an error message in such a case. + + procedure Read_Project_Qualifier + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Is_Config_File : Boolean; + Qualifier_Location : out Source_Ptr; + Project : Project_Node_Id); + -- Check if there is a qualifier before the reserved word "project" + -- Hash table to cache project path to avoid looking for them on the path + procedure Check_Extending_All_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id); + -- Check that a non extending-all project does not import an + -- extending-all project. + + procedure Check_Aggregate_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id); + -- Check that an aggregate project only imports abstract projects + procedure Create_Virtual_Extending_Project (For_Project : Project_Node_Id; Main_Project : Project_Node_Id; @@ -916,6 +945,185 @@ package body Prj.Part is end loop; end Post_Parse_Context_Clause; + --------------------------------- + -- Check_Extending_All_Imports -- + --------------------------------- + + procedure Check_Extending_All_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id) + is + With_Clause, Imported : Project_Node_Id; + begin + if not Is_Extending_All (Project, In_Tree) then + With_Clause := First_With_Clause_Of (Project, In_Tree); + + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Is_Extending_All (With_Clause, In_Tree) then + Error_Msg_Name_1 := Name_Of (Imported, In_Tree); + Error_Msg (Flags, "cannot import extending-all project %%", + Token_Ptr); + exit; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + end if; + end Check_Extending_All_Imports; + + ----------------------------- + -- Check_Aggregate_Imports -- + ----------------------------- + + procedure Check_Aggregate_Imports + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id) + is + With_Clause, Imported : Project_Node_Id; + begin + if Project_Qualifier_Of (Project, In_Tree) = Aggregate then + With_Clause := First_With_Clause_Of (Project, In_Tree); + + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Project_Qualifier_Of (Imported, In_Tree) /= Dry then + Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); + Error_Msg (Flags, "can only import abstract projects, not %%", + Token_Ptr); + exit; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + end if; + end Check_Aggregate_Imports; + + ---------------------------- + -- Read_Project_Qualifier -- + ---------------------------- + + procedure Read_Project_Qualifier + (Flags : Processing_Flags; + In_Tree : Project_Node_Tree_Ref; + Is_Config_File : Boolean; + Qualifier_Location : out Source_Ptr; + Project : Project_Node_Id) + is + Proj_Qualifier : Project_Qualifier := Unspecified; + begin + Qualifier_Location := Token_Ptr; + + if Token = Tok_Abstract then + Proj_Qualifier := Dry; + Scan (In_Tree); + + elsif Token = Tok_Identifier then + case Token_Name is + when Snames.Name_Standard => + Proj_Qualifier := Standard; + Scan (In_Tree); + + when Snames.Name_Aggregate => + Proj_Qualifier := Aggregate; + Scan (In_Tree); + + if Token = Tok_Identifier and then + Token_Name = Snames.Name_Library + then + Proj_Qualifier := Aggregate_Library; + Scan (In_Tree); + end if; + + when Snames.Name_Library => + Proj_Qualifier := Library; + Scan (In_Tree); + + when Snames.Name_Configuration => + if not Is_Config_File then + Error_Msg + (Flags, + "configuration projects cannot belong to a user" & + " project tree", + Token_Ptr); + end if; + + Proj_Qualifier := Configuration; + Scan (In_Tree); + + when others => + null; + end case; + end if; + + if Is_Config_File and then Proj_Qualifier = Unspecified then + + -- Set the qualifier to Configuration, even if the token doesn't + -- exist in the source file itself, so that we can differentiate + -- project files and configuration files later on. + + Proj_Qualifier := Configuration; + end if; + + if Proj_Qualifier /= Unspecified then + if Is_Config_File + and then Proj_Qualifier /= Configuration + then + Error_Msg (Flags, + "a configuration project cannot be qualified except " & + "as configuration project", + Qualifier_Location); + end if; + + Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); + end if; + end Read_Project_Qualifier; + + ------------------------------- + -- Has_Circular_Dependencies -- + ------------------------------- + + function Has_Circular_Dependencies + (Flags : Processing_Flags; + Normed_Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type) return Boolean is + begin + for Index in reverse 1 .. Project_Stack.Last loop + exit when Project_Stack.Table (Index).Limited_With; + + if Canonical_Path_Name = + Project_Stack.Table (Index).Canonical_Path_Name + then + Error_Msg (Flags, "circular dependency detected", Token_Ptr); + Error_Msg_Name_1 := Name_Id (Normed_Path_Name); + Error_Msg (Flags, "\ %% is imported by", Token_Ptr); + + for Current in reverse 1 .. Project_Stack.Last loop + Error_Msg_Name_1 := + Name_Id (Project_Stack.Table (Current).Path_Name); + + if Project_Stack.Table (Current).Canonical_Path_Name /= + Canonical_Path_Name + then + Error_Msg + (Flags, "\ %% which itself is imported by", Token_Ptr); + + else + Error_Msg (Flags, "\ %%", Token_Ptr); + exit; + end if; + end loop; + + return True; + end if; + end loop; + return False; + end Has_Circular_Dependencies; + -------------------------- -- Parse_Single_Project -- -------------------------- @@ -962,7 +1170,6 @@ package body Prj.Part is Project_Comment_State : Tree.Comment_State; - Proj_Qualifier : Project_Qualifier := Unspecified; Qualifier_Location : Source_Ptr; begin @@ -988,38 +1195,12 @@ package body Prj.Part is Canonical_Path_Name := Name_Find; end; - -- Check for a circular dependency - - for Index in reverse 1 .. Project_Stack.Last loop - exit when Project_Stack.Table (Index).Limited_With; - - if Canonical_Path_Name = - Project_Stack.Table (Index).Canonical_Path_Name - then - Error_Msg (Flags, "circular dependency detected", Token_Ptr); - Error_Msg_Name_1 := Name_Id (Normed_Path_Name); - Error_Msg (Flags, "\ %% is imported by", Token_Ptr); - - for Current in reverse 1 .. Project_Stack.Last loop - Error_Msg_Name_1 := - Name_Id (Project_Stack.Table (Current).Path_Name); - - if Project_Stack.Table (Current).Canonical_Path_Name /= - Canonical_Path_Name - then - Error_Msg - (Flags, "\ %% which itself is imported by", Token_Ptr); - - else - Error_Msg (Flags, "\ %%", Token_Ptr); - exit; - end if; - end loop; - - Project := Empty_Node; - return; - end if; - end loop; + if Has_Circular_Dependencies + (Flags, Normed_Path_Name, Canonical_Path_Name) + then + Project := Empty_Node; + return; + end if; -- Put the new path name on the stack @@ -1156,73 +1337,8 @@ package body Prj.Part is Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); - -- Check if there is a qualifier before the reserved word "project" - - Qualifier_Location := Token_Ptr; - - if Token = Tok_Abstract then - Proj_Qualifier := Dry; - Scan (In_Tree); - - elsif Token = Tok_Identifier then - case Token_Name is - when Snames.Name_Standard => - Proj_Qualifier := Standard; - Scan (In_Tree); - - when Snames.Name_Aggregate => - Proj_Qualifier := Aggregate; - Scan (In_Tree); - - if Token = Tok_Identifier and then - Token_Name = Snames.Name_Library - then - Proj_Qualifier := Aggregate_Library; - Scan (In_Tree); - end if; - - when Snames.Name_Library => - Proj_Qualifier := Library; - Scan (In_Tree); - - when Snames.Name_Configuration => - if not Is_Config_File then - Error_Msg - (Flags, - "configuration projects cannot belong to a user" & - " project tree", - Token_Ptr); - end if; - - Proj_Qualifier := Configuration; - Scan (In_Tree); - - when others => - null; - end case; - end if; - - if Is_Config_File and then Proj_Qualifier = Unspecified then - - -- Set the qualifier to Configuration, even if the token doesn't - -- exist in the source file itself, so that we can differentiate - -- project files and configuration files later on. - - Proj_Qualifier := Configuration; - end if; - - if Proj_Qualifier /= Unspecified then - if Is_Config_File - and then Proj_Qualifier /= Configuration - then - Error_Msg (Flags, - "a configuration project cannot be qualified except " & - "as configuration project", - Qualifier_Location); - end if; - - Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); - end if; + Read_Project_Qualifier + (Flags, In_Tree, Is_Config_File, Qualifier_Location, Project); Set_Location_Of (Project, In_Tree, Token_Ptr); @@ -1513,7 +1629,7 @@ package body Prj.Part is -- with sources, if it inherits sources from the project -- it extends. - if Proj_Qualifier = Dry and then + if Project_Qualifier_Of (Project, In_Tree) = Dry and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry then Error_Msg @@ -1529,31 +1645,8 @@ package body Prj.Part is end if; end if; - -- Check that a non extending-all project does not import an - -- extending-all project. - - if not Is_Extending_All (Project, In_Tree) then - declare - With_Clause : Project_Node_Id := - First_With_Clause_Of (Project, In_Tree); - Imported : Project_Node_Id := Empty_Node; - - begin - With_Clause_Loop : - while Present (With_Clause) loop - Imported := Project_Node_Of (With_Clause, In_Tree); - - if Is_Extending_All (With_Clause, In_Tree) then - Error_Msg_Name_1 := Name_Of (Imported, In_Tree); - Error_Msg (Flags, "cannot import extending-all project %%", - Token_Ptr); - exit With_Clause_Loop; - end if; - - With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); - end loop With_Clause_Loop; - end; - end if; + Check_Extending_All_Imports (Flags, In_Tree, Project); + Check_Aggregate_Imports (Flags, In_Tree, Project); -- Check that a project with a name including a dot either imports -- or extends the project whose name precedes the last dot. @@ -1571,7 +1664,7 @@ package body Prj.Part is Name_Len := Name_Len - 1; end loop; - -- If a dot was find, check if the parent project is imported + -- If a dot was found, check if the parent project is imported -- or extended. if Name_Len > 0 then @@ -1728,7 +1821,7 @@ package body Prj.Part is Node => Project, Canonical_Path => Canonical_Path_Name, Extended => Extended, - Proj_Qualifier => Proj_Qualifier)); + Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree))); end if; declare