From c4d67e2d730f6a8e45182a384b5b674f5134bc64 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 3 Aug 2011 11:17:28 +0200 Subject: [PATCH] [multiple changes] 2011-08-03 Yannick Moy * sem_ch6.adb (New_Overloaded_Entity): only issue error for SPARK restriction on overloaded entity if the entity is not an operator. 2011-08-03 Yannick Moy * sem_ch7.adb, sem_res.adb, sem_attr.adb, restrict.adb, restrict.ads: Rename remaining Check_Formal_Restriction* into Check_SPARK_Restriction*. 2011-08-03 Emmanuel Briot * prj-proc.adb, prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-nmsc.ads, prj-err.adb (Project_Data): now discriminated on its qualifier. (Project_Empty): removed (Empty_Project): new parameter Qualifier This is used to have fields specific to aggregate projects, cleaner New field to store the list of aggregated projects. (Check_Aggregate_Project): removed (Process_Aggregated_Projects, Free): new subprograms. From-SVN: r177243 --- gcc/ada/ChangeLog | 23 + gcc/ada/prj-err.adb | 6 +- gcc/ada/prj-nmsc.adb | 86 ++- gcc/ada/prj-nmsc.ads | 14 +- gcc/ada/prj-part.adb | 2 +- gcc/ada/prj-proc.adb | 1683 +++++++++++++++++++++--------------------- gcc/ada/prj.adb | 119 +-- gcc/ada/prj.ads | 57 +- gcc/ada/restrict.adb | 10 +- gcc/ada/restrict.ads | 4 +- gcc/ada/sem_attr.adb | 26 +- gcc/ada/sem_ch6.adb | 9 +- gcc/ada/sem_ch7.adb | 2 +- gcc/ada/sem_res.adb | 2 +- 14 files changed, 1063 insertions(+), 980 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ecb09e0d43e..5ef41f80ce2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2011-08-03 Yannick Moy + + * sem_ch6.adb (New_Overloaded_Entity): only issue error for SPARK + restriction on overloaded entity if the entity is not an operator. + +2011-08-03 Yannick Moy + + * sem_ch7.adb, sem_res.adb, sem_attr.adb, restrict.adb, + restrict.ads: Rename remaining Check_Formal_Restriction* into + Check_SPARK_Restriction*. + +2011-08-03 Emmanuel Briot + + * prj-proc.adb, prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb, + prj-nmsc.ads, prj-err.adb (Project_Data): now discriminated on its + qualifier. + (Project_Empty): removed + (Empty_Project): new parameter Qualifier + This is used to have fields specific to aggregate projects, cleaner + New field to store the list of aggregated projects. + (Check_Aggregate_Project): removed + (Process_Aggregated_Projects, Free): new subprograms. + 2011-08-03 Olivier Hainque * tracebak.c (STOP_FRAME ppc AIX): Stop at null return address as well. diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb index 4f5aea10b43..75cf23b7bfc 100644 --- a/gcc/ada/prj-err.adb +++ b/gcc/ada/prj-err.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -78,7 +78,7 @@ package body Prj.Err is -- triggered) if Current_Verbosity = High then - Write_Line ("ERROR: " & Msg); + Debug_Output ("ERROR: " & Msg); end if; -- If location of error is unknown, use the location of the project @@ -96,7 +96,7 @@ package body Prj.Err is -- access to in any case. if Current_Verbosity = High then - Write_Line ("Error in in-memory project, ignored"); + Debug_Output ("Error in in-memory project, ignored"); end if; return; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index c045ab261d6..d05af1b39f2 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -30,6 +30,7 @@ with Output; use Output; with Prj.Com; with Prj.Env; use Prj.Env; with Prj.Err; use Prj.Err; +with Prj.Tree; use Prj.Tree; with Prj.Util; use Prj.Util; with Sinput.P; with Snames; use Snames; @@ -196,8 +197,8 @@ package body Prj.Nmsc is -- Free the memory occupied by Data procedure Check - (Project : Project_Id; - Data : in out Tree_Processing_Data); + (Project : Project_Id; + Data : in out Tree_Processing_Data); -- Process the naming scheme for a single project procedure Initialize @@ -247,7 +248,8 @@ package body Prj.Nmsc is -- expanded pattern was found (1 for the first element of Patterns and -- all its matching directories, then 2,...). -- We use a generic and not an access-to-subprogram because in some cases - -- this code is compiled with the restriction No_Implicit_Dynamic_Code + -- this code is compiled with the restriction No_Implicit_Dynamic_Code. + -- An error message is raised if a pattern does not match any file. procedure Add_Source (Id : out Source_Id; @@ -322,12 +324,6 @@ 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, and find the list of aggregated - -- projects. They are stored as a "project_files" language in Project. - procedure Check_Abstract_Project (Project : Project_Id; Data : in out Tree_Processing_Data); @@ -923,19 +919,27 @@ package body Prj.Nmsc is end if; end Canonical_Case_File_Name; - ----------------------------- - -- Check_Aggregate_Project -- - ----------------------------- + --------------------------------- + -- Process_Aggregated_Projects -- + --------------------------------- - procedure Check_Aggregate_Project - (Project : Project_Id; - Data : in out Tree_Processing_Data) + procedure Process_Aggregated_Projects + (Tree : Project_Tree_Ref; + Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags) is + Data : Tree_Processing_Data := + (Tree => Tree, + Node_Tree => Node_Tree, + File_To_Source => Files_Htable.Nil, + Flags => Flags); + Project_Files : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Project_Files, Project.Decl.Attributes, - Data.Tree); + Tree); Project_Path_For_Aggregate : Prj.Env.Project_Search_Path; @@ -954,7 +958,6 @@ package body Prj.Nmsc is procedure Found_Project_File (Path : Path_Information; Rank : Natural) is pragma Unreferenced (Rank); - Full_Path : Path_Name_Type; begin Debug_Output ("Aggregates: ", Name_Id (Path.Display_Name)); @@ -963,30 +966,37 @@ package body Prj.Nmsc is -- can only do this when processing the aggregate project, since the -- exact list of project files or project directories can depend on -- scenario variables. + -- We only load the projects explicitly here, but do not process + -- them. For the processing, Prj.Proc will take care of processing + -- them, within the same call to Recursive_Process (thus avoiding the + -- processing of a given project multiple times). -- -- ??? We might already have loaded the project - Prj.Env.Find_Project - (Self => Project_Path_For_Aggregate, - Project_File_Name => Get_Name_String (Path.Name), - Directory => Get_Name_String (Project.Path.Name), - Path => Full_Path); + Add_Aggregated_Project (Project, Path => Path.Name); end Found_Project_File; -- Start of processing for Check_Aggregate_Project begin + pragma Assert (Project.Qualifier = Aggregate); + if Project_Files.Default then Error_Msg_Name_1 := Snames.Name_Project_Files; Error_Msg - (Data.Flags, + (Flags, "Attribute %% must be specified in aggregate project", Project.Location, Project); return; end if; + -- The aggregated projects are only searched relative to the directory + -- of the aggregate project, not in the default project path. + Initialize_Empty (Project_Path_For_Aggregate); + Free (Project.Aggregated_Projects); + -- Look for aggregated projects. For similarity with source files and -- dirs, the aggregated project files are not searched for on the -- project path, and are only found through the path specified in @@ -1001,7 +1011,7 @@ package body Prj.Nmsc is Resolve_Links => Opt.Follow_Links_For_Files); Free (Project_Path_For_Aggregate); - end Check_Aggregate_Project; + end Process_Aggregated_Projects; ---------------------------- -- Check_Abstract_Project -- @@ -1058,7 +1068,7 @@ package body Prj.Nmsc is Prj_Data : Project_Processing_Data; begin - Debug_Increase_Indent ("Check ", Project.Name); + Debug_Increase_Indent ("Check", Project.Name); Initialize (Prj_Data, Project); @@ -1074,7 +1084,6 @@ package body Prj.Nmsc is 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; @@ -5222,7 +5231,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then if Project.Object_Directory = No_Path_Information then - Write_Line ("No object directory"); + Debug_Output ("No object directory"); else Write_Attr ("Object directory", @@ -7928,17 +7937,20 @@ package body Prj.Nmsc is Element : String_Element; begin - Debug_Increase_Indent ("Source_Dirs:"); - - Current := Project.Source_Dirs; - while Current /= Nil_String loop - Element := In_Tree.String_Elements.Table (Current); - Write_Str (" "); - Write_Line (Get_Name_String (Element.Display_Value)); - Current := Element.Next; - end loop; + if Project.Source_Dirs = Nil_String then + Debug_Output ("No source dirs"); + else + Debug_Increase_Indent ("Source_Dirs:"); + + Current := Project.Source_Dirs; + while Current /= Nil_String loop + Element := In_Tree.String_Elements.Table (Current); + Debug_Output (Get_Name_String (Element.Display_Value)); + Current := Element.Next; + end loop; - Debug_Decrease_Indent ("end Source_Dirs."); + Debug_Decrease_Indent ("end Source_Dirs."); + end if; end Show_Source_Dirs; --------------------------- diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index ce57e9007c1..47ae06b61da 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -42,4 +42,16 @@ private package Prj.Nmsc is -- Project_Id which contains all the information about the project. This -- information is only valid while the external references are preserved. + procedure Process_Aggregated_Projects + (Tree : Project_Tree_Ref; + Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags); + -- Assuming Project is an aggregate project, find out (based on the + -- current external references) what are the projects it aggregates. + -- This has to be done in phase 1 of the processing, so that we know the + -- full list of languages required for root_project and its aggregated + -- projects. As a result, it cannot be done as part of + -- Process_Naming_Scheme. + end Prj.Nmsc; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 5167da4a3f0..7fedc86e368 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -1870,7 +1870,7 @@ package body Prj.Part is Tree.Restore_And_Free (Project_Comment_State); - Debug_Decrease_Indent ("Done parsing project"); + Debug_Decrease_Indent; end Parse_Single_Project; ----------------------- diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index f007a718948..ddab4362fd8 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,7 @@ with Prj.Attr; use Prj.Attr; with Prj.Err; use Prj.Err; with Prj.Ext; use Prj.Ext; with Prj.Nmsc; use Prj.Nmsc; +with Prj.Part; with Snames; with Ada.Strings.Fixed; use Ada.Strings.Fixed; @@ -128,7 +129,7 @@ package body Prj.Proc is In_Tree : Project_Tree_Ref; Flags : Processing_Flags; From_Project_Node : Project_Node_Id; - From_Project_Node_Tree : Project_Node_Tree_Ref; + Node_Tree : Project_Node_Tree_Ref; Pkg : Package_Id; Item : Project_Node_Id); -- Process declarative items starting with From_Project_Node, and put them @@ -1421,7 +1422,7 @@ package body Prj.Proc is In_Tree : Project_Tree_Ref; Flags : Processing_Flags; From_Project_Node : Project_Node_Id; - From_Project_Node_Tree : Project_Node_Tree_Ref; + Node_Tree : Project_Node_Tree_Ref; Pkg : Package_Id; Item : Project_Node_Id) is @@ -1433,6 +1434,23 @@ package body Prj.Proc is -- reported, or a warning, or nothing. In the last two cases, the value -- of the variable is set to a valid value, replacing Value. + procedure Process_Package_Declaration + (Current_Item : Project_Node_Id); + procedure Process_Attribute_Declaration (Current : Project_Node_Id); + procedure Process_Case_Construction + (Current_Item : Project_Node_Id); + procedure Process_Associative_Array + (Current_Item : Project_Node_Id); + procedure Process_Expression + (Current : Project_Node_Id); + procedure Process_Expression_For_Associative_Array + (Current_Item : Project_Node_Id; + New_Value : Variable_Value); + procedure Process_Expression_Variable_Decl + (Current_Item : Project_Node_Id; + New_Value : Variable_Value); + -- Process the various declarative items + --------------------------------- -- Check_Or_Set_Typed_Variable -- --------------------------------- @@ -1441,8 +1459,7 @@ package body Prj.Proc is (Value : in out Variable_Value; Declaration : Project_Node_Id) is - Loc : constant Source_Ptr := - Location_Of (Declaration, From_Project_Node_Tree); + Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree); Reset_Value : Boolean := False; Current_String : Project_Node_Id; @@ -1451,7 +1468,7 @@ package body Prj.Proc is -- Report an error for an empty string if Value.Value = Empty_String then - Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree); + Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree); case Flags.Allow_Invalid_External is when Error => @@ -1467,24 +1484,22 @@ package body Prj.Proc is -- Loop through all the valid strings for the -- string type and compare to the string value. - Current_String := - First_Literal_String - (String_Type_Of (Declaration, From_Project_Node_Tree), - From_Project_Node_Tree); + Current_String := First_Literal_String + (String_Type_Of (Declaration, Node_Tree), Node_Tree); + while Present (Current_String) - and then String_Value_Of - (Current_String, From_Project_Node_Tree) /= Value.Value + and then String_Value_Of (Current_String, Node_Tree) /= + Value.Value loop Current_String := - Next_Literal_String (Current_String, From_Project_Node_Tree); + Next_Literal_String (Current_String, Node_Tree); end loop; -- Report error if string value is not one for the string type if No (Current_String) then Error_Msg_Name_1 := Value.Value; - Error_Msg_Name_2 := - Name_Of (Declaration, From_Project_Node_Tree); + Error_Msg_Name_2 := Name_Of (Declaration, Node_Tree); case Flags.Allow_Invalid_External is when Error => @@ -1505,909 +1520,801 @@ package body Prj.Proc is if Reset_Value then Current_String := First_Literal_String - (String_Type_Of (Declaration, From_Project_Node_Tree), - From_Project_Node_Tree); - - Value.Value := String_Value_Of - (Current_String, From_Project_Node_Tree); + (String_Type_Of (Declaration, Node_Tree), Node_Tree); + Value.Value := String_Value_Of (Current_String, Node_Tree); end if; end Check_Or_Set_Typed_Variable; - -- Local variables - - Current_Declarative_Item : Project_Node_Id; - Current_Item : Project_Node_Id; + --------------------------------- + -- Process_Package_Declaration -- + --------------------------------- - -- Start of processing for Process_Declarative_Items + procedure Process_Package_Declaration + (Current_Item : Project_Node_Id) is + begin + -- Do not process a package declaration that should be ignored - begin - -- Loop through declarative items + if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then + -- Create the new package - Current_Item := Empty_Node; + Package_Table.Increment_Last (In_Tree.Packages); - Current_Declarative_Item := Item; - while Present (Current_Declarative_Item) loop + declare + New_Pkg : constant Package_Id := + Package_Table.Last (In_Tree.Packages); + The_New_Package : Package_Element; - -- Get its data + Project_Of_Renamed_Package : constant Project_Node_Id := + Project_Of_Renamed_Package_Of (Current_Item, Node_Tree); - Current_Item := - Current_Item_Node - (Current_Declarative_Item, From_Project_Node_Tree); + begin + -- Set the name of the new package - -- And set Current_Declarative_Item to the next declarative item - -- ready for the next iteration. + The_New_Package.Name := Name_Of (Current_Item, Node_Tree); - Current_Declarative_Item := - Next_Declarative_Item - (Current_Declarative_Item, From_Project_Node_Tree); + -- Insert the new package in the appropriate list - case Kind_Of (Current_Item, From_Project_Node_Tree) is + if Pkg /= No_Package then + The_New_Package.Next := + In_Tree.Packages.Table (Pkg).Decl.Packages; + In_Tree.Packages.Table (Pkg).Decl.Packages := New_Pkg; - when N_Package_Declaration => + else + The_New_Package.Next := Project.Decl.Packages; + Project.Decl.Packages := New_Pkg; + end if; - -- Do not process a package declaration that should be ignored + In_Tree.Packages.Table (New_Pkg) := The_New_Package; - if Expression_Kind_Of - (Current_Item, From_Project_Node_Tree) /= Ignored - then - -- Create the new package + if Present (Project_Of_Renamed_Package) then - Package_Table.Increment_Last (In_Tree.Packages); + -- Renamed or extending package declare - New_Pkg : constant Package_Id := - Package_Table.Last (In_Tree.Packages); - The_New_Package : Package_Element; + Project_Name : constant Name_Id := + Name_Of (Project_Of_Renamed_Package, Node_Tree); + + Renamed_Project : constant Project_Id := + Imported_Or_Extended_Project_From + (Project, Project_Name); - Project_Of_Renamed_Package : - constant Project_Node_Id := - Project_Of_Renamed_Package_Of - (Current_Item, From_Project_Node_Tree); + Renamed_Package : constant Package_Id := + Package_From + (Renamed_Project, In_Tree, + Name_Of (Current_Item, Node_Tree)); begin - -- Set the name of the new package + -- For a renamed package, copy the declarations of + -- the renamed package, but set all the locations + -- to the location of the package name in the + -- renaming declaration. + + Copy_Package_Declarations + (From => In_Tree.Packages.Table (Renamed_Package).Decl, + To => In_Tree.Packages.Table (New_Pkg).Decl, + New_Loc => Location_Of (Current_Item, Node_Tree), + Restricted => False, + In_Tree => In_Tree); + end; - The_New_Package.Name := - Name_Of (Current_Item, From_Project_Node_Tree); + else + -- Set the default values of the attributes + + Add_Attributes + (Project, + Project.Name, + Name_Id (Project.Directory.Name), + In_Tree, + In_Tree.Packages.Table (New_Pkg).Decl, + First_Attribute_Of + (Package_Id_Of (Current_Item, Node_Tree)), + Project_Level => False); + end if; - -- Insert the new package in the appropriate list + -- Process declarative items (nothing to do when the + -- package is renaming, as the first declarative item is + -- null). - if Pkg /= No_Package then - The_New_Package.Next := - In_Tree.Packages.Table (Pkg).Decl.Packages; - In_Tree.Packages.Table (Pkg).Decl.Packages := - New_Pkg; + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + Node_Tree => Node_Tree, + Pkg => New_Pkg, + Item => + First_Declarative_Item_Of (Current_Item, Node_Tree)); + end; + end if; + end Process_Package_Declaration; - else - The_New_Package.Next := Project.Decl.Packages; - Project.Decl.Packages := New_Pkg; - end if; + ------------------------------- + -- Process_Associative_Array -- + ------------------------------- - In_Tree.Packages.Table (New_Pkg) := - The_New_Package; + procedure Process_Associative_Array + (Current_Item : Project_Node_Id) + is + Current_Item_Name : constant Name_Id := + Name_Of (Current_Item, Node_Tree); + -- The name of the attribute - if Present (Project_Of_Renamed_Package) then + Current_Location : constant Source_Ptr := + Location_Of (Current_Item, Node_Tree); - -- Renamed or extending package + New_Array : Array_Id; + -- The new associative array created - declare - Project_Name : constant Name_Id := - Name_Of - (Project_Of_Renamed_Package, - From_Project_Node_Tree); - - Renamed_Project : - constant Project_Id := - Imported_Or_Extended_Project_From - (Project, Project_Name); - - Renamed_Package : constant Package_Id := - Package_From - (Renamed_Project, In_Tree, - Name_Of - (Current_Item, - From_Project_Node_Tree)); + Orig_Array : Array_Id; + -- The associative array value - begin - -- For a renamed package, copy the declarations of - -- the renamed package, but set all the locations - -- to the location of the package name in the - -- renaming declaration. - - Copy_Package_Declarations - (From => - In_Tree.Packages.Table (Renamed_Package).Decl, - To => - In_Tree.Packages.Table (New_Pkg).Decl, - New_Loc => - Location_Of - (Current_Item, From_Project_Node_Tree), - Restricted => False, - In_Tree => In_Tree); - end; + Orig_Project_Name : Name_Id := No_Name; + -- The name of the project where the associative array + -- value is. - else - -- Set the default values of the attributes - - Add_Attributes - (Project, - Project.Name, - Name_Id (Project.Directory.Name), - In_Tree, - In_Tree.Packages.Table (New_Pkg).Decl, - First_Attribute_Of - (Package_Id_Of - (Current_Item, From_Project_Node_Tree)), - Project_Level => False); + Orig_Project : Project_Id := No_Project; + -- The id of the project where the associative array + -- value is. - end if; + Orig_Package_Name : Name_Id := No_Name; + -- The name of the package, if any, where the associative + -- array value is. - -- Process declarative items (nothing to do when the - -- package is renaming, as the first declarative item is - -- null). + Orig_Package : Package_Id := No_Package; + -- The id of the package, if any, where the associative + -- array value is. - Process_Declarative_Items - (Project => Project, - In_Tree => In_Tree, - Flags => Flags, - From_Project_Node => From_Project_Node, - From_Project_Node_Tree => From_Project_Node_Tree, - Pkg => New_Pkg, - Item => - First_Declarative_Item_Of - (Current_Item, From_Project_Node_Tree)); - end; - end if; + New_Element : Array_Element_Id := No_Array_Element; + -- Id of a new array element created - when N_String_Type_Declaration => + Prev_Element : Array_Element_Id := No_Array_Element; + -- Last new element id created - -- There is nothing to process + Orig_Element : Array_Element_Id := No_Array_Element; + -- Current array element in original associative array - null; + Next_Element : Array_Element_Id := No_Array_Element; + -- Id of the array element that follows the new element. + -- This is not always nil, because values for the + -- associative array attribute may already have been + -- declared, and the array elements declared are reused. - when N_Attribute_Declaration | - N_Typed_Variable_Declaration | - N_Variable_Declaration => + Prj : Project_List; - if Expression_Of (Current_Item, From_Project_Node_Tree) = - Empty_Node - then + begin + -- First find if the associative array attribute already + -- has elements declared. - -- It must be a full associative array attribute declaration + if Pkg /= No_Package then + New_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays; + else + New_Array := Project.Decl.Arrays; + end if; - declare - Current_Item_Name : constant Name_Id := - Name_Of - (Current_Item, - From_Project_Node_Tree); - -- The name of the attribute + while New_Array /= No_Array + and then In_Tree.Arrays.Table (New_Array).Name /= Current_Item_Name + loop + New_Array := In_Tree.Arrays.Table (New_Array).Next; + end loop; - Current_Location : constant Source_Ptr := - Location_Of - (Current_Item, - From_Project_Node_Tree); + -- If the attribute has never been declared add new entry + -- in the arrays of the project/package and link it. - New_Array : Array_Id; - -- The new associative array created + if New_Array = No_Array then + Array_Table.Increment_Last (In_Tree.Arrays); + New_Array := Array_Table.Last (In_Tree.Arrays); - Orig_Array : Array_Id; - -- The associative array value + if Pkg /= No_Package then + In_Tree.Arrays.Table (New_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Packages.Table (Pkg).Decl.Arrays); - Orig_Project_Name : Name_Id := No_Name; - -- The name of the project where the associative array - -- value is. + In_Tree.Packages.Table (Pkg).Decl.Arrays := New_Array; - Orig_Project : Project_Id := No_Project; - -- The id of the project where the associative array - -- value is. + else + In_Tree.Arrays.Table (New_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Project.Decl.Arrays); - Orig_Package_Name : Name_Id := No_Name; - -- The name of the package, if any, where the associative - -- array value is. + Project.Decl.Arrays := New_Array; + end if; + end if; - Orig_Package : Package_Id := No_Package; - -- The id of the package, if any, where the associative - -- array value is. + -- Find the project where the value is declared - New_Element : Array_Element_Id := No_Array_Element; - -- Id of a new array element created + Orig_Project_Name := + Name_Of + (Associative_Project_Of (Current_Item, Node_Tree), Node_Tree); - Prev_Element : Array_Element_Id := No_Array_Element; - -- Last new element id created + Prj := In_Tree.Projects; + while Prj /= null loop + if Prj.Project.Name = Orig_Project_Name then + Orig_Project := Prj.Project; + exit; + end if; + Prj := Prj.Next; + end loop; - Orig_Element : Array_Element_Id := No_Array_Element; - -- Current array element in original associative array + pragma Assert (Orig_Project /= No_Project, + "original project not found"); - Next_Element : Array_Element_Id := No_Array_Element; - -- Id of the array element that follows the new element. - -- This is not always nil, because values for the - -- associative array attribute may already have been - -- declared, and the array elements declared are reused. + if No (Associative_Package_Of (Current_Item, Node_Tree)) then + Orig_Array := Orig_Project.Decl.Arrays; - Prj : Project_List; + else + -- If in a package, find the package where the value + -- is declared. - begin - -- First find if the associative array attribute already - -- has elements declared. + Orig_Package_Name := + Name_Of + (Associative_Package_Of (Current_Item, Node_Tree), Node_Tree); - if Pkg /= No_Package then - New_Array := In_Tree.Packages.Table - (Pkg).Decl.Arrays; + Orig_Package := Orig_Project.Decl.Packages; + pragma Assert (Orig_Package /= No_Package, + "original package not found"); - else - New_Array := Project.Decl.Arrays; - end if; + while In_Tree.Packages.Table + (Orig_Package).Name /= Orig_Package_Name + loop + Orig_Package := In_Tree.Packages.Table (Orig_Package).Next; + pragma Assert (Orig_Package /= No_Package, + "original package not found"); + end loop; - while New_Array /= No_Array - and then In_Tree.Arrays.Table (New_Array).Name /= - Current_Item_Name - loop - New_Array := In_Tree.Arrays.Table (New_Array).Next; - end loop; + Orig_Array := In_Tree.Packages.Table (Orig_Package).Decl.Arrays; + end if; - -- If the attribute has never been declared add new entry - -- in the arrays of the project/package and link it. + -- Now look for the array - if New_Array = No_Array then - Array_Table.Increment_Last (In_Tree.Arrays); - New_Array := Array_Table.Last (In_Tree.Arrays); + while Orig_Array /= No_Array + and then In_Tree.Arrays.Table (Orig_Array).Name /= Current_Item_Name + loop + Orig_Array := In_Tree.Arrays.Table (Orig_Array).Next; + end loop; - if Pkg /= No_Package then - In_Tree.Arrays.Table (New_Array) := - (Name => Current_Item_Name, - Location => Current_Location, - Value => No_Array_Element, - Next => In_Tree.Packages.Table - (Pkg).Decl.Arrays); + if Orig_Array = No_Array then + Error_Msg + (Flags, + "associative array value not found", + Location_Of (Current_Item, Node_Tree), + Project); - In_Tree.Packages.Table (Pkg).Decl.Arrays := - New_Array; + else + Orig_Element := In_Tree.Arrays.Table (Orig_Array).Value; - else - In_Tree.Arrays.Table (New_Array) := - (Name => Current_Item_Name, - Location => Current_Location, - Value => No_Array_Element, - Next => Project.Decl.Arrays); + -- Copy each array element - Project.Decl.Arrays := New_Array; - end if; - end if; + while Orig_Element /= No_Array_Element loop - -- Find the project where the value is declared + -- Case of first element - Orig_Project_Name := - Name_Of - (Associative_Project_Of - (Current_Item, From_Project_Node_Tree), - From_Project_Node_Tree); + if Prev_Element = No_Array_Element then - Prj := In_Tree.Projects; - while Prj /= null loop - if Prj.Project.Name = Orig_Project_Name then - Orig_Project := Prj.Project; - exit; - end if; - Prj := Prj.Next; - end loop; + -- And there is no array element declared yet, + -- create a new first array element. - pragma Assert (Orig_Project /= No_Project, - "original project not found"); + if In_Tree.Arrays.Table (New_Array).Value = + No_Array_Element + then + Array_Element_Table.Increment_Last + (In_Tree.Array_Elements); + New_Element := Array_Element_Table.Last + (In_Tree.Array_Elements); + In_Tree.Arrays.Table (New_Array).Value := New_Element; + Next_Element := No_Array_Element; - if No (Associative_Package_Of - (Current_Item, From_Project_Node_Tree)) - then - Orig_Array := Orig_Project.Decl.Arrays; + -- Otherwise, the new element is the first - else - -- If in a package, find the package where the value - -- is declared. + else + New_Element := In_Tree.Arrays. Table (New_Array).Value; + Next_Element := + In_Tree.Array_Elements.Table (New_Element).Next; + end if; - Orig_Package_Name := - Name_Of - (Associative_Package_Of - (Current_Item, From_Project_Node_Tree), - From_Project_Node_Tree); + -- Otherwise, reuse an existing element, or create + -- one if necessary. - Orig_Package := Orig_Project.Decl.Packages; - pragma Assert (Orig_Package /= No_Package, - "original package not found"); + else + Next_Element := + In_Tree.Array_Elements.Table (Prev_Element).Next; - while In_Tree.Packages.Table - (Orig_Package).Name /= Orig_Package_Name - loop - Orig_Package := In_Tree.Packages.Table - (Orig_Package).Next; - pragma Assert (Orig_Package /= No_Package, - "original package not found"); - end loop; + if Next_Element = No_Array_Element then + Array_Element_Table.Increment_Last + (In_Tree.Array_Elements); + New_Element := + Array_Element_Table.Last (In_Tree.Array_Elements); + In_Tree.Array_Elements.Table (Prev_Element).Next := + New_Element; - Orig_Array := - In_Tree.Packages.Table (Orig_Package).Decl.Arrays; - end if; + else + New_Element := Next_Element; + Next_Element := + In_Tree.Array_Elements.Table (New_Element).Next; + end if; + end if; - -- Now look for the array + -- Copy the value of the element - while Orig_Array /= No_Array - and then In_Tree.Arrays.Table (Orig_Array).Name /= - Current_Item_Name - loop - Orig_Array := In_Tree.Arrays.Table - (Orig_Array).Next; - end loop; + In_Tree.Array_Elements.Table (New_Element) := + In_Tree.Array_Elements.Table (Orig_Element); + In_Tree.Array_Elements.Table (New_Element).Value.Project := + Project; - if Orig_Array = No_Array then - Error_Msg - (Flags, - "associative array value not found", - Location_Of (Current_Item, From_Project_Node_Tree), - Project); + -- Adjust the Next link - else - Orig_Element := - In_Tree.Arrays.Table (Orig_Array).Value; + In_Tree.Array_Elements.Table (New_Element).Next := Next_Element; - -- Copy each array element + -- Adjust the previous id for the next element - while Orig_Element /= No_Array_Element loop + Prev_Element := New_Element; - -- Case of first element + -- Go to the next element in the original array - if Prev_Element = No_Array_Element then + Orig_Element := + In_Tree.Array_Elements.Table (Orig_Element).Next; + end loop; - -- And there is no array element declared yet, - -- create a new first array element. + -- Make sure that the array ends here, in case there + -- previously a greater number of elements. - if In_Tree.Arrays.Table (New_Array).Value = - No_Array_Element - then - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - New_Element := Array_Element_Table.Last - (In_Tree.Array_Elements); - In_Tree.Arrays.Table - (New_Array).Value := New_Element; - Next_Element := No_Array_Element; + In_Tree.Array_Elements.Table (New_Element).Next := + No_Array_Element; + end if; + end Process_Associative_Array; - -- Otherwise, the new element is the first + ---------------------------------------------- + -- Process_Expression_For_Associative_Array -- + ---------------------------------------------- - else - New_Element := In_Tree.Arrays. - Table (New_Array).Value; - Next_Element := - In_Tree.Array_Elements.Table - (New_Element).Next; - end if; + procedure Process_Expression_For_Associative_Array + (Current_Item : Project_Node_Id; + New_Value : Variable_Value) + is + Current_Item_Name : constant Name_Id := + Name_Of (Current_Item, Node_Tree); + Current_Location : constant Source_Ptr := + Location_Of (Current_Item, Node_Tree); - -- Otherwise, reuse an existing element, or create - -- one if necessary. + Index_Name : Name_Id := + Associative_Array_Index_Of (Current_Item, Node_Tree); - else - Next_Element := - In_Tree.Array_Elements.Table - (Prev_Element).Next; + Source_Index : constant Int := + Source_Index_Of (Current_Item, Node_Tree); - if Next_Element = No_Array_Element then - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - New_Element := - Array_Element_Table.Last - (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Prev_Element).Next := New_Element; + The_Array : Array_Id; + The_Array_Element : Array_Element_Id := No_Array_Element; - else - New_Element := Next_Element; - Next_Element := - In_Tree.Array_Elements.Table - (New_Element).Next; - end if; - end if; + begin + if Index_Name /= All_Other_Names then + Index_Name := Get_Attribute_Index + (Node_Tree, + Current_Item, + Associative_Array_Index_Of (Current_Item, Node_Tree)); + end if; - -- Copy the value of the element + -- Look for the array in the appropriate list - In_Tree.Array_Elements.Table - (New_Element) := - In_Tree.Array_Elements.Table (Orig_Element); - In_Tree.Array_Elements.Table - (New_Element).Value.Project := Project; + if Pkg /= No_Package then + The_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays; + else + The_Array := Project.Decl.Arrays; + end if; - -- Adjust the Next link + while The_Array /= No_Array + and then In_Tree.Arrays.Table (The_Array).Name /= Current_Item_Name + loop + The_Array := In_Tree.Arrays.Table (The_Array).Next; + end loop; - In_Tree.Array_Elements.Table - (New_Element).Next := Next_Element; + -- If the array cannot be found, create a new entry + -- in the list. As The_Array_Element is initialized + -- to No_Array_Element, a new element will be + -- created automatically later - -- Adjust the previous id for the next element + if The_Array = No_Array then + Array_Table.Increment_Last (In_Tree.Arrays); + The_Array := Array_Table.Last (In_Tree.Arrays); - Prev_Element := New_Element; + if Pkg /= No_Package then + In_Tree.Arrays.Table (The_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => In_Tree.Packages.Table (Pkg).Decl.Arrays); - -- Go to the next element in the original array + In_Tree.Packages.Table (Pkg).Decl.Arrays := The_Array; - Orig_Element := - In_Tree.Array_Elements.Table - (Orig_Element).Next; - end loop; + else + In_Tree.Arrays.Table (The_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Project.Decl.Arrays); - -- Make sure that the array ends here, in case there - -- previously a greater number of elements. + Project.Decl.Arrays := The_Array; + end if; - In_Tree.Array_Elements.Table - (New_Element).Next := No_Array_Element; - end if; - end; + -- Otherwise initialize The_Array_Element as the + -- head of the element list. - -- Declarations other that full associative arrays + else + The_Array_Element := In_Tree.Arrays.Table (The_Array).Value; + end if; - else - declare - New_Value : Variable_Value := - Expression - (Project => Project, - In_Tree => In_Tree, - Flags => Flags, - From_Project_Node => From_Project_Node, - From_Project_Node_Tree => From_Project_Node_Tree, - Pkg => Pkg, - First_Term => - Tree.First_Term - (Expression_Of - (Current_Item, From_Project_Node_Tree), - From_Project_Node_Tree), - Kind => - Expression_Kind_Of - (Current_Item, From_Project_Node_Tree)); - -- The expression value - - The_Variable : Variable_Id := No_Variable; - - Current_Item_Name : constant Name_Id := - Name_Of - (Current_Item, - From_Project_Node_Tree); - - Current_Location : constant Source_Ptr := - Location_Of - (Current_Item, - From_Project_Node_Tree); + -- Look in the list, if any, to find an element + -- with the same index and same source index. - begin - -- Process a typed variable declaration - - if Kind_Of (Current_Item, From_Project_Node_Tree) = - N_Typed_Variable_Declaration - then - Check_Or_Set_Typed_Variable - (Value => New_Value, - Declaration => Current_Item); - end if; + while The_Array_Element /= No_Array_Element + and then + (In_Tree.Array_Elements.Table (The_Array_Element).Index /= + Index_Name + or else + In_Tree.Array_Elements.Table (The_Array_Element).Src_Index /= + Source_Index) + loop + The_Array_Element := + In_Tree.Array_Elements.Table (The_Array_Element).Next; + end loop; - -- Comment here ??? + -- If no such element were found, create a new one + -- and insert it in the element list, with the + -- proper value. - if Kind_Of (Current_Item, From_Project_Node_Tree) /= - N_Attribute_Declaration - or else - Associative_Array_Index_Of - (Current_Item, From_Project_Node_Tree) = No_Name - then - -- Case of a variable declaration or of a not - -- associative array attribute. + if The_Array_Element = No_Array_Element then + Array_Element_Table.Increment_Last (In_Tree.Array_Elements); + The_Array_Element := + Array_Element_Table.Last (In_Tree.Array_Elements); - -- First, find the list where to find the variable - -- or attribute. + In_Tree.Array_Elements.Table + (The_Array_Element) := + (Index => Index_Name, + Src_Index => Source_Index, + Index_Case_Sensitive => + not Case_Insensitive (Current_Item, Node_Tree), + Value => New_Value, + Next => In_Tree.Arrays.Table (The_Array).Value); - if Kind_Of (Current_Item, From_Project_Node_Tree) = - N_Attribute_Declaration - then - if Pkg /= No_Package then - The_Variable := - In_Tree.Packages.Table - (Pkg).Decl.Attributes; - else - The_Variable := Project.Decl.Attributes; - end if; + In_Tree.Arrays.Table (The_Array).Value := The_Array_Element; - else - if Pkg /= No_Package then - The_Variable := - In_Tree.Packages.Table - (Pkg).Decl.Variables; - else - The_Variable := Project.Decl.Variables; - end if; + -- An element with the same index already exists, + -- just replace its value with the new one. - end if; + else + In_Tree.Array_Elements.Table (The_Array_Element).Value := + New_Value; + end if; + end Process_Expression_For_Associative_Array; - -- Loop through the list, to find if it has already - -- been declared. + -------------------------------------- + -- Process_Expression_Variable_Decl -- + -------------------------------------- - while The_Variable /= No_Variable - and then - In_Tree.Variable_Elements.Table - (The_Variable).Name /= Current_Item_Name - loop - The_Variable := - In_Tree.Variable_Elements.Table - (The_Variable).Next; - end loop; + procedure Process_Expression_Variable_Decl + (Current_Item : Project_Node_Id; + New_Value : Variable_Value) + is + Current_Item_Name : constant Name_Id := + Name_Of (Current_Item, Node_Tree); + The_Variable : Variable_Id := No_Variable; - -- If it has not been declared, create a new entry - -- in the list. + begin + -- First, find the list where to find the variable or attribute. - if The_Variable = No_Variable then + if Kind_Of (Current_Item, Node_Tree) = + N_Attribute_Declaration + then + if Pkg /= No_Package then + The_Variable := In_Tree.Packages.Table (Pkg).Decl.Attributes; + else + The_Variable := Project.Decl.Attributes; + end if; - -- All single string attribute should already have - -- been declared with a default empty string value. + else + if Pkg /= No_Package then + The_Variable := In_Tree.Packages.Table (Pkg).Decl.Variables; + else + The_Variable := Project.Decl.Variables; + end if; + end if; - pragma Assert - (Kind_Of (Current_Item, From_Project_Node_Tree) /= - N_Attribute_Declaration, - "illegal attribute declaration for " - & Get_Name_String (Current_Item_Name)); + -- Loop through the list, to find if it has already been declared. - Variable_Element_Table.Increment_Last - (In_Tree.Variable_Elements); - The_Variable := Variable_Element_Table.Last - (In_Tree.Variable_Elements); + while The_Variable /= No_Variable + and then In_Tree.Variable_Elements.Table (The_Variable).Name /= + Current_Item_Name + loop + The_Variable := + In_Tree.Variable_Elements.Table (The_Variable).Next; + end loop; - -- Put the new variable in the appropriate list + -- If it has not been declared, create a new entry + -- in the list. - if Pkg /= No_Package then - In_Tree.Variable_Elements.Table (The_Variable) := - (Next => - In_Tree.Packages.Table - (Pkg).Decl.Variables, - Name => Current_Item_Name, - Value => New_Value); - In_Tree.Packages.Table - (Pkg).Decl.Variables := The_Variable; + if The_Variable = No_Variable then - else - In_Tree.Variable_Elements.Table (The_Variable) := - (Next => Project.Decl.Variables, - Name => Current_Item_Name, - Value => New_Value); - Project.Decl.Variables := The_Variable; - end if; + -- All single string attribute should already have + -- been declared with a default empty string value. - -- If the variable/attribute has already been - -- declared, just change the value. + pragma Assert + (Kind_Of (Current_Item, Node_Tree) /= + N_Attribute_Declaration, + "illegal attribute declaration for " + & Get_Name_String (Current_Item_Name)); - else - In_Tree.Variable_Elements.Table - (The_Variable).Value := New_Value; - end if; + Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements); + The_Variable := Variable_Element_Table.Last + (In_Tree.Variable_Elements); - -- Associative array attribute + -- Put the new variable in the appropriate list - else - declare - Index_Name : Name_Id := - Associative_Array_Index_Of - (Current_Item, - From_Project_Node_Tree); + if Pkg /= No_Package then + In_Tree.Variable_Elements.Table (The_Variable) := + (Next => In_Tree.Packages.Table (Pkg).Decl.Variables, + Name => Current_Item_Name, + Value => New_Value); + In_Tree.Packages.Table (Pkg).Decl.Variables := The_Variable; - Source_Index : constant Int := - Source_Index_Of - (Current_Item, - From_Project_Node_Tree); + else + In_Tree.Variable_Elements.Table (The_Variable) := + (Next => Project.Decl.Variables, + Name => Current_Item_Name, + Value => New_Value); + Project.Decl.Variables := The_Variable; + end if; - The_Array : Array_Id; - The_Array_Element : Array_Element_Id := - No_Array_Element; + -- If the variable/attribute has already been + -- declared, just change the value. - begin - if Index_Name /= All_Other_Names then - Index_Name := Get_Attribute_Index - (From_Project_Node_Tree, - Current_Item, - Associative_Array_Index_Of - (Current_Item, From_Project_Node_Tree)); - end if; + else + In_Tree.Variable_Elements.Table (The_Variable).Value := New_Value; + end if; + end Process_Expression_Variable_Decl; - -- Look for the array in the appropriate list + ------------------------ + -- Process_Expression -- + ------------------------ - if Pkg /= No_Package then - The_Array := - In_Tree.Packages.Table (Pkg).Decl.Arrays; - else - The_Array := - Project.Decl.Arrays; - end if; + procedure Process_Expression + (Current : Project_Node_Id) + is + New_Value : Variable_Value := + Expression + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => Node_Tree, + Pkg => Pkg, + First_Term => + Tree.First_Term + (Expression_Of (Current, Node_Tree), Node_Tree), + Kind => Expression_Kind_Of (Current, Node_Tree)); - while - The_Array /= No_Array - and then - In_Tree.Arrays.Table (The_Array).Name /= - Current_Item_Name - loop - The_Array := - In_Tree.Arrays.Table (The_Array).Next; - end loop; + begin + -- Process a typed variable declaration - -- If the array cannot be found, create a new entry - -- in the list. As The_Array_Element is initialized - -- to No_Array_Element, a new element will be - -- created automatically later + if Kind_Of (Current, Node_Tree) = + N_Typed_Variable_Declaration + then + Check_Or_Set_Typed_Variable (New_Value, Current); + end if; - if The_Array = No_Array then - Array_Table.Increment_Last (In_Tree.Arrays); - The_Array := Array_Table.Last (In_Tree.Arrays); + if Kind_Of (Current, Node_Tree) /= N_Attribute_Declaration + or else Associative_Array_Index_Of (Current, Node_Tree) = No_Name + then + Process_Expression_Variable_Decl (Current, New_Value); + else + Process_Expression_For_Associative_Array (Current, New_Value); + end if; + end Process_Expression; - if Pkg /= No_Package then - In_Tree.Arrays.Table (The_Array) := - (Name => Current_Item_Name, - Location => Current_Location, - Value => No_Array_Element, - Next => In_Tree.Packages.Table - (Pkg).Decl.Arrays); + ----------------------------------- + -- Process_Attribute_Declaration -- + ----------------------------------- - In_Tree.Packages.Table (Pkg).Decl.Arrays := - The_Array; + procedure Process_Attribute_Declaration (Current : Project_Node_Id) is + begin + if Expression_Of (Current, Node_Tree) = Empty_Node then + Process_Associative_Array (Current); + else + Process_Expression (Current); + end if; + end Process_Attribute_Declaration; - else - In_Tree.Arrays.Table (The_Array) := - (Name => Current_Item_Name, - Location => Current_Location, - Value => No_Array_Element, - Next => Project.Decl.Arrays); + ------------------------------- + -- Process_Case_Construction -- + ------------------------------- - Project.Decl.Arrays := The_Array; - end if; + procedure Process_Case_Construction + (Current_Item : Project_Node_Id) + is + The_Project : Project_Id := Project; + -- The id of the project of the case variable - -- Otherwise initialize The_Array_Element as the - -- head of the element list. + The_Package : Package_Id := Pkg; + -- The id of the package, if any, of the case variable - else - The_Array_Element := - In_Tree.Arrays.Table (The_Array).Value; - end if; + The_Variable : Variable_Value := Nil_Variable_Value; + -- The case variable - -- Look in the list, if any, to find an element - -- with the same index and same source index. + Case_Value : Name_Id := No_Name; + -- The case variable value - while The_Array_Element /= No_Array_Element - and then - (In_Tree.Array_Elements.Table - (The_Array_Element).Index /= Index_Name - or else - In_Tree.Array_Elements.Table - (The_Array_Element).Src_Index /= Source_Index) - loop - The_Array_Element := - In_Tree.Array_Elements.Table - (The_Array_Element).Next; - end loop; + Case_Item : Project_Node_Id := Empty_Node; + Choice_String : Project_Node_Id := Empty_Node; + Decl_Item : Project_Node_Id := Empty_Node; - -- If no such element were found, create a new one - -- and insert it in the element list, with the - -- proper value. - - if The_Array_Element = No_Array_Element then - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - The_Array_Element := - Array_Element_Table.Last - (In_Tree.Array_Elements); - - In_Tree.Array_Elements.Table - (The_Array_Element) := - (Index => Index_Name, - Src_Index => Source_Index, - Index_Case_Sensitive => - not Case_Insensitive - (Current_Item, From_Project_Node_Tree), - Value => New_Value, - Next => - In_Tree.Arrays.Table (The_Array).Value); - - In_Tree.Arrays.Table (The_Array).Value := - The_Array_Element; - - -- An element with the same index already exists, - -- just replace its value with the new one. + begin + declare + Variable_Node : constant Project_Node_Id := + Case_Variable_Reference_Of + (Current_Item, + Node_Tree); - else - In_Tree.Array_Elements.Table - (The_Array_Element).Value := New_Value; - end if; - end; - end if; - end; - end if; + Var_Id : Variable_Id := No_Variable; + Name : Name_Id := No_Name; - when N_Case_Construction => - declare - The_Project : Project_Id := Project; - -- The id of the project of the case variable + begin + -- If a project was specified for the case variable, + -- get its id. + + if Present (Project_Node_Of (Variable_Node, Node_Tree)) then + Name := + Name_Of + (Project_Node_Of (Variable_Node, Node_Tree), Node_Tree); + The_Project := + Imported_Or_Extended_Project_From (Project, Name); + end if; - The_Package : Package_Id := Pkg; - -- The id of the package, if any, of the case variable + -- If a package were specified for the case variable, + -- get its id. - The_Variable : Variable_Value := Nil_Variable_Value; - -- The case variable + if Present (Package_Node_Of (Variable_Node, Node_Tree)) then + Name := + Name_Of + (Package_Node_Of (Variable_Node, Node_Tree), Node_Tree); + The_Package := Package_From (The_Project, In_Tree, Name); + end if; - Case_Value : Name_Id := No_Name; - -- The case variable value + Name := Name_Of (Variable_Node, Node_Tree); - Case_Item : Project_Node_Id := Empty_Node; - Choice_String : Project_Node_Id := Empty_Node; - Decl_Item : Project_Node_Id := Empty_Node; + -- First, look for the case variable into the package, + -- if any. - begin - declare - Variable_Node : constant Project_Node_Id := - Case_Variable_Reference_Of - (Current_Item, - From_Project_Node_Tree); + if The_Package /= No_Package then + Var_Id := In_Tree.Packages.Table (The_Package).Decl.Variables; + Name := Name_Of (Variable_Node, Node_Tree); + while Var_Id /= No_Variable + and then In_Tree.Variable_Elements.Table (Var_Id).Name /= Name + loop + Var_Id := In_Tree.Variable_Elements.Table (Var_Id).Next; + end loop; + end if; - Var_Id : Variable_Id := No_Variable; - Name : Name_Id := No_Name; + -- If not found in the package, or if there is no + -- package, look at the project level. - begin - -- If a project was specified for the case variable, - -- get its id. - - if Present (Project_Node_Of - (Variable_Node, From_Project_Node_Tree)) - then - Name := - Name_Of - (Project_Node_Of - (Variable_Node, From_Project_Node_Tree), - From_Project_Node_Tree); - The_Project := - Imported_Or_Extended_Project_From (Project, Name); - end if; + if Var_Id = No_Variable + and then No (Package_Node_Of (Variable_Node, Node_Tree)) + then + Var_Id := The_Project.Decl.Variables; + while Var_Id /= No_Variable + and then In_Tree.Variable_Elements.Table (Var_Id).Name /= Name + loop + Var_Id := In_Tree.Variable_Elements.Table (Var_Id).Next; + end loop; + end if; - -- If a package were specified for the case variable, - -- get its id. - - if Present (Package_Node_Of - (Variable_Node, From_Project_Node_Tree)) - then - Name := - Name_Of - (Package_Node_Of - (Variable_Node, From_Project_Node_Tree), - From_Project_Node_Tree); - The_Package := - Package_From (The_Project, In_Tree, Name); - end if; + if Var_Id = No_Variable then - Name := Name_Of (Variable_Node, From_Project_Node_Tree); + -- Should never happen, because this has already been + -- checked during parsing. - -- First, look for the case variable into the package, - -- if any. + Write_Line + ("variable """ & Get_Name_String (Name) & """ not found"); + raise Program_Error; + end if; - if The_Package /= No_Package then - Var_Id := In_Tree.Packages.Table - (The_Package).Decl.Variables; - Name := - Name_Of (Variable_Node, From_Project_Node_Tree); - while Var_Id /= No_Variable - and then - In_Tree.Variable_Elements.Table - (Var_Id).Name /= Name - loop - Var_Id := In_Tree.Variable_Elements. - Table (Var_Id).Next; - end loop; - end if; + -- Get the case variable - -- If not found in the package, or if there is no - -- package, look at the project level. + The_Variable := In_Tree.Variable_Elements. Table (Var_Id).Value; - if Var_Id = No_Variable - and then - No (Package_Node_Of - (Variable_Node, From_Project_Node_Tree)) - then - Var_Id := The_Project.Decl.Variables; - while Var_Id /= No_Variable - and then - In_Tree.Variable_Elements.Table - (Var_Id).Name /= Name - loop - Var_Id := In_Tree.Variable_Elements. - Table (Var_Id).Next; - end loop; - end if; + if The_Variable.Kind /= Single then - if Var_Id = No_Variable then + -- Should never happen, because this has already been + -- checked during parsing. - -- Should never happen, because this has already been - -- checked during parsing. + Write_Line ("variable""" & Get_Name_String (Name) & + """ is not a single string variable"); + raise Program_Error; + end if; - Write_Line ("variable """ & - Get_Name_String (Name) & - """ not found"); - raise Program_Error; - end if; + -- Get the case variable value + Case_Value := The_Variable.Value; + end; - -- Get the case variable + -- Now look into all the case items of the case construction - The_Variable := In_Tree.Variable_Elements. - Table (Var_Id).Value; + Case_Item := First_Case_Item_Of (Current_Item, Node_Tree); - if The_Variable.Kind /= Single then + Case_Item_Loop : + while Present (Case_Item) loop + Choice_String := First_Choice_Of (Case_Item, Node_Tree); - -- Should never happen, because this has already been - -- checked during parsing. + -- When Choice_String is nil, it means that it is + -- the "when others =>" alternative. - Write_Line ("variable""" & - Get_Name_String (Name) & - """ is not a single string variable"); - raise Program_Error; - end if; + if No (Choice_String) then + Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree); + exit Case_Item_Loop; + end if; - -- Get the case variable value - Case_Value := The_Variable.Value; - end; + -- Look into all the alternative of this case item - -- Now look into all the case items of the case construction + Choice_Loop : + while Present (Choice_String) loop + if Case_Value = String_Value_Of (Choice_String, Node_Tree) then + Decl_Item := + First_Declarative_Item_Of (Case_Item, Node_Tree); + exit Case_Item_Loop; + end if; - Case_Item := - First_Case_Item_Of (Current_Item, From_Project_Node_Tree); - Case_Item_Loop : - while Present (Case_Item) loop - Choice_String := - First_Choice_Of (Case_Item, From_Project_Node_Tree); + Choice_String := Next_Literal_String (Choice_String, Node_Tree); + end loop Choice_Loop; - -- When Choice_String is nil, it means that it is - -- the "when others =>" alternative. + Case_Item := Next_Case_Item (Case_Item, Node_Tree); + end loop Case_Item_Loop; - if No (Choice_String) then - Decl_Item := - First_Declarative_Item_Of - (Case_Item, From_Project_Node_Tree); - exit Case_Item_Loop; - end if; + -- If there is an alternative, then we process it - -- Look into all the alternative of this case item + if Present (Decl_Item) then + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + Flags => Flags, + From_Project_Node => From_Project_Node, + Node_Tree => Node_Tree, + Pkg => Pkg, + Item => Decl_Item); + end if; + end Process_Case_Construction; - Choice_Loop : - while Present (Choice_String) loop - if Case_Value = - String_Value_Of - (Choice_String, From_Project_Node_Tree) - then - Decl_Item := - First_Declarative_Item_Of - (Case_Item, From_Project_Node_Tree); - exit Case_Item_Loop; - end if; + -- Local variables - Choice_String := - Next_Literal_String - (Choice_String, From_Project_Node_Tree); - end loop Choice_Loop; + Current, Decl : Project_Node_Id; + Kind : Project_Node_Kind; - Case_Item := - Next_Case_Item (Case_Item, From_Project_Node_Tree); - end loop Case_Item_Loop; + -- Start of processing for Process_Declarative_Items - -- If there is an alternative, then we process it + begin + Decl := Item; + while Present (Decl) loop + Current := Current_Item_Node (Decl, Node_Tree); + Decl := Next_Declarative_Item (Decl, Node_Tree); + Kind := Kind_Of (Current, Node_Tree); - if Present (Decl_Item) then - Process_Declarative_Items - (Project => Project, - In_Tree => In_Tree, - Flags => Flags, - From_Project_Node => From_Project_Node, - From_Project_Node_Tree => From_Project_Node_Tree, - Pkg => Pkg, - Item => Decl_Item); - end if; - end; + case Kind is + when N_Package_Declaration => + Process_Package_Declaration (Current); - when others => + when N_String_Type_Declaration => + -- There is nothing to process + null; - -- Should never happen + when N_Attribute_Declaration | + N_Typed_Variable_Declaration | + N_Variable_Declaration => + Process_Attribute_Declaration (Current); + + when N_Case_Construction => + Process_Case_Construction (Current); - Write_Line ("Illegal declarative item: " & - Project_Node_Kind'Image - (Kind_Of - (Current_Item, From_Project_Node_Tree))); + when others => + Write_Line ("Illegal declarative item: " & Kind'Img); raise Program_Error; end case; end loop; @@ -2439,6 +2346,8 @@ package body Prj.Proc is -- And process the main project and all of the projects it depends on, -- recursively. + Debug_Increase_Indent ("Process tree, phase 1"); + Recursive_Process (Project => Project, In_Tree => In_Tree, @@ -2450,7 +2359,12 @@ package body Prj.Proc is Success := Total_Errors_Detected = 0 and then - (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + + if Current_Verbosity = High then + Debug_Decrease_Indent ("Done Process tree, phase 1, Success=" + & Success'Img); + end if; end Process_Project_Tree_Phase_1; ---------------------------------- @@ -2475,6 +2389,8 @@ package body Prj.Proc is begin Success := True; + Debug_Increase_Indent ("Process tree, phase 2"); + if Project /= No_Project then Check (In_Tree, Project, From_Project_Node_Tree, Flags); end if; @@ -2554,6 +2470,8 @@ package body Prj.Proc is end loop; end if; + Debug_Decrease_Indent ("Done Process tree, phase 2"); + Success := Total_Errors_Detected = 0 and then @@ -2580,6 +2498,16 @@ package body Prj.Proc is -- only projects imported through a standard "with" are processed. -- Imported is the id of the last imported project. + procedure Process_Aggregated_Projects; + -- Process all the projects aggregated in List. + -- This does nothing if the project is not an aggregate project. + + procedure Process_Extended_Project; + -- Process the extended project: + -- inherit all packages from the extended project that are not + -- explicitly defined or renamed. Also inherit the languages, if + -- attribute Languages is not explicitly defined. + ------------------------------- -- Process_Imported_Projects -- ------------------------------- @@ -2596,6 +2524,7 @@ package body Prj.Proc is With_Clause := First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree); + while Present (With_Clause) loop Proj_Node := Non_Limited_Project_Node_Of @@ -2637,6 +2566,158 @@ package body Prj.Proc is end loop; end Process_Imported_Projects; + --------------------------------- + -- Process_Aggregated_Projects -- + --------------------------------- + + procedure Process_Aggregated_Projects is + List : Aggregated_Project_List; + Loaded_Tree : Prj.Tree.Project_Node_Id; + Success : Boolean := True; + begin + if Project.Qualifier /= Aggregate then + return; + end if; + + Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name); + + Prj.Nmsc.Process_Aggregated_Projects + (Tree => In_Tree, + Project => Project, + Node_Tree => From_Project_Node_Tree, + Flags => Flags); + + List := Project.Aggregated_Projects; + while Success and then List /= null loop + Prj.Part.Parse + (In_Tree => From_Project_Node_Tree, + Project => Loaded_Tree, + Project_File_Name => Get_Name_String (List.Path), + Errout_Handling => Prj.Part.Never_Finalize, + Current_Directory => Get_Name_String (Project.Directory.Name), + Is_Config_File => False, + Flags => Flags); + + Success := not Prj.Tree.No (Loaded_Tree); + + if Success then + Recursive_Process + (In_Tree => In_Tree, + Project => List.Project, + Flags => Flags, + From_Project_Node => Loaded_Tree, + From_Project_Node_Tree => From_Project_Node_Tree, + Extended_By => No_Project); + else + Debug_Output ("Failed to parse", Name_Id (List.Path)); + end if; + + List := List.Next; + end loop; + + Debug_Decrease_Indent ("Done Process_Aggregated_Projects"); + end Process_Aggregated_Projects; + + ------------------------------ + -- Process_Extended_Project -- + ------------------------------ + + procedure Process_Extended_Project is + Extended_Pkg : Package_Id; + Current_Pkg : Package_Id; + Element : Package_Element; + First : constant Package_Id := Project.Decl.Packages; + Attribute1 : Variable_Id; + Attribute2 : Variable_Id; + Attr_Value1 : Variable; + Attr_Value2 : Variable; + + begin + Extended_Pkg := Project.Extends.Decl.Packages; + while Extended_Pkg /= No_Package loop + Element := In_Tree.Packages.Table (Extended_Pkg); + + Current_Pkg := First; + while Current_Pkg /= No_Package + and then In_Tree.Packages.Table (Current_Pkg).Name /= + Element.Name + loop + Current_Pkg := + In_Tree.Packages.Table (Current_Pkg).Next; + end loop; + + if Current_Pkg = No_Package then + Package_Table.Increment_Last + (In_Tree.Packages); + Current_Pkg := Package_Table.Last (In_Tree.Packages); + In_Tree.Packages.Table (Current_Pkg) := + (Name => Element.Name, + Decl => No_Declarations, + Parent => No_Package, + Next => Project.Decl.Packages); + Project.Decl.Packages := Current_Pkg; + Copy_Package_Declarations + (From => Element.Decl, + To => + In_Tree.Packages.Table (Current_Pkg).Decl, + New_Loc => No_Location, + Restricted => True, + In_Tree => In_Tree); + end if; + + Extended_Pkg := Element.Next; + end loop; + + -- Check if attribute Languages is declared in the + -- extending project. + + Attribute1 := Project.Decl.Attributes; + while Attribute1 /= No_Variable loop + Attr_Value1 := In_Tree.Variable_Elements. + Table (Attribute1); + exit when Attr_Value1.Name = Snames.Name_Languages; + Attribute1 := Attr_Value1.Next; + end loop; + + if Attribute1 = No_Variable or else + Attr_Value1.Value.Default + then + -- Attribute Languages is not declared in the extending + -- project. Check if it is declared in the project being + -- extended. + + Attribute2 := Project.Extends.Decl.Attributes; + while Attribute2 /= No_Variable loop + Attr_Value2 := In_Tree.Variable_Elements. + Table (Attribute2); + exit when Attr_Value2.Name = Snames.Name_Languages; + Attribute2 := Attr_Value2.Next; + end loop; + + if Attribute2 /= No_Variable and then + not Attr_Value2.Value.Default + then + -- As attribute Languages is declared in the project + -- being extended, copy its value for the extending + -- project. + + if Attribute1 = No_Variable then + Variable_Element_Table.Increment_Last + (In_Tree.Variable_Elements); + Attribute1 := Variable_Element_Table.Last + (In_Tree.Variable_Elements); + Attr_Value1.Next := Project.Decl.Attributes; + Project.Decl.Attributes := Attribute1; + end if; + + Attr_Value1.Name := Snames.Name_Languages; + Attr_Value1.Value := Attr_Value2.Value; + In_Tree.Variable_Elements.Table + (Attribute1) := Attr_Value1; + end if; + end if; + end Process_Extended_Project; + -- Start of processing for Recursive_Process begin @@ -2672,7 +2753,10 @@ package body Prj.Proc is return; end if; - Project := new Project_Data'(Empty_Project); + Project := new Project_Data' + (Empty_Project + (Project_Qualifier_Of + (From_Project_Node, From_Project_Node_Tree))); In_Tree.Projects := new Project_List_Element' (Project => Project, Next => In_Tree.Projects); @@ -2681,9 +2765,6 @@ package body Prj.Proc is Project.Name := Name; Project.Display_Name := Name_Node.Display_Name; - Project.Qualifier := - Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree); - Get_Name_String (Name); -- If name starts with the virtual prefix, flag the project as @@ -2743,117 +2824,21 @@ package body Prj.Proc is In_Tree => In_Tree, Flags => Flags, From_Project_Node => From_Project_Node, - From_Project_Node_Tree => From_Project_Node_Tree, + Node_Tree => From_Project_Node_Tree, Pkg => No_Package, Item => First_Declarative_Item_Of (Declaration_Node, From_Project_Node_Tree)); - -- If it is an extending project, inherit all packages - -- from the extended project that are not explicitly defined - -- or renamed. Also inherit the languages, if attribute Languages - -- is not explicitly defined. - if Project.Extends /= No_Project then - declare - Extended_Pkg : Package_Id; - Current_Pkg : Package_Id; - Element : Package_Element; - First : constant Package_Id := - Project.Decl.Packages; - Attribute1 : Variable_Id; - Attribute2 : Variable_Id; - Attr_Value1 : Variable; - Attr_Value2 : Variable; - - begin - Extended_Pkg := Project.Extends.Decl.Packages; - while Extended_Pkg /= No_Package loop - Element := In_Tree.Packages.Table (Extended_Pkg); - - Current_Pkg := First; - while Current_Pkg /= No_Package - and then In_Tree.Packages.Table (Current_Pkg).Name /= - Element.Name - loop - Current_Pkg := - In_Tree.Packages.Table (Current_Pkg).Next; - end loop; - - if Current_Pkg = No_Package then - Package_Table.Increment_Last - (In_Tree.Packages); - Current_Pkg := Package_Table.Last (In_Tree.Packages); - In_Tree.Packages.Table (Current_Pkg) := - (Name => Element.Name, - Decl => No_Declarations, - Parent => No_Package, - Next => Project.Decl.Packages); - Project.Decl.Packages := Current_Pkg; - Copy_Package_Declarations - (From => Element.Decl, - To => - In_Tree.Packages.Table (Current_Pkg).Decl, - New_Loc => No_Location, - Restricted => True, - In_Tree => In_Tree); - end if; - - Extended_Pkg := Element.Next; - end loop; - - -- Check if attribute Languages is declared in the - -- extending project. - - Attribute1 := Project.Decl.Attributes; - while Attribute1 /= No_Variable loop - Attr_Value1 := In_Tree.Variable_Elements. - Table (Attribute1); - exit when Attr_Value1.Name = Snames.Name_Languages; - Attribute1 := Attr_Value1.Next; - end loop; - - if Attribute1 = No_Variable or else - Attr_Value1.Value.Default - then - -- Attribute Languages is not declared in the extending - -- project. Check if it is declared in the project being - -- extended. - - Attribute2 := Project.Extends.Decl.Attributes; - while Attribute2 /= No_Variable loop - Attr_Value2 := In_Tree.Variable_Elements. - Table (Attribute2); - exit when Attr_Value2.Name = Snames.Name_Languages; - Attribute2 := Attr_Value2.Next; - end loop; - - if Attribute2 /= No_Variable and then - not Attr_Value2.Value.Default - then - -- As attribute Languages is declared in the project - -- being extended, copy its value for the extending - -- project. - - if Attribute1 = No_Variable then - Variable_Element_Table.Increment_Last - (In_Tree.Variable_Elements); - Attribute1 := Variable_Element_Table.Last - (In_Tree.Variable_Elements); - Attr_Value1.Next := Project.Decl.Attributes; - Project.Decl.Attributes := Attribute1; - end if; - - Attr_Value1.Name := Snames.Name_Languages; - Attr_Value1.Value := Attr_Value2.Value; - In_Tree.Variable_Elements.Table - (Attribute1) := Attr_Value1; - end if; - end if; - end; + Process_Extended_Project; end if; Process_Imported_Projects (Imported, Limited_With => True); + + if Err_Vars.Total_Errors_Detected = 0 then + Process_Aggregated_Projects; + end if; end; end if; end Recursive_Process; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0b9d4ff932a..cbc2c9657ec 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -62,55 +62,6 @@ package body Prj is All_Upper_Case => All_Upper_Case_Image'Access, Mixed_Case => Mixed_Case_Image'Access); - Project_Empty : constant Project_Data := - (Qualifier => Unspecified, - Externally_Built => False, - Config => Default_Project_Config, - Name => No_Name, - Display_Name => No_Name, - Path => No_Path_Information, - Virtual => False, - Location => No_Location, - Mains => Nil_String, - Directory => No_Path_Information, - Library => False, - Library_Dir => No_Path_Information, - Library_Src_Dir => No_Path_Information, - Library_ALI_Dir => No_Path_Information, - Library_Name => No_Name, - Library_Kind => Static, - Lib_Internal_Name => No_Name, - Standalone_Library => False, - Lib_Interface_ALIs => Nil_String, - Lib_Auto_Init => False, - Libgnarl_Needed => Unknown, - Symbol_Data => No_Symbols, - Interfaces_Defined => False, - Source_Dirs => Nil_String, - Source_Dir_Ranks => No_Number_List, - Object_Directory => No_Path_Information, - Library_TS => Empty_Time_Stamp, - Exec_Directory => No_Path_Information, - Extends => No_Project, - Extended_By => No_Project, - Languages => No_Language_Index, - Decl => No_Declarations, - Imported_Projects => null, - Include_Path_File => No_Path, - All_Imported_Projects => null, - Ada_Include_Path => null, - Ada_Objects_Path => null, - Objects_Path => null, - Objects_Path_File_With_Libs => No_Path, - Objects_Path_File_Without_Libs => No_Path, - Config_File_Name => No_Path, - Config_File_Temp => False, - Config_Checked => False, - Need_To_Build_Lib => False, - Has_Multi_Unit_Sources => False, - Depth => 0, - Unkept_Comments => False); - procedure Free (Project : in out Project_Id); -- Free memory allocated for Project @@ -270,10 +221,20 @@ package body Prj is -- Empty_Project -- ------------------- - function Empty_Project return Project_Data is + function Empty_Project + (Qualifier : Project_Qualifier) return Project_Data is begin Prj.Initialize (Tree => No_Project_Tree); - return Project_Empty; + + declare + Data : Project_Data (Qualifier => Qualifier); + begin + -- Only the fields for which no default value could be provided in + -- prj.ads are initialized below + + Data.Config := Default_Project_Config; + return Data; + end; end Empty_Project; ------------------ @@ -440,6 +401,7 @@ package body Prj is procedure For_Every_Project_Imported (By : Project_Id; With_State : in out State; + Include_Aggregated : Boolean := True; Imported_First : Boolean := False) is use Project_Boolean_Htable; @@ -455,6 +417,7 @@ package body Prj is procedure Recursive_Check (Project : Project_Id) is List : Project_List; + Agg : Aggregated_Project_List; begin if not Get (Seen, Project) then @@ -464,13 +427,13 @@ package body Prj is Action (Project, With_State); end if; - -- Visited all extended projects + -- Visit all extended projects if Project.Extends /= No_Project then Recursive_Check (Project.Extends); end if; - -- Visited all imported projects + -- Visit all imported projects List := Project.Imported_Projects; while List /= null loop @@ -478,6 +441,19 @@ package body Prj is List := List.Next; end loop; + -- Visit all aggregated projects + + if Include_Aggregated + and then Project.Qualifier = Aggregate + then + Agg := Project.Aggregated_Projects; + while Agg /= null loop + pragma Assert (Agg.Project /= No_Project); + Recursive_Check (Agg.Project); + Agg := Agg.Next; + end loop; + end if; + if Imported_First then Action (Project, With_State); end if; @@ -729,6 +705,35 @@ package body Prj is -- Free -- ---------- + procedure Free (List : in out Aggregated_Project_List) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Aggregated_Project, Aggregated_Project_List); + Tmp : Aggregated_Project_List; + begin + while List /= null loop + Tmp := List.Next; + Unchecked_Free (List); + List := Tmp; + end loop; + end Free; + + ---------------------------- + -- Add_Aggregated_Project -- + ---------------------------- + + procedure Add_Aggregated_Project + (Project : Project_Id; Path : Path_Name_Type) is + begin + Project.Aggregated_Projects := new Aggregated_Project' + (Path => Path, + Project => No_Project, + Next => Project.Aggregated_Projects); + end Add_Aggregated_Project; + + ---------- + -- Free -- + ---------- + procedure Free (Project : in out Project_Id) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_Data, Project_Id); @@ -742,6 +747,14 @@ package body Prj is Free_List (Project.All_Imported_Projects, Free_Project => False); Free_List (Project.Languages); + case Project.Qualifier is + when Aggregate => + Free (Project.Aggregated_Projects); + + when others => + null; + end case; + Unchecked_Free (Project); end if; end Free; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 202e70aeca9..db53aa08155 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1086,13 +1086,34 @@ package Prj is Lib_Maj_Min_Id_Supported => False, Auto_Init_Supported => False); - -- The following record describes a project file representation + ------------------------- + -- Aggregated projects -- + ------------------------- + + type Aggregated_Project; + type Aggregated_Project_List is access all Aggregated_Project; + type Aggregated_Project is record + Path : Path_Name_Type; + Project : Project_Id; + Next : Aggregated_Project_List; + end record; + + procedure Free (List : in out Aggregated_Project_List); + -- Free the memory used for List - -- Note that it is not specified if the path names of directories (source, - -- object, library or exec directories) end with or without a directory - -- separator. + procedure Add_Aggregated_Project + (Project : Project_Id; Path : Path_Name_Type); + -- Add a new aggregated project in Project. + -- The aggregated project has not been processed yet. This procedure should + -- the called while processing the aggregate project, and as a result + -- Prj.Proc.Process will then automatically process the aggregated projects - type Project_Data is record + ------------------ + -- Project_Data -- + ------------------ + -- The following record describes a project file representation + + type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record ------------- -- General -- @@ -1104,9 +1125,6 @@ package Prj is Display_Name : Name_Id := No_Name; -- The name of the project with the spelling of its declaration - Qualifier : Project_Qualifier := Unspecified; - -- The eventual qualifier for this project - Externally_Built : Boolean := False; -- True if the project is externally built. In such case, the Project -- Manager will not modify anything in this project. @@ -1152,10 +1170,10 @@ package Prj is -- The declarations (variables, attributes and packages) of this project -- file. - Imported_Projects : Project_List; + Imported_Projects : Project_List := null; -- The list of all directly imported projects, if any - All_Imported_Projects : Project_List; + All_Imported_Projects : Project_List := null; -- The list of all projects imported directly or indirectly, if any. -- This does not include the project itself. @@ -1295,9 +1313,21 @@ package Prj is -- True if there are comments in the project sources that cannot be kept -- in the project tree. + ----------------------------- + -- qualifier-specific data -- + ----------------------------- + -- The following fields are only valid for specific types of projects. + + case Qualifier is + when Aggregate => + Aggregated_Projects : Aggregated_Project_List := null; + + when others => + null; + end case; end record; - function Empty_Project return Project_Data; + function Empty_Project (Qualifier : Project_Qualifier) return Project_Data; -- Return the representation of an empty project function Is_Extending @@ -1432,6 +1462,7 @@ package Prj is procedure For_Every_Project_Imported (By : Project_Id; With_State : in out State; + Include_Aggregated : Boolean := True; Imported_First : Boolean := False); -- Call Action for each project imported directly or indirectly by project -- By, as well as extended projects. @@ -1448,6 +1479,10 @@ package Prj is -- -- With_State may be used by Action to choose a behavior or to report some -- global result. + -- + -- If Include_Aggregated is True, then an aggregate project will recurse + -- into the projects it aggregates. Otherwise, the latter are never + -- returned function Extend_Name (File : File_Name_Type; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index ba2633bc5a6..fdc243cdd6a 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -105,9 +105,9 @@ package body Restrict is Check_Restriction (No_Elaboration_Code, N); end Check_Elaboration_Code_Allowed; - ------------------------------ - -- Check_Formal_Restriction -- - ------------------------------ + ----------------------------- + -- Check_SPARK_Restriction -- + ----------------------------- procedure Check_SPARK_Restriction (Msg : String; @@ -139,7 +139,7 @@ package body Restrict is end if; end Check_SPARK_Restriction; - procedure Check_Formal_Restriction (Msg1, Msg2 : String; N : Node_Id) is + procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is Msg_Issued : Boolean; Save_Error_Msg_Sloc : Source_Ptr; begin @@ -166,7 +166,7 @@ package body Restrict is Error_Msg_F (Msg2, N); end if; end if; - end Check_Formal_Restriction; + end Check_SPARK_Restriction; ----------------------------------------- -- Check_Implicit_Dynamic_Code_Allowed -- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 92709c93526..31cecd7305d 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -265,8 +265,8 @@ package Restrict is -- SPARK restriction is set, then an error is issued on N. Msg is appended -- to the restriction failure message. - procedure Check_Formal_Restriction (Msg1, Msg2 : String; N : Node_Id); - -- Same as Check_Formal_Restriction except there is a continuation message + procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id); + -- Same as Check_SPARK_Restriction except there is a continuation message -- Msg2 following the initial message Msg1. procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 01a9befc1a9..849ec86c824 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -289,7 +289,7 @@ package body Sem_Attr is -- Common processing for attributes Definite and Has_Discriminants. -- Checks that prefix is generic indefinite formal type. - procedure Check_Formal_Restriction_On_Attribute; + procedure Check_SPARK_Restriction_On_Attribute; -- Issue an error in formal mode because attribute N is allowed procedure Check_Integer_Type; @@ -568,7 +568,7 @@ package body Sem_Attr is -- Start of processing for Analyze_Access_Attribute begin - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_E0; if Nkind (P) = N_Character_Literal then @@ -1289,15 +1289,15 @@ package body Sem_Attr is Check_E2; end Check_Floating_Point_Type_2; - ------------------------------------------- - -- Check_Formal_Restriction_On_Attribute -- - ------------------------------------------- + ------------------------------------------ + -- Check_SPARK_Restriction_On_Attribute -- + ------------------------------------------ - procedure Check_Formal_Restriction_On_Attribute is + procedure Check_SPARK_Restriction_On_Attribute is begin Error_Msg_Name_1 := Aname; Check_SPARK_Restriction ("attribute % is not allowed", P); - end Check_Formal_Restriction_On_Attribute; + end Check_SPARK_Restriction_On_Attribute; ------------------------ -- Check_Integer_Type -- @@ -3266,7 +3266,7 @@ package body Sem_Attr is when Attribute_Image => Image : begin - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_Scalar_Type; Set_Etype (N, Standard_String); @@ -4825,7 +4825,7 @@ package body Sem_Attr is when Attribute_Value => Value : begin - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -4888,7 +4888,7 @@ package body Sem_Attr is when Attribute_Wide_Image => Wide_Image : begin - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_Scalar_Type; Set_Etype (N, Standard_Wide_String); Check_E1; @@ -4915,7 +4915,7 @@ package body Sem_Attr is when Attribute_Wide_Value => Wide_Value : begin - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -4956,7 +4956,7 @@ package body Sem_Attr is ---------------- when Attribute_Wide_Width => - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); @@ -4966,7 +4966,7 @@ package body Sem_Attr is ----------- when Attribute_Width => - Check_Formal_Restriction_On_Attribute; + Check_SPARK_Restriction_On_Attribute; Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 99ba2a23af2..d487921ad0f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8593,10 +8593,13 @@ package body Sem_Ch6 is Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); - -- Overloading is not allowed in SPARK + -- Overloading is not allowed in SPARK, except for operators - Error_Msg_Sloc := Sloc (Homonym (S)); - Check_SPARK_Restriction ("overloading not allowed with entity#", S); + if Nkind (S) /= N_Defining_Operator_Symbol then + Error_Msg_Sloc := Sloc (Homonym (S)); + Check_SPARK_Restriction + ("overloading not allowed with entity#", S); + end if; -- If S is a derived operation for an untagged type then by -- definition it's not a dispatching operation (even if the parent diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 474f39c830e..633d975758e 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -936,7 +936,7 @@ package body Sem_Ch7 is else Error_Msg_Sloc := Sloc (Previous); - Check_Formal_Restriction + Check_SPARK_Restriction ("at most one tagged type or type extension allowed", "\\ previous declaration#", Decl); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 85cd8509b89..ddb85a7a6d0 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5748,7 +5748,7 @@ package body Sem_Res is -- and then Is_Inherited_Operation_For_Type -- (Entity (Name (N)), Etype (N)) -- then --- Check_Formal_Restriction ("function not inherited", N); +-- Check_SPARK_Restriction ("function not inherited", N); -- end if; -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is -- 2.30.2