From patchwork Tue Jan 29 14:24:47 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 216551 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id B888D2C0097 for ; Wed, 30 Jan 2013 01:25:47 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1360074349; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=CP8x88BRq+J9DFXQ4j6P 5Eef9zQ=; b=Q/9dSFDgS3oPpxdNIGMO6VhlqvNme7LfX3/VuarzoGp6AAb8qMHT YwlZkMKOOIXJNjCMZYHff+eANnE1GbvvA9wVyesmgpkQtIQtfUbuR8o8jXGbfGT/ HK6YIijU1AoKidWcHej/gJkMPIW6/shmD/qxZYto3rv6OJgysgc0rmA= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=jveNk1243bevXOsmx7qPDXGK++NA4tLeVuP5sCgX7F9UQ1Ht9+F+ThQAq1wnjF M1KbKnsgNbnPmFg8ByUM3nEf/DNjr8Sksp3uQL+MyIkeqoEKOQIEpM3KZTQb9iXz vX09/aDoijLS+c8zXc/wvVoN6ZpuKfR/nBoGJb4oEyw8c=; Received: (qmail 14601 invoked by alias); 29 Jan 2013 14:25:33 -0000 Received: (qmail 14577 invoked by uid 22791); 29 Jan 2013 14:25:29 -0000 X-SWARE-Spam-Status: No, hits=-0.4 required=5.0 tests=AWL, BAYES_50, KHOP_SPAMHAUS_DROP, RCVD_IN_HOSTKARMA_NO X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 29 Jan 2013 14:24:49 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id EC81F2E2AB; Tue, 29 Jan 2013 09:24:47 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id pPjzi712+nPY; Tue, 29 Jan 2013 09:24:47 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id C49C12E0FB; Tue, 29 Jan 2013 09:24:47 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id C4A023FF09; Tue, 29 Jan 2013 09:24:47 -0500 (EST) Date: Tue, 29 Jan 2013 09:24:47 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Ada 2012: Rule on function writable actuals (AI05-0144-2) Message-ID: <20130129142447.GA6315@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org If the construct N has two or more direct constituents that are names or expressions whose evaluation may occur in an arbitrary order, at least one of which contains a function call with an in out or out parameter, then the construct is legal only if: for each name that is passed as a parameter of mode in out or out to some inner function call C2 (not including the construct N itself), there is no other name anywhere within a direct constituent of the construct C other than the one containing C2, that is known to refer to the same object (RM 6.4.1(6.17/3)). The following test now compiles with errors: pragma Ada_2012; procedure aliasfunc is function Init_Value return Integer is begin return 0; end; function f (a : in out integer) return integer is begin a := a + 1; return 3; end; procedure p (a : in out Integer; b : in out Integer) is begin a := b; end; table : array (1 .. 3) of Integer := (others => 0); x : integer := Init_Value; begin p (a => x, b => table (f (x))); end; Command: gcc -c aliasfunc.adb Output: aliasfunc.adb:24:30: conflict of writable function parameter in construct with arbitrary order of evaluation Tested on x86_64-pc-linux-gnu, committed on trunk 2013-01-29 Javier Miranda * errout.ads, errout.adb (Get_Ignore_Errors): New subprogram. * opt.ads (Warn_On_Overlap): Update documentation. * sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate): Check function writable actuals. * sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration): Check function writable actuals. * sem_ch4.adb (Analyze_Range): Check function writable actuals. * sem_ch5.adb (Analyze_Assignment): Remove code of the initial implementation of AI05-0144. * sem_ch6.adb (Analyze_Function_Return, (Analyze_Procedure_Call.Analyze_Call_And_Resolve): Remove code of the initial implementation of AI05-0144. * sem_res.adb (Resolve): Remove code of the initial implementation. (Resolve_Actuals): Call Check_Function_Writable_Actuals and remove call of the initial implementation. (Resolve_Arithmetic_Op, Resolve_Logical_Op, Resolve_Membership_Op): Check function writable actuals. * sem_util.ad[sb] (Actuals_In_Call): Removed (Check_Order_Dependence): Removed (Save_Actual): Removed (Check_Function_Writable_Actuals): New subprogram. * usage.adb (Usage): Update documentation. * warnsw.adb (Set_Warning_Switch): Enable warn_on_overlap when setting all warnings. Index: sem_aggr.adb =================================================================== --- sem_aggr.adb (revision 195533) +++ sem_aggr.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -1252,6 +1252,8 @@ Set_Etype (N, Aggr_Subtyp); Set_Analyzed (N); end if; + + Check_Function_Writable_Actuals (N); end Resolve_Aggregate; ----------------------------- @@ -2816,6 +2818,8 @@ else Error_Msg_N ("no unique type for this aggregate", A); end if; + + Check_Function_Writable_Actuals (N); end Resolve_Extension_Aggregate; ------------------------------ Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 195538) +++ sem_ch3.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -8061,6 +8061,8 @@ Set_Last_Entity (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); end if; + + Check_Function_Writable_Actuals (N); end Build_Derived_Record_Type; ------------------------ @@ -19678,6 +19680,8 @@ then Derive_Progenitor_Subprograms (T, T); end if; + + Check_Function_Writable_Actuals (N); end Record_Type_Declaration; ---------------------------- Index: sem_ch5.adb =================================================================== --- sem_ch5.adb (revision 195533) +++ sem_ch5.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -692,7 +692,6 @@ -- checks have been applied. Note_Possible_Modification (Lhs, Sure => True); - Check_Order_Dependence; -- ??? a real accessibility check is needed when ??? Index: usage.adb =================================================================== --- usage.adb (revision 195536) +++ usage.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -502,8 +502,8 @@ Write_Line (" .H* turn off warnings for holes in records"); Write_Line (" i*+ turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); - Write_Line (" .i turn on warnings for overlapping actuals"); - Write_Line (" .I* turn off warnings for overlapping actuals"); + Write_Line (" .i*+ turn on warnings for overlapping actuals"); + Write_Line (" .I turn off warnings for overlapping actuals"); Write_Line (" j+ turn on warnings for obsolescent " & "(annex J) feature"); Write_Line (" J* turn off warnings for obsolescent " & Index: sem_util.adb =================================================================== --- sem_util.adb (revision 195538) +++ sem_util.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -57,7 +57,6 @@ with Stand; use Stand; with Style; with Stringt; use Stringt; -with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -96,30 +95,6 @@ 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. - -- The actuals to be checked in a call to Check_Order_Dependence are at - -- positions 1 .. Last. - - 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 => 100, - Table_Name => "Actuals"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -1245,6 +1220,590 @@ end if; end Cannot_Raise_Constraint_Error; + ------------------------------------- + -- Check_Function_Writable_Actuals -- + ------------------------------------- + + procedure Check_Function_Writable_Actuals (N : Node_Id) is + Writable_Actuals_List : Elist_Id := No_Elist; + Identifiers_List : Elist_Id := No_Elist; + Error_Node : Node_Id := Empty; + + procedure Collect_Identifiers (N : Node_Id); + -- In a single traversal of subtree N collect in Writable_Actuals_List + -- all the actuals of functions with writable actuals, and in the list + -- Identifiers_List collect all the identifiers that are not actuals of + -- functions with writable actuals. If a writable actual is referenced + -- twice as writable actual then Error_Node is set to reference its + -- second occurrence, the error is reported, and the tree traversal + -- is abandoned. + + function Get_Function_Id (Call : Node_Id) return Entity_Id; + -- Return the entity associated with the function call + + procedure Preanalyze_Without_Errors (N : Node_Id); + -- Preanalyze N without reporting errors + + ------------------------- + -- Collect_Identifiers -- + ------------------------- + + procedure Collect_Identifiers (N : Node_Id) is + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Process a single node during the tree traversal to collect the + -- writable actuals of functions and all the identifiers which are + -- not writable actuals of functions. + + function Contains (List : Elist_Id; N : Node_Id) return Boolean; + -- Returns True if List has a node whose Entity is Entity (N) + + ------------------------- + -- Check_Function_Call -- + ------------------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + Is_Writable_Actual : Boolean := False; + + begin + if Nkind (N) = N_Identifier then + + -- No analysis possible if the entity is not decorated + + if No (Entity (N)) then + return Skip; + + -- We don't collect identifiers of packages, called functions, + -- etc. + + elsif Ekind_In (Entity (N), + E_Package, + E_Function, + E_Procedure, + E_Entry) + then + return Skip; + + -- Analyze if N is a writable actual of a function + + elsif Nkind (Parent (N)) = N_Function_Call then + declare + Call : constant Node_Id := Parent (N); + Id : constant Entity_Id := Get_Function_Id (Call); + Actual : Node_Id; + Formal : Node_Id; + + begin + Formal := First_Formal (Id); + Actual := First_Actual (Call); + while Present (Actual) and then Present (Formal) loop + if Actual = N then + if Ekind_In (Formal, E_Out_Parameter, + E_In_Out_Parameter) + then + Is_Writable_Actual := True; + end if; + + exit; + end if; + + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + end; + end if; + + if Is_Writable_Actual then + if Contains (Writable_Actuals_List, N) then + Error_Msg_N + ("conflict of writable function parameter in " + & "construct with arbitrary order of evaluation", N); + Error_Node := N; + return Abandon; + end if; + + if Writable_Actuals_List = No_Elist then + Writable_Actuals_List := New_Elmt_List; + end if; + + Append_Elmt (N, Writable_Actuals_List); + else + if Identifiers_List = No_Elist then + Identifiers_List := New_Elmt_List; + end if; + + Append_Unique_Elmt (N, Identifiers_List); + end if; + end if; + + return OK; + end Check_Node; + + -------------- + -- Contains -- + -------------- + + function Contains + (List : Elist_Id; + N : Node_Id) return Boolean + is + pragma Assert (Nkind (N) in N_Has_Entity); + + Elmt : Elmt_Id; + begin + if List = No_Elist then + return False; + end if; + + Elmt := First_Elmt (List); + loop + if No (Elmt) then + return False; + elsif Entity (Node (Elmt)) = Entity (N) then + return True; + else + Next_Elmt (Elmt); + end if; + end loop; + end Contains; + + ------------------ + -- Do_Traversal -- + ------------------ + + procedure Do_Traversal is new Traverse_Proc (Check_Node); + -- The traversal procedure + + -- Start of processing for Collect_Identifiers + + begin + if Present (Error_Node) then + return; + end if; + + if Nkind (N) in N_Subexpr + and then Is_Static_Expression (N) + then + return; + end if; + + Do_Traversal (N); + end Collect_Identifiers; + + --------------------- + -- Get_Function_Id -- + --------------------- + + function Get_Function_Id (Call : Node_Id) return Entity_Id is + Nam : constant Node_Id := Name (Call); + Id : Entity_Id; + begin + if Nkind (Nam) = N_Explicit_Dereference then + Id := Etype (Nam); + pragma Assert (Ekind (Id) = E_Subprogram_Type); + + elsif Nkind (Nam) = N_Selected_Component then + Id := Entity (Selector_Name (Nam)); + + elsif Nkind (Nam) = N_Indexed_Component then + Id := Entity (Selector_Name (Prefix (Nam))); + + else + Id := Entity (Nam); + end if; + + return Id; + end Get_Function_Id; + + --------------------------- + -- Preanalyze_Expression -- + --------------------------- + + procedure Preanalyze_Without_Errors (N : Node_Id) is + Status : constant Boolean := Get_Ignore_Errors; + begin + Set_Ignore_Errors (True); + Preanalyze (N); + Set_Ignore_Errors (Status); + end Preanalyze_Without_Errors; + + -- Start of processing for Check_Function_Writable_Actuals + + begin + if Ada_Version < Ada_2012 + or else (not (Nkind (N) in N_Op) + and then not (Nkind (N) in N_Membership_Test) + and then not Nkind_In (N, + N_Range, + N_Aggregate, + N_Extension_Aggregate, + N_Full_Type_Declaration, + N_Function_Call, + N_Procedure_Call_Statement, + N_Entry_Call_Statement)) + or else (Nkind (N) = N_Full_Type_Declaration + and then not Is_Record_Type (Defining_Identifier (N))) + then + return; + end if; + + -- If a construct C has two or more direct constituents that are names + -- or expressions whose evaluation may occur in an arbitrary order, at + -- least one of which contains a function call with an in out or out + -- parameter, then the construct is legal only if: for each name N that + -- is passed as a parameter of mode in out or out to some inner function + -- call C2 (not including the construct C itself), there is no other + -- name anywhere within a direct constituent of the construct C other + -- than the one containing C2, that is known to refer to the same + -- object (RM 6.4.1(6.17/3)). + + case Nkind (N) is + when N_Range => + Collect_Identifiers (Low_Bound (N)); + Collect_Identifiers (High_Bound (N)); + + when N_Op | N_Membership_Test => + declare + Expr : Node_Id; + begin + Collect_Identifiers (Left_Opnd (N)); + + if Present (Right_Opnd (N)) then + Collect_Identifiers (Right_Opnd (N)); + end if; + + if Nkind_In (N, N_In, N_Not_In) + and then Present (Alternatives (N)) + then + Expr := First (Alternatives (N)); + while Present (Expr) loop + Collect_Identifiers (Expr); + + Next (Expr); + end loop; + end if; + end; + + when N_Full_Type_Declaration => + declare + function Get_Record_Part (N : Node_Id) return Node_Id; + -- Return the record part of this record type definition + + function Get_Record_Part (N : Node_Id) return Node_Id is + Type_Def : constant Node_Id := Type_Definition (N); + begin + if Nkind (Type_Def) = N_Derived_Type_Definition then + return Record_Extension_Part (Type_Def); + else + return Type_Def; + end if; + end Get_Record_Part; + + Comp : Node_Id; + Def_Id : Entity_Id := Defining_Identifier (N); + Rec : Node_Id := Get_Record_Part (N); + begin + -- No need to perform any analysis if the record has no + -- components + + if No (Rec) or else No (Component_List (Rec)) then + return; + end if; + + -- Collect the identifiers starting from the deepest + -- derivation. Done to report the error in the deepest + -- derivation. + + loop + if Present (Component_List (Rec)) then + Comp := First (Component_Items (Component_List (Rec))); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then Present (Expression (Comp)) + then + Collect_Identifiers (Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + + exit when No (Underlying_Type (Etype (Def_Id))) + or else Base_Type (Underlying_Type (Etype (Def_Id))) + = Def_Id; + + Def_Id := Base_Type (Underlying_Type (Etype (Def_Id))); + Rec := Get_Record_Part (Parent (Def_Id)); + end loop; + end; + + when N_Subprogram_Call | + N_Entry_Call_Statement => + declare + Id : constant Entity_Id := Get_Function_Id (N); + Formal : Node_Id; + Actual : Node_Id; + + begin + Formal := First_Formal (Id); + Actual := First_Actual (N); + while Present (Actual) and then Present (Formal) loop + if Ekind_In (Formal, E_Out_Parameter, + E_In_Out_Parameter) + then + Collect_Identifiers (Actual); + end if; + + Next_Formal (Formal); + Next_Actual (Actual); + end loop; + end; + + when N_Aggregate | + N_Extension_Aggregate => + declare + Assoc : Node_Id; + Choice : Node_Id; + Comp_Expr : Node_Id; + + begin + -- Handle the N_Others_Choice of array aggregates with static + -- bounds. There is no need to perform this analysis in + -- aggregates without static bounds since we cannot evaluate + -- if the N_Others_Choice covers several elements. There is + -- no need to handle the N_Others choice of record aggregates + -- since at this stage it has been already expanded by + -- Resolve_Record_Aggregate. + + if Is_Array_Type (Etype (N)) + and then Nkind (N) = N_Aggregate + and then Present (Aggregate_Bounds (N)) + and then Compile_Time_Known_Bounds (Etype (N)) + and then Expr_Value (High_Bound (Aggregate_Bounds (N))) + > Expr_Value (Low_Bound (Aggregate_Bounds (N))) + then + declare + Count_Components : Uint := Uint_0; + Num_Components : Uint; + Others_Assoc : Node_Id; + Others_Choice : Node_Id := Empty; + Others_Box_Present : Boolean := False; + + begin + -- Count positional associations + + if Present (Expressions (N)) then + Comp_Expr := First (Expressions (N)); + while Present (Comp_Expr) loop + Count_Components := Count_Components + 1; + Next (Comp_Expr); + end loop; + end if; + + -- Count the rest of elements and locate the N_Others + -- choice (if any) + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Others_Assoc := Assoc; + Others_Choice := Choice; + Others_Box_Present := Box_Present (Assoc); + + -- Count several components + + elsif Nkind_In (Choice, N_Range, + N_Subtype_Indication) + or else (Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice))) + then + declare + L, H : Node_Id; + begin + Get_Index_Bounds (Choice, L, H); + pragma Assert + (Compile_Time_Known_Value (L) + and then Compile_Time_Known_Value (H)); + Count_Components := + Count_Components + + Expr_Value (H) - Expr_Value (L) + 1; + end; + + -- Count single component. No other case available + -- since we are handling an aggregate with static + -- bounds. + + else + pragma Assert (Is_Static_Expression (Choice) + or else Nkind (Choice) = N_Identifier + or else Nkind (Choice) = N_Integer_Literal); + + Count_Components := Count_Components + 1; + end if; + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + Num_Components := + Expr_Value (High_Bound (Aggregate_Bounds (N))) + - Expr_Value (Low_Bound (Aggregate_Bounds (N))) + + 1; + + pragma Assert (Count_Components <= Num_Components); + + -- Handle the N_Others choice if it covers several + -- components + + if Present (Others_Choice) + and then (Num_Components - Count_Components) > 1 + then + if not Others_Box_Present then + + -- At this stage, if expansion is active, the + -- expression of the others choice has not been + -- analyzed. Hence we generate a duplicate and + -- we analyze it silently to have available the + -- minimum decoration required to collect the + -- identifiers. + + if not Expander_Active then + Comp_Expr := Expression (Others_Assoc); + else + Comp_Expr := + New_Copy_Tree (Expression (Others_Assoc)); + Preanalyze_Without_Errors (Comp_Expr); + end if; + + Collect_Identifiers (Comp_Expr); + + if Writable_Actuals_List /= No_Elist then + + -- As suggested by Robert, at current stage we + -- report occurrences of this case as warnings. + + Error_Msg_N + ("conflict of writable function parameter in " + & "construct with arbitrary order of " + & "evaluation?", + Node (First_Elmt (Writable_Actuals_List))); + end if; + end if; + end if; + end; + end if; + + -- Handle ancestor part of extension aggregates + + if Nkind (N) = N_Extension_Aggregate then + Collect_Identifiers (Ancestor_Part (N)); + end if; + + -- Handle positional associations + + if Present (Expressions (N)) then + Comp_Expr := First (Expressions (N)); + while Present (Comp_Expr) loop + if not Is_Static_Expression (Comp_Expr) then + Collect_Identifiers (Comp_Expr); + end if; + + Next (Comp_Expr); + end loop; + end if; + + -- Handle discrete associations + + if Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + + if not Box_Present (Assoc) then + Choice := First (Choices (Assoc)); + while Present (Choice) loop + + -- For now we skip discriminants since it requires + -- performing the analysis in two phases: first one + -- analyzing discriminants and second one analyzing + -- the rest of components since discriminants are + -- evaluated prior to components: too much extra + -- work to detect a corner case??? + + if Nkind (Choice) in N_Has_Entity + and then Present (Entity (Choice)) + and then Ekind (Entity (Choice)) + = E_Discriminant + then + null; + + elsif Box_Present (Assoc) then + null; + + else + if not Analyzed (Expression (Assoc)) then + Comp_Expr := + New_Copy_Tree (Expression (Assoc)); + Preanalyze_Without_Errors (Comp_Expr); + else + Comp_Expr := Expression (Assoc); + end if; + + Collect_Identifiers (Comp_Expr); + end if; + + Next (Choice); + end loop; + end if; + + Next (Assoc); + end loop; + end if; + end; + + when others => + return; + end case; + + -- No further action needed if we already reported an error + + if Present (Error_Node) then + return; + end if; + + -- Check if some writable argument of a function is referenced + + if Writable_Actuals_List /= No_Elist + and then Identifiers_List /= No_Elist + then + declare + Elmt_1 : Elmt_Id; + Elmt_2 : Elmt_Id; + + begin + Elmt_1 := First_Elmt (Writable_Actuals_List); + while Present (Elmt_1) loop + Elmt_2 := First_Elmt (Identifiers_List); + while Present (Elmt_2) loop + if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then + Error_Msg_N + ("conflict of writable function parameter in construct " + & "with arbitrary order of evaluation", + Node (Elmt_1)); + end if; + + Next_Elmt (Elmt_2); + end loop; + + Next_Elmt (Elmt_1); + end loop; + end; + end if; + end Check_Function_Writable_Actuals; + -------------------------------- -- Check_Implicit_Dereference -- -------------------------------- @@ -1529,65 +2088,6 @@ end if; end Check_Nested_Access; - ---------------------------- - -- Check_Order_Dependence -- - ---------------------------- - - procedure Check_Order_Dependence is - Act1 : Node_Id; - Act2 : Node_Id; - - begin - if Ada_Version < Ada_2012 then - return; - end if; - - -- Ada 2012 AI05-0144-2: Dangerous order dependence. Actuals in nested - -- calls within a construct have been collected. If one of them is - -- writable and overlaps with another one, evaluation of the enclosing - -- construct is nondeterministic. This is illegal in Ada 2012, but is - -- treated as a warning for now. - - for J in 1 .. 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 1 .. 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 Parent (Act1) /= Parent (Act2) - then - Error_Msg_N - ("result may differ if evaluated " - & "after other actual in expression??", Act1); - end if; - end if; - end loop; - end if; - end loop; - - -- Remove checked actuals from table - - Actuals_In_Call.Set_Last (0); - end Check_Order_Dependence; - ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -12595,35 +13095,6 @@ end if; end Same_Value; - ----------------- - -- Save_Actual -- - ----------------- - - procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is - begin - if Ada_Version < Ada_2012 then - return; - - elsif 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; - ------------------------ -- Scope_Is_Transient -- ------------------------ Index: sem_util.ads =================================================================== --- sem_util.ads (revision 195539) +++ sem_util.ads (working copy) @@ -178,6 +178,17 @@ -- not necessarily mean that CE could be raised, but a response of True -- means that for sure CE cannot be raised. + procedure Check_Function_Writable_Actuals (N : Node_Id); + -- (Ada 2012): If the construct N has two or more direct constituents that + -- are names or expressions whose evaluation may occur in an arbitrary + -- order, at least one of which contains a function call with an in out or + -- out parameter, then the construct is legal only if: for each name that + -- is passed as a parameter of mode in out or out to some inner function + -- call C2 (not including the construct N itself), there is no other name + -- anywhere within a direct constituent of the construct C other than + -- the one containing C2, that is known to refer to the same object (RM + -- 6.4.1(6.17/3)). + procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id); -- AI05-139-2: Accessors and iterators for containers. This procedure -- checks whether T is a reference type, and if so it adds an interprettion @@ -215,11 +226,6 @@ -- 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. @@ -1404,11 +1410,6 @@ -- 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 language versions). - 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. Index: sem_res.adb =================================================================== --- sem_res.adb (revision 195533) +++ sem_res.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -2864,18 +2864,6 @@ return; end if; - -- AI05-144-2: Check dangerous order dependence within an expression - -- that is not a subexpression. Exclude RHS of an assignment, because - -- both sides may have side-effects and the check must be performed - -- over the statement. - - if Nkind (Parent (N)) not in N_Subexpr - and then Nkind (Parent (N)) /= N_Assignment_Statement - and then Nkind (Parent (N)) /= N_Procedure_Call_Statement - then - Check_Order_Dependence; - end if; - -- The expression is definitely NOT overloaded at this point, so -- we reset the Is_Overloaded flag to avoid any confusion when -- reanalyzing the node. @@ -3378,6 +3366,7 @@ begin Check_Argument_Order; + Check_Function_Writable_Actuals (N); if Present (First_Actual (N)) then Check_Prefixed_Call; @@ -3776,21 +3765,6 @@ end if; end if; - -- Save actual for subsequent check on order dependence, and - -- indicate whether actual is modifiable. For AI05-0144-2. - - -- If this is a call to a reference function that is the result - -- of expansion, as in element iterator loops, this does not lead - -- to a dangerous order dependence: only subsequent use of the - -- denoted element might, in some enclosing call. - - if not Has_Implicit_Dereference (Etype (Nam)) - or else Comes_From_Source (N) - then - Save_Actual (A, Ekind (F) /= E_In_Parameter); - end if; - - -- For mode IN, if actual is an entity, and the type of the formal -- has warnings suppressed, then we reset Never_Set_In_Source for -- the calling entity. The reason for this is to catch cases like -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram @@ -5108,6 +5082,7 @@ Check_Unset_Reference (L); Check_Unset_Reference (R); + Check_Function_Writable_Actuals (N); end Resolve_Arithmetic_Op; ------------------ @@ -7632,6 +7607,8 @@ end if; end; end if; + + Check_Function_Writable_Actuals (N); end Resolve_Logical_Op; --------------------------- @@ -7729,6 +7706,7 @@ if Present (Alternatives (N)) then Resolve_Set_Membership; + Check_Function_Writable_Actuals (N); return; elsif not Is_Overloaded (R) @@ -7793,6 +7771,7 @@ end if; Eval_Membership_Op (N); + Check_Function_Writable_Actuals (N); end Resolve_Membership_Op; ------------------ Index: warnsw.adb =================================================================== --- warnsw.adb (revision 195533) +++ warnsw.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2013, 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- -- @@ -292,6 +292,7 @@ Warn_On_Non_Local_Exception := True; Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; + Warn_On_Overlap := True; Warn_On_Parameter_Order := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; Index: errout.adb =================================================================== --- errout.adb (revision 195533) +++ errout.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -1458,6 +1458,15 @@ return S; end First_Sloc; + ----------------------- + -- Get_Ignore_Errors -- + ----------------------- + + function Get_Ignore_Errors return Boolean is + begin + return Errors_Must_Be_Ignored; + end Get_Ignore_Errors; + ---------------- -- Initialize -- ---------------- Index: errout.ads =================================================================== --- errout.ads (revision 195533) +++ errout.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -746,6 +746,9 @@ -- where the expression is parenthesized, an attempt is made to include -- the parentheses (i.e. to return the location of the initial paren). + function Get_Ignore_Errors return Boolean; + -- Return True if all error calls are ignored. + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) renames Erroutc.Purge_Messages; -- All error messages whose location is in the range From .. To (not Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 195533) +++ sem_ch4.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -3611,6 +3611,8 @@ Check_Universal_Expression (L); Check_Universal_Expression (H); end if; + + Check_Function_Writable_Actuals (N); end Analyze_Range; ----------------------- Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 195536) +++ sem_ch6.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -978,10 +978,6 @@ & "null-excluding return??", Reason => CE_Null_Not_Allowed); end if; - - -- Apply checks suggested by AI05-0144 (dangerous order dependence) - - Check_Order_Dependence; end if; end Analyze_Function_Return; @@ -1266,11 +1262,6 @@ if Nkind (N) = N_Procedure_Call_Statement then Analyze_Call (N); Resolve (N, Standard_Void_Type); - - -- Apply checks suggested by AI05-0144 - - Check_Order_Dependence; - else Analyze (N); end if; Index: opt.ads =================================================================== --- opt.ads (revision 195536) +++ opt.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -1595,8 +1595,9 @@ Warn_On_Overlap : Boolean := False; -- GNAT - -- Set to True to generate warnings when a writable actual which is not - -- a by-copy type overlaps with another actual in a subprogram call. + -- Set to True to generate warnings when a writable actual overlaps with + -- another actual in a subprogram call. This applies only in modes before + -- Ada 2012. Starting with Ada 2012, such overlaps are illegal. -- Modified by use of -gnatw.i/.I. Warn_On_Questionable_Missing_Parens : Boolean := True;