From e771c08509c5bc959cd8a59aaa15965cfc04a48c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 23 Jun 2010 08:50:13 +0200 Subject: [PATCH] [multiple changes] 2010-06-23 Javier Miranda * atree.ads (Set_Reporting_Proc): New subprogram. * atree.adb: Remove dependency on packages Opt and SCIL_LL. (Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls to routines of package Scil_ll by indirect call to the registered subprogram. (Set_Reporting_Proc): New subprogram. Used to register a subprogram that is invoked when a node is allocated, replaced or rewritten. * scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying the SCIL node. Used as argument for Set_Reporting_Proc. (Initialize): Register Copy_SCIL_Node as the reporting routine that is invoked by atree. 2010-06-23 Thomas Quinot * sem_ch3.ads: Minor reformatting. 2010-06-23 Ed Schonberg * sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode, always analyze the generic body and instance, because it may be needed downstream. (Mark_Context): Prepend the with clauses for needed generic units, so they appear in a better order for CodePeer. * sem_util.adb, sem_util.ads: Prototype code for AI05-0144. 2010-06-23 Emmanuel Briot * prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram. From-SVN: r161252 --- gcc/ada/ChangeLog | 31 +++++++++++++ gcc/ada/atree.adb | 33 +++++++++----- gcc/ada/atree.ads | 8 +++- gcc/ada/prj-nmsc.adb | 103 ++++++++++++++++++++----------------------- gcc/ada/prj.ads | 3 +- gcc/ada/scil_ll.adb | 14 ++++++ gcc/ada/sem_ch12.adb | 17 ++++--- gcc/ada/sem_ch3.ads | 12 +++-- gcc/ada/sem_util.adb | 88 +++++++++++++++++++++++++++++++++++- gcc/ada/sem_util.ads | 11 +++++ 10 files changed, 238 insertions(+), 82 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ea344cbab21..ba3b9e99650 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2010-06-23 Javier Miranda + + * atree.ads (Set_Reporting_Proc): New subprogram. + * atree.adb: Remove dependency on packages Opt and SCIL_LL. + (Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls + to routines of package Scil_ll by indirect call to the registered + subprogram. + (Set_Reporting_Proc): New subprogram. Used to register a subprogram + that is invoked when a node is allocated, replaced or rewritten. + * scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying + the SCIL node. Used as argument for Set_Reporting_Proc. + (Initialize): Register Copy_SCIL_Node as the reporting routine that + is invoked by atree. + +2010-06-23 Thomas Quinot + + * sem_ch3.ads: Minor reformatting. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode, + always analyze the generic body and instance, because it may be needed + downstream. + (Mark_Context): Prepend the with clauses for needed generic units, so + they appear in a better order for CodePeer. + * sem_util.adb, sem_util.ads: Prototype code for AI05-0144. + +2010-06-23 Emmanuel Briot + + * prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram. + 2010-06-23 Robert Dewar * g-pehage.adb, exp_ch13.adb: Minor reformatting. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index c0c5bd8dde9..807527230af 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -38,14 +38,15 @@ pragma Style_Checks (All_Checks); with Debug; use Debug; with Nlists; use Nlists; -with Opt; use Opt; with Output; use Output; with Sinput; use Sinput; -with SCIL_LL; use SCIL_LL; with Tree_IO; use Tree_IO; package body Atree is + Reporting_Proc : Report_Proc := null; + -- Record argument to last call to Set_Reporting_Proc + --------------- -- Debugging -- --------------- @@ -534,10 +535,10 @@ package body Atree is Orig_Nodes.Set_Last (Nodes.Last); Allocate_List_Tables (Nodes.Last); - -- Update the SCIL_Node field (if available) + -- Invoke the reporting procedure (if available) - if Generate_SCIL then - Set_SCIL_Node (New_Id, Get_SCIL_Node (Src)); + if Reporting_Proc /= null then + Reporting_Proc.all (Target => New_Id, Source => Src); end if; return New_Id; @@ -925,6 +926,16 @@ package body Atree is return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6); end Ekind_In; + ------------------------ + -- Set_Reporting_Proc -- + ------------------------ + + procedure Set_Reporting_Proc (P : Report_Proc) is + begin + pragma Assert (Reporting_Proc = null); + Reporting_Proc := P; + end Set_Reporting_Proc; + ------------------ -- Error_Posted -- ------------------ @@ -1580,10 +1591,10 @@ package body Atree is Orig_Nodes.Table (Old_Node) := Old_Node; - -- Update the SCIL_Node field (if available) + -- Invoke the reporting procedure (if available) - if Generate_SCIL then - Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node)); + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); end if; end Replace; @@ -1644,10 +1655,10 @@ package body Atree is Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); - -- Update the SCIL_Node field (if available) + -- Invoke the reporting procedure (if available) - if Generate_SCIL then - Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node)); + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); end if; end Rewrite; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 7408b0e48fe..11787bc116e 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -461,6 +461,12 @@ package Atree is -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. + type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); + + procedure Set_Reporting_Proc (P : Report_Proc); + -- Register a procedure that is invoked when a node is allocated, replaced + -- or rewritten. + type Traverse_Result is (Abandon, OK, OK_Orig, Skip); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc. See below for details. diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index f6557f18717..b502b2aebc9 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -467,6 +467,32 @@ package body Prj.Nmsc is -- Debug print a value for a specific property. Does nothing when not in -- debug mode + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id); + -- Emits either an error or warning message (or nothing), depending on Kind + + ---------------------- + -- Error_Or_Warning -- + ---------------------- + + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id) is + begin + case Kind is + when Error => Error_Msg (Flags, Msg, Location, Project); + when Warning => Error_Msg (Flags, "?" & Msg, Location, Project); + when Silent => null; + end case; + end Error_Or_Warning; + ------------------------------ -- Replace_Into_Name_Buffer -- ------------------------------ @@ -5170,8 +5196,8 @@ package body Prj.Nmsc is begin if Root_Dir'Length = 0 then Err_Vars.Error_Msg_File_1 := Base_Dir; - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "{ is not a valid directory.", Location, Project); else @@ -5210,8 +5236,8 @@ package body Prj.Nmsc is if not Dir_Exists then Err_Vars.Error_Msg_File_1 := From; - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "{ is not a valid directory", Location, Project); else @@ -5291,21 +5317,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Object_Dir.Value); - - case Data.Flags.Require_Obj_Dirs is - when Error => - Error_Msg - (Data.Flags, - "object directory { not found", - Project.Location, Project); - when Warning => - Error_Msg - (Data.Flags, - "?object directory { not found", - Project.Location, Project); - when Silent => - null; - end case; + Error_Or_Warning + (Data.Flags, Data.Flags.Require_Obj_Dirs, + "object directory { not found", Project.Location, Project); end if; end if; @@ -6493,8 +6507,8 @@ package body Prj.Nmsc is if not Found then Error_Msg_Name_1 := Name_Id (Source.Display_File); Error_Msg_Name_2 := Name_Id (Source.Unit.Name); - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "source file %% for unit %% not found", No_Location, Project.Project); @@ -6536,41 +6550,18 @@ package body Prj.Nmsc is while NL /= No_Name_Location loop if not NL.Found then Err_Vars.Error_Msg_File_1 := NL.Name; - - case Data.Flags.Missing_Source_Files is - when Error => - if First_Error then - Error_Msg - (Data.Flags, - "source file { not found", - NL.Location, Project.Project); - First_Error := False; - - else - Error_Msg - (Data.Flags, - "\source file { not found", - NL.Location, Project.Project); - end if; - - when Warning => - if First_Error then - Error_Msg - (Data.Flags, - "?source file { not found", - NL.Location, Project.Project); - First_Error := False; - - else - Error_Msg - (Data.Flags, - "?\source file { not found", - NL.Location, Project.Project); - end if; - - when Silent => - null; - end case; + if First_Error then + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "source file { not found", + NL.Location, Project.Project); + First_Error := False; + else + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "\source file { not found", + NL.Location, Project.Project); + end if; end if; NL := Source_Names_Htable.Get_Next (Project.Source_Names); diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 0cb504a8274..75bb078b063 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1496,7 +1496,8 @@ package Prj is -- -- Missing_Source_Files indicates whether it is an error or a warning that -- a source file mentioned in the Source_Files attributes is not actually - -- found in the source directories + -- found in the source directories. This also impacts errors for missing + -- source directories. Gprbuild_Flags : constant Processing_Flags; Gprclean_Flags : constant Processing_Flags; diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb index 388abdb2885..4591d8ef287 100644 --- a/gcc/ada/scil_ll.adb +++ b/gcc/ada/scil_ll.adb @@ -37,6 +37,10 @@ with Table; package body SCIL_LL is + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id); + -- Copy the SCIL field from Source to Target (it is used as the argument + -- for a call to Set_Reporting_Proc in package atree). + function SCIL_Nodes_Table_Size return Pos; -- Used to initialize the table of SCIL nodes because we do not want -- to consume memory for this table if it is not required. @@ -64,6 +68,15 @@ package body SCIL_LL is -- This table records the value of attribute SCIL_Node of all the -- tree nodes. + -------------------- + -- Copy_SCIL_Node -- + -------------------- + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is + begin + Set_SCIL_Node (Target, Get_SCIL_Node (Source)); + end Copy_SCIL_Node; + ---------------- -- Initialize -- ---------------- @@ -71,6 +84,7 @@ package body SCIL_LL is procedure Initialize is begin SCIL_Nodes.Init; + Set_Reporting_Proc (Copy_SCIL_Node'Access); end Initialize; ------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index da144b89810..757276b0009 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3237,7 +3237,8 @@ package body Sem_Ch12 is or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) and then (Is_In_Main_Unit (N) - or else Might_Inline_Subp) + or else Might_Inline_Subp + or else CodePeer_Mode) and then not Is_Actual_Pack and then not Inline_Now and then (Operating_Mode = Generate_Code @@ -10421,7 +10422,7 @@ package body Sem_Ch12 is Set_Implicit_With (Withn); Set_Library_Unit (Withn, Cunit (CU)); Set_Withed_Body (Withn, Cunit (CU)); - Append (Withn, Context_Items (Cunit (Inst_CU))); + Prepend (Withn, Context_Items (Cunit (Inst_CU))); end Add_Implicit_With; begin @@ -10433,9 +10434,15 @@ package body Sem_Ch12 is return; end if; - -- If G is itself declared within an instance, indicate that the generic - -- body of that instance is also needed by C. This must be done - -- recursively. + -- Nothing to do if G is local. + + if Inst_CU = Gen_CU then + return; + end if; + + -- If G is itself declared within an instance, indicate that the + -- generic body of that instance is also needed by C. This must be + -- done recursively. Scop := Scope (Defining_Entity (Gen_Decl)); diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 6bfa52844d0..18b585f04aa 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -84,13 +84,11 @@ package Sem_Ch3 is procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Process an access type declaration - procedure Build_Itype_Reference - (Ityp : Entity_Id; - Nod : Node_Id); + procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id); -- Create a reference to an internal type, for use by Gigi. The back-end - -- elaborates itypes on demand, i.e. when their first use is seen. This - -- can lead to scope anomalies if the first use is within a scope that is - -- nested within the scope that contains the point of definition of the + -- elaborates itypes on demand, i.e. when their first use is seen. This can + -- lead to scope anomalies if the first use is within a scope that is + -- nested within the scope that contains the point of definition of the -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f96b45b1754..cbc099ee059 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -56,6 +56,7 @@ with Sinput; use Sinput; with Stand; use Stand; with Style; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -93,6 +94,88 @@ package body Sem_Util is subtype NCT_Header_Num is Int range 0 .. 511; -- Defines range of headers in hash tables (512 headers) + ----------------------------------- + -- Order dependence : AI05-0144 -- + ----------------------------------- + + -- Each actual in a call is entered into the table below. A flag + -- indicates whether the corresponding formal is out or in out. + -- Each top-level call (procedure call, condition, assignment) + -- examines all the actuals for a possible order dependence. + -- The table is reset after each such check. + + type Actual_Name is record + Act : Node_Id; + Is_Writable : Boolean; + end record; + + package Actuals_In_Call is new Table.Table ( + Table_Component_Type => Actual_Name, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Actuals"); + + procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is + begin + if Is_Entity_Name (N) + or else Nkind_In (N, + N_Indexed_Component, N_Selected_Component, N_Slice) + or else (Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Access) + + then + -- We are only interested in in out parameters of inner calls. + + if not Writable + or else Nkind (Parent (N)) = N_Function_Call + or else Nkind (Parent (N)) in N_Op + then + Actuals_In_Call.Increment_Last; + Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable); + end if; + end if; + end Save_Actual; + + procedure Check_Order_Dependence is + Act1, Act2 : Node_Id; + begin + for J in 0 .. Actuals_In_Call.Last loop + + if Actuals_In_Call.Table (J).Is_Writable then + Act1 := Actuals_In_Call.Table (J).Act; + + if Nkind (Act1) = N_Attribute_Reference then + Act1 := Prefix (Act1); + end if; + + for K in 0 .. Actuals_In_Call.Last loop + if K /= J then + Act2 := Actuals_In_Call.Table (K).Act; + if Nkind (Act2) = N_Attribute_Reference then + Act2 := Prefix (Act2); + end if; + + if Actuals_In_Call.Table (K).Is_Writable + and then K < J + then + -- already checked + null; + + elsif Denotes_Same_Object (Act1, Act2) + and then False + then + Error_Msg_N ("?,mighty suspicious!!!", Act1); + end if; + end if; + end loop; + end if; + end loop; + + Actuals_In_Call.Set_Last (0); + end Check_Order_Dependence; + ----------------------- -- Local Subprograms -- ----------------------- @@ -2251,7 +2334,9 @@ package body Sem_Util is begin if Is_Entity_Name (A1) then - if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then + if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) + and then not Is_Access_Type (Etype (A1)) + then return Denotes_Same_Object (A1, Prefix (A2)) or else Denotes_Same_Prefix (A1, Prefix (A2)); else @@ -7862,6 +7947,7 @@ package body Sem_Util is if Nkind (N) = N_Allocator then if Is_Dynamic then Set_Is_Dynamic_Coextension (N); + else Set_Is_Static_Coextension (N); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index dd655c9beb9..daa1c9dd2ad 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -141,6 +141,11 @@ package Sem_Util is -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag -- accordingly. This is currently only enabled for VM_Target /= No_VM. + procedure Check_Order_Dependence; + -- Examine the actuals in a top-level call to determine whether aliasing + -- between two actuals, one of which is writable, can make the call + -- order-dependent. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. @@ -1168,6 +1173,12 @@ package Sem_Util is -- are only partially ordered, so Scope_Within_Or_Same (A,B) and -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B. + procedure Save_Actual (N : Node_Id; Writable : Boolean := False); + -- Enter an actual in a call in a table global, for subsequent check + -- of possible order dependence in the presence of in out parameters + -- for functions in Ada 2012 (or access parameters in older versions + -- of the language). + function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean; -- Like Scope_Within_Or_Same, except that this function returns -- False in the case where Scope1 and Scope2 are the same scope. -- 2.30.2