From ab29a348ebe1345e469cede91ea4b2ef7c72e1fe Mon Sep 17 00:00:00 2001 From: Emmanuel Briot Date: Wed, 3 Aug 2011 10:01:51 +0000 Subject: [multiple changes] 2011-08-03 Yannick Moy * alfa.ads Update format of ALFA section in ALI file in order to add a mapping from bodies to specs when both are present (ALFA_Scope_Record): add components for spec file/scope * get_alfa.adb (Get_ALFA): read the new file/scope for spec when present * lib-xref-alfa.adb (Collect_ALFA): after all scopes have been collected, fill in the spec information when relevant * put_alfa.adb (Put_ALFA): write the new file/scope for spec when present. 2011-08-03 Eric Botcazou * inline.adb (Add_Inlined_Subprogram): Do not consider the enclosing code unit to decide whether to add internally generated subprograms. 2011-08-03 Javier Miranda * sem_aux.ads, sem_aux.adb (Is_VM_By_Copy_Actual): New subprogram. * exp_ch9.adb (Build_Simple_Entry_Call): Handle actuals that must be handled by copy in VM targets. 2011-08-03 Emmanuel Briot * make.adb, makeutl.adb, makeutl.ads (Make.Switches_Of): now shares code with Makeutl.Get_Switches. * prj-tree.adb: Update comment. From-SVN: r177257 --- gcc/ada/ChangeLog | 6 ++++ gcc/ada/prj-env.adb | 14 +++++++++ gcc/ada/prj-env.ads | 10 ++++++ gcc/ada/prj-ext.adb | 70 +++++++++++++++++++++++++++++------------- gcc/ada/prj-ext.ads | 25 ++++++++++++--- gcc/ada/prj-proc.adb | 86 +++++++++++++++++++++++++++++++++++++++++++--------- gcc/ada/prj-tree.adb | 16 +++++++++- gcc/ada/prj-tree.ads | 9 +++++- 8 files changed, 193 insertions(+), 43 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3090c3e..7ce74cf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2011-08-03 Emmanuel Briot + + * prj-proc.adb, prj-ext.adb, prj-ext.ads, prj-env.adb, prj-env.ads, + prj-tree.adb, prj-tree.ads (Initialize_And_Copy, Copy): new subprograms + (Process_Declarative_Items): new parameter Child_Env. + 2011-08-03 Yannick Moy * alfa.ads Update format of ALFA section in ALI file in order to add a diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 6285222..050660e 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -2197,4 +2197,18 @@ package body Prj.Env is Projects_Paths.Reset (Self.Cache); end Free; + ---------- + -- Copy -- + ---------- + + procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is + begin + Free (To); + if From.Path /= null then + To.Path := new String'(From.Path.all); + end if; + + -- No need to copy the Cache, it will be recomputed as needed. + end Copy; + end Prj.Env; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 61c0431..75f014a 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -162,6 +162,8 @@ package Prj.Env is -- to search for projects on the path (and caches the results to improve -- efficiency). + No_Project_Search_Path : constant Project_Search_Path; + procedure Initialize_Default_Project_Path (Self : in out Project_Search_Path; Target_Name : String); @@ -170,6 +172,9 @@ package Prj.Env is -- variables ADA_PROJECT_PATH and GPR_PROJECT_PATH). This does nothing if -- Self has already been initialized. + procedure Copy (From : Project_Search_Path; To : out Project_Search_Path); + -- Copy From into To + procedure Initialize_Empty (Self : in out Project_Search_Path); -- Initialize self with an empty list of directories. If Self had already -- been set, it is reset. @@ -234,4 +239,9 @@ private Cache : Projects_Paths.Instance; end record; + + No_Project_Search_Path : constant Project_Search_Path := + (Path => null, + Cache => Projects_Paths.Nil); + end Prj.Env; diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index b9885c3..a235bde 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -46,9 +46,11 @@ package body Prj.Ext is if Copy_From.Refs /= null then N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all); while N /= null loop - N2 := new Name_To_Name; - N2.Key := N.Key; - N2.Value := N.Value; + N2 := new Name_To_Name' + (Key => N.Key, + Value => N.Value, + Source => N.Source, + Next => null); Name_To_Name_HTable.Set (Self.Refs.all, N2); N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all); end loop; @@ -63,24 +65,47 @@ package body Prj.Ext is procedure Add (Self : External_References; External_Name : String; - Value : String) + Value : String; + Source : External_Source := External_Source'First) is - N : Name_To_Name_Ptr; + Key : Name_Id; + N : Name_To_Name_Ptr; begin - N := new Name_To_Name; - - Name_Len := Value'Length; - Name_Buffer (1 .. Name_Len) := Value; - N.Value := Name_Find; - Name_Len := External_Name'Length; Name_Buffer (1 .. Name_Len) := External_Name; Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len)); - N.Key := Name_Find; + Key := Name_Find; + + -- Check whether the value is already defined, to properly respect the + -- overriding order. + + if Source /= External_Source'First then + N := Name_To_Name_HTable.Get (Self.Refs.all, Key); + if N /= null then + if External_Source'Pos (N.Source) < + External_Source'Pos (Source) + then + if Current_Verbosity = High then + Debug_Output + ("Not overridding existing variable '" & External_Name + & "', value was defined in " & N.Source'Img); + end if; + return; + end if; + end if; + end if; + + Name_Len := Value'Length; + Name_Buffer (1 .. Name_Len) := Value; + N := new Name_To_Name' + (Key => Key, + Source => Source, + Value => Name_Find, + Next => null); if Current_Verbosity = High then - Debug_Output ("Add (" & External_Name & ") is", N.Value); + Debug_Output ("Add external (" & External_Name & ") is", N.Value); end if; Name_To_Name_HTable.Set (Self.Refs.all, N); @@ -103,7 +128,8 @@ package body Prj.Ext is External_Name => Declaration (Declaration'First .. Equal_Pos - 1), Value => - Declaration (Equal_Pos + 1 .. Declaration'Last)); + Declaration (Equal_Pos + 1 .. Declaration'Last), + Source => From_Command_Line); return True; end if; end loop; @@ -146,6 +172,7 @@ package body Prj.Ext is Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find); if Value /= null then + Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value); return Value.Value; end if; end if; @@ -162,14 +189,15 @@ package body Prj.Ext is Val := Name_Find; if Current_Verbosity = High then - Debug_Output ("Value_Of (" & Get_Name_String (External_Name) - & ") is", Val); + Debug_Output ("Value_Of (" & Name & ") is", Val); end if; if Self.Refs /= null then - Value := new Name_To_Name; - Value.Key := External_Name; - Value.Value := Val; + Value := new Name_To_Name' + (Key => External_Name, + Value => Val, + Source => From_Environment, + Next => null); Name_To_Name_HTable.Set (Self.Refs.all, Value); end if; @@ -178,8 +206,8 @@ package body Prj.Ext is else if Current_Verbosity = High then - Debug_Output ("Value_Of (" & Get_Name_String (External_Name) - & ") is default", With_Default); + Debug_Output + ("Value_Of (" & Name & ") is default", With_Default); end if; Free (Env_Value); diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads index 4ea4608..75b0ed2 100644 --- a/gcc/ada/prj-ext.ads +++ b/gcc/ada/prj-ext.ads @@ -54,11 +54,25 @@ package Prj.Ext is procedure Free (Self : in out External_References); -- Free memory used by Self + type External_Source is + (From_Command_Line, + From_Environment, + From_External_Attribute); + -- Where was the value of an external reference defined ? + -- They are prioritized in that order, so that a user can always use the + -- command line to override a value coming from his environment, or an + -- environment variable to override a value defined in an aggregate project + -- through the "for External()..." attribute. + procedure Add (Self : External_References; External_Name : String; - Value : String); - -- Add an external reference (or modify an existing one) + Value : String; + Source : External_Source := External_Source'First); + -- Add an external reference (or modify an existing one). + -- No overriding is done if the Source's priority is less than the one + -- used to previously set the value of the variable. The default for Source + -- is such that overriding always occurs. function Value_Of (Self : External_References; @@ -88,9 +102,10 @@ private type Name_To_Name; type Name_To_Name_Ptr is access all Name_To_Name; type Name_To_Name is record - Key : Name_Id; - Value : Name_Id; - Next : Name_To_Name_Ptr; + Key : Name_Id; + Value : Name_Id; + Source : External_Source; + Next : Name_To_Name_Ptr; end record; procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index f83a05f..4e3ba1b 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -131,10 +131,17 @@ package body Prj.Proc is Node_Tree : Project_Node_Tree_Ref; Env : Prj.Tree.Environment; Pkg : Package_Id; - Item : Project_Node_Id); + Item : Project_Node_Id; + Child_Env : in out Prj.Tree.Environment; + Can_Modify_Child_Env : Boolean); -- Process declarative items starting with From_Project_Node, and put them -- in declarations Decl. This is a recursive procedure; it calls itself for -- a package declaration or a case construction. + -- Child_Env is the modified environment after seeing declarations like + -- "for External(...) use" or "for Project_Path use" in aggregate projects. + -- It should have been initialized first. This environment can only be + -- modified if Can_Modify_Child_Env is True, otherwise all the above + -- attributes simply have no effect. procedure Recursive_Process (In_Tree : Project_Tree_Ref; @@ -142,13 +149,22 @@ package body Prj.Proc is From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment; - Extended_By : Project_Id); + Extended_By : Project_Id; + Child_Env : in out Prj.Tree.Environment; + Is_Root_Project : Boolean); -- Process project with node From_Project_Node in the tree. Do nothing if -- From_Project_Node is Empty_Node. If project has already been processed, -- simply return its project id. Otherwise create a new project id, mark it -- as processed, call itself recursively for all imported projects and a -- extended project, if any. Then process the declarative items of the -- project. + -- Child_Env is the environment created from an aggregate project (new + -- external values or project path), and should be initialized before the + -- call. + -- Is_Root_Project should be true only for the project that the user + -- explicitly loaded. In the context of aggregate projects, only that + -- project is allowed to modify the environment that will be used to load + -- projects (Child_Env). function Get_Attribute_Index (Tree : Project_Node_Tree_Ref; @@ -1392,7 +1408,9 @@ package body Prj.Proc is Node_Tree : Project_Node_Tree_Ref; Env : Prj.Tree.Environment; Pkg : Package_Id; - Item : Project_Node_Id) + Item : Project_Node_Id; + Child_Env : in out Prj.Tree.Environment; + Can_Modify_Child_Env : Boolean) is procedure Check_Or_Set_Typed_Variable (Value : in out Variable_Value; @@ -1597,7 +1615,9 @@ package body Prj.Proc is Env => Env, Pkg => New_Pkg, Item => - First_Declarative_Item_Of (Current_Item, Node_Tree)); + First_Declarative_Item_Of (Current_Item, Node_Tree), + Child_Env => Child_Env, + Can_Modify_Child_Env => Can_Modify_Child_Env); end; end if; end Process_Package_Declaration; @@ -1949,9 +1969,26 @@ package body Prj.Proc is end if; if Name = Snames.Name_External then + if Can_Modify_Child_Env then + Add (Child_Env.External, + External_Name => Get_Name_String (Index_Name), + Value => Get_Name_String (New_Value.Value), + Source => From_External_Attribute); + Add (Env.External, + External_Name => Get_Name_String (Index_Name), + Value => Get_Name_String (New_Value.Value), + Source => From_External_Attribute); + else + if Current_Verbosity = High then + Debug_Output + ("'for External' has no effect except in root aggregate (" + & Get_Name_String (Index_Name) & ")", New_Value.Value); + end if; + end if; + + elsif Name = Snames.Name_Project_Path then Debug_Output - ("Defined external value (" - & Get_Name_String (Index_Name) & ")", New_Value.Value); + ("Defined project path"); end if; end Process_Expression_For_Associative_Array; @@ -2236,7 +2273,9 @@ package body Prj.Proc is Node_Tree => Node_Tree, Env => Env, Pkg => Pkg, - Item => Decl_Item); + Item => Decl_Item, + Child_Env => Child_Env, + Can_Modify_Child_Env => Can_Modify_Child_Env); end if; end Process_Case_Construction; @@ -2291,6 +2330,7 @@ package body Prj.Proc is Env : in out Prj.Tree.Environment; Reset_Tree : Boolean := True) is + Child_Env : Prj.Tree.Environment; begin if Reset_Tree then @@ -2306,13 +2346,19 @@ package body Prj.Proc is Debug_Increase_Indent ("Process tree, phase 1"); + Initialize_And_Copy (Child_Env, Copy_From => Env); + Recursive_Process (Project => Project, In_Tree => In_Tree, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, - Extended_By => No_Project); + Extended_By => No_Project, + Child_Env => Child_Env, + Is_Root_Project => True); + + Free (Child_Env); Success := Total_Errors_Detected = 0 @@ -2448,7 +2494,9 @@ package body Prj.Proc is From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment; - Extended_By : Project_Id) + Extended_By : Project_Id; + Child_Env : in out Prj.Tree.Environment; + Is_Root_Project : Boolean) is procedure Process_Imported_Projects (Imported : in out Project_List; @@ -2501,7 +2549,9 @@ package body Prj.Proc is (With_Clause, From_Project_Node_Tree), From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, - Extended_By => No_Project); + Extended_By => No_Project, + Child_Env => Child_Env, + Is_Root_Project => False); -- Imported is the id of the last imported project. If -- it is nil, then this imported project is our first. @@ -2555,7 +2605,7 @@ package body Prj.Proc is Errout_Handling => Prj.Part.Never_Finalize, Current_Directory => Get_Name_String (Project.Directory.Name), Is_Config_File => False, - Env => Env); + Env => Child_Env); Success := not Prj.Tree.No (Loaded_Tree); @@ -2565,8 +2615,10 @@ package body Prj.Proc is Project => List.Project, From_Project_Node => Loaded_Tree, From_Project_Node_Tree => From_Project_Node_Tree, - Env => Env, - Extended_By => No_Project); + Env => Child_Env, + Extended_By => No_Project, + Child_Env => Child_Env, + Is_Root_Project => False); else Debug_Output ("Failed to parse", Name_Id (List.Path)); end if; @@ -2768,7 +2820,9 @@ package body Prj.Proc is (Declaration_Node, From_Project_Node_Tree), From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, - Extended_By => Project); + Extended_By => Project, + Child_Env => Child_Env, + Is_Root_Project => False); Process_Declarative_Items (Project => Project, @@ -2778,7 +2832,9 @@ package body Prj.Proc is Env => Env, Pkg => No_Package, Item => First_Declarative_Item_Of - (Declaration_Node, From_Project_Node_Tree)); + (Declaration_Node, From_Project_Node_Tree), + Child_Env => Child_Env, + Can_Modify_Child_Env => Is_Root_Project); if Project.Extends /= No_Project then Process_Extended_Project; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 3ac6a88..0a1b9a5 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -1005,7 +1005,8 @@ package body Prj.Tree is ---------------- procedure Initialize - (Self : in out Environment; Flags : Processing_Flags) is + (Self : out Environment; + Flags : Processing_Flags) is begin -- Do not reset the external references, in case we are reloading a -- project, since we want to preserve the current environment. But we @@ -1018,6 +1019,19 @@ package body Prj.Tree is Self.Flags := Flags; end Initialize; + ------------------------- + -- Initialize_And_Copy -- + ------------------------- + + procedure Initialize_And_Copy + (Self : out Environment; + Copy_From : Environment) is + begin + Self.Flags := Copy_From.Flags; + Prj.Ext.Initialize (Self.External, Copy_From => Copy_From.External); + Prj.Env.Copy (From => Copy_From.Project_Path, To => Self.Project_Path); + end Initialize_And_Copy; + ---------- -- Free -- ---------- diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 69372ae..fede1f9 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -60,9 +60,16 @@ package Prj.Tree is -- Configure errors and warnings end record; - procedure Initialize (Self : in out Environment; Flags : Processing_Flags); + procedure Initialize + (Self : out Environment; + Flags : Processing_Flags); -- Initialize a new environment + procedure Initialize_And_Copy + (Self : out Environment; + Copy_From : Environment); + -- Initialize a new environment, copying its values from Copy_From + procedure Free (Self : in out Environment); -- Free the memory used by Self -- cgit v1.1