From 9e52df9ccbd8040b1c15ca583e1204d1814b4bb7 Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 27 Apr 2016 12:37:55 +0000 Subject: [PATCH] 2016-04-27 Hristian Kirtchev * sem_res.adb (Flag_Effectively_Volatile_Objects): New routine. (Resolve_Actuals): Flag effectively volatile objects with enabled property Async_Writers or Effective_Reads as illegal. * sem_util.adb (Is_OK_Volatile_Context): Comment reformatting. 2016-04-27 Javier Miranda * exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate the profile of the equality operator if it has been explicitly defined as abstract in the parent type. Required to avoid reporting an spurious error. 2016-04-27 Ed Schonberg * sem_dim.ads, sem_dim.adb (Check_Expression_Dimensions): New procedure to compute the dimension vector of a scalar expression and compare it with the dimensions if its expected subtype. Used for the ultimate components of a multidimensional aggregate, whose components typically are themselves aggregates that are expanded separately. Previous to this patch, dimensionality checking on such aggregates generated spurious errors. * sem_aggr.adb (Resolve_Array_Aggregate): Use Check_Expression_Dimensions when needed. 2016-04-27 Javier Miranda * einfo.ads, einfo.adb (Corresponding_Function): New attribute (applicable to E_Procedure). (Corresponding_Procedure): New attribute (applicable to E_Function). * exp_util.adb (Build_Procedure_Form): Link the function with its internally built proc and viceversa. * sem_ch6.adb (Build_Subprogram_Declaration): Propagate the attribute Rewritten_For_C and Corresponding_Procedure to the body. * exp_ch6.adb (Rewritten_For_C_Func_Id): Removed. (Rewritten_For_C_Proc_Id): Removed. * exp_unst.adb (Note_Uplevel_Ref): Use the new attribute to locate the corresponding procedure. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@235493 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 40 +++++++++++++++++++++++++ gcc/ada/einfo.adb | 36 +++++++++++++++++++++++ gcc/ada/einfo.ads | 19 +++++++++++- gcc/ada/exp_ch3.adb | 6 ++-- gcc/ada/exp_ch6.adb | 82 ++++------------------------------------------------ gcc/ada/exp_unst.adb | 2 +- gcc/ada/exp_util.adb | 5 +++- gcc/ada/sem_aggr.adb | 9 +++++- gcc/ada/sem_ch6.adb | 20 ++++++++----- gcc/ada/sem_dim.adb | 27 +++++++++++++++-- gcc/ada/sem_dim.ads | 12 +++++++- gcc/ada/sem_res.adb | 75 +++++++++++++++++++++++++++++++++++++++++++---- gcc/ada/sem_util.adb | 64 ++++++++++++++++++++-------------------- 13 files changed, 267 insertions(+), 130 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4b39a4d8542..eb0f5ae046f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,45 @@ 2016-04-27 Hristian Kirtchev + * sem_res.adb (Flag_Effectively_Volatile_Objects): New routine. + (Resolve_Actuals): Flag effectively volatile objects with enabled + property Async_Writers or Effective_Reads as illegal. + * sem_util.adb (Is_OK_Volatile_Context): Comment reformatting. + +2016-04-27 Javier Miranda + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): + Do not generate the profile of the equality operator if it has + been explicitly defined as abstract in the parent type. Required + to avoid reporting an spurious error. + +2016-04-27 Ed Schonberg + + * sem_dim.ads, sem_dim.adb (Check_Expression_Dimensions): New + procedure to compute the dimension vector of a scalar expression + and compare it with the dimensions if its expected subtype. Used + for the ultimate components of a multidimensional aggregate, + whose components typically are themselves aggregates that are + expanded separately. Previous to this patch, dimensionality + checking on such aggregates generated spurious errors. + * sem_aggr.adb (Resolve_Array_Aggregate): Use + Check_Expression_Dimensions when needed. + +2016-04-27 Javier Miranda + + * einfo.ads, einfo.adb (Corresponding_Function): New attribute + (applicable to E_Procedure). + (Corresponding_Procedure): New attribute (applicable to E_Function). + * exp_util.adb (Build_Procedure_Form): Link the function with + its internally built proc and viceversa. + * sem_ch6.adb (Build_Subprogram_Declaration): Propagate the + attribute Rewritten_For_C and Corresponding_Procedure to the body. + * exp_ch6.adb (Rewritten_For_C_Func_Id): Removed. + (Rewritten_For_C_Proc_Id): Removed. + * exp_unst.adb (Note_Uplevel_Ref): Use the new attribute to + locate the corresponding procedure. + +2016-04-27 Hristian Kirtchev + * sem_ch13.adb (Analyze_Aspect_Export_Import): Signal that there is no corresponding pragma. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7172a2ac518..32a56a6f8f1 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -256,6 +256,8 @@ package body Einfo is -- Thunk_Entity Node31 -- Activation_Record_Component Node31 + -- Corresponding_Function Node32 + -- Corresponding_Procedure Node32 -- Encapsulating_State Node32 -- No_Tagged_Streams_Pragma Node32 @@ -915,6 +917,18 @@ package body Einfo is return Node30 (Id); end Corresponding_Equality; + function Corresponding_Function (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Node32 (Id); + end Corresponding_Function; + + function Corresponding_Procedure (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Function); + return Node32 (Id); + end Corresponding_Procedure; + function Corresponding_Protected_Entry (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Subprogram_Body); @@ -3919,6 +3933,22 @@ package body Einfo is Set_Node30 (Id, V); end Set_Corresponding_Equality; + procedure Set_Corresponding_Function (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Procedure + and then Rewritten_For_C (V)); + Set_Node32 (Id, V); + end Set_Corresponding_Function; + + procedure Set_Corresponding_Procedure (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Function + and then Rewritten_For_C (Id)); + Set_Node32 (Id, V); + end Set_Corresponding_Procedure; + procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Void, E_Subprogram_Body)); @@ -10276,6 +10306,12 @@ package body Einfo is E_Variable => Write_Str ("Encapsulating_State"); + when E_Function => + Write_Str ("Corresponding_Procedure"); + + when E_Procedure => + Write_Str ("Corresponding_Function"); + when Type_Kind => Write_Str ("No_Tagged_Streams_Pragma"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 84ce2e2cb24..e8cee391b5f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -738,6 +738,17 @@ package Einfo is -- other function entities, only in implicit inequality routines, -- where Comes_From_Source is always False. +-- Corresponding_Function (Node32) +-- Defined on procedures internally built with an extra out parameter +-- to return a constrained array type, when Modify_Tree_For_C is set. +-- Denotes the function that returns the constrained array type for +-- which this procedure was built. + +-- Corresponding_Procedure (Node32) +-- Defined on functions that return a constrained array type, when +-- Modify_Tree_For_C is set. Denotes the internally built procedure +-- with an extra out parameter created for it. + -- Corresponding_Protected_Entry (Node18) -- Defined in subprogram bodies. Set for subprogram bodies that implement -- a protected type entry to point to the entity for the entry. @@ -5888,6 +5899,7 @@ package Einfo is -- Subprograms_For_Type (Node29) -- Corresponding_Equality (Node30) (implicit /= only) -- Thunk_Entity (Node31) (thunk case only) + -- Corresponding_Procedure (Node32) (generate C code only) -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) @@ -5938,7 +5950,7 @@ package Einfo is -- Return_Present (Flag54) -- Returns_By_Ref (Flag90) -- Returns_Limited_View (Flag134) (non-generic case only) - -- Rewritten_For_C (Flag287) + -- Rewritten_For_C (Flag287) (generate C code only) -- Sec_Stack_Needed_For_Return (Flag167) -- SPARK_Pragma_Inherited (Flag265) -- Uses_Sec_Stack (Flag95) @@ -6201,6 +6213,7 @@ package Einfo is -- Extra_Formals (Node28) -- Static_Initialization (Node30) (init_proc only) -- Thunk_Entity (Node31) (thunk case only) + -- Corresponding_Function (Node32) (generate C code only) -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) @@ -6774,6 +6787,8 @@ package Einfo is function Corresponding_Concurrent_Type (Id : E) return E; function Corresponding_Discriminant (Id : E) return E; function Corresponding_Equality (Id : E) return E; + function Corresponding_Function (Id : E) return E; + function Corresponding_Procedure (Id : E) return E; function Corresponding_Protected_Entry (Id : E) return E; function Corresponding_Record_Type (Id : E) return E; function Corresponding_Remote_Type (Id : E) return E; @@ -7441,6 +7456,8 @@ package Einfo is procedure Set_Corresponding_Concurrent_Type (Id : E; V : E); procedure Set_Corresponding_Discriminant (Id : E; V : E); procedure Set_Corresponding_Equality (Id : E; V : E); + procedure Set_Corresponding_Function (Id : E; V : E); + procedure Set_Corresponding_Procedure (Id : E; V : E); procedure Set_Corresponding_Protected_Entry (Id : E; V : E); procedure Set_Corresponding_Record_Type (Id : E; V : E); procedure Set_Corresponding_Remote_Type (Id : E; V : E); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e76db7eeeb7..5f6e3cd9eb1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -9637,11 +9637,13 @@ package body Exp_Ch3 is exit; -- If the parent is not an interface type and has an abstract - -- equality function, the inherited equality is abstract as - -- well, and no body can be created for it. + -- equality function explicitly defined in the sources, then + -- the inherited equality is abstract as well, and no body can + -- be created for it. elsif not Is_Interface (Etype (Tag_Typ)) and then Present (Alias (Node (Prim))) + and then Comes_From_Source (Alias (Node (Prim))) and then Is_Abstract_Subprogram (Alias (Node (Prim))) then Eq_Needed := False; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 60c2ce034ea..1d3ab7d80df 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2502,47 +2502,9 @@ package body Exp_Ch6 is end if; end New_Value; - function Rewritten_For_C_Func_Id (Proc_Id : Entity_Id) return Entity_Id; - -- Given the Id of the procedure with an extra out parameter internally - -- built to handle functions that return a constrained array type return - -- the Id of the corresponding function. - - ----------------------------- - -- Rewritten_For_C_Func_Id -- - ----------------------------- - - function Rewritten_For_C_Func_Id (Proc_Id : Entity_Id) return Entity_Id - is - Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id); - Func_Decl : Node_Id; - Func_Id : Entity_Id; - - begin - pragma Assert (Rewritten_For_C (Proc_Id)); - pragma Assert (Nkind (Decl) = N_Subprogram_Body); - - Func_Decl := Nlists.Prev (Decl); - - while Present (Func_Decl) - and then - (Nkind (Func_Decl) = N_Freeze_Entity - or else - Nkind (Func_Decl) /= N_Subprogram_Declaration - or else - Nkind (Specification (Func_Decl)) /= N_Function_Specification) - loop - Func_Decl := Nlists.Prev (Func_Decl); - end loop; - - pragma Assert (Present (Func_Decl)); - Func_Id := Defining_Entity (Specification (Func_Decl)); - pragma Assert (Chars (Proc_Id) = Chars (Func_Id)); - return Func_Id; - end Rewritten_For_C_Func_Id; - -- Local variables - Remote : constant Boolean := Is_Remote_Call (Call_Node); + Remote : constant Boolean := Is_Remote_Call (Call_Node); Actual : Node_Id; Formal : Entity_Id; Orig_Subp : Entity_Id := Empty; @@ -2706,8 +2668,9 @@ package body Exp_Ch6 is N_Subprogram_Body then Set_Entity (Name (Call_Node), - Rewritten_For_C_Func_Id - (Ultimate_Alias (Entity (Name (Call_Node))))); + Corresponding_Function + (Corresponding_Procedure + (Ultimate_Alias (Entity (Name (Call_Node)))))); end if; Rewrite_Function_Call_For_C (Call_Node); @@ -8405,45 +8368,10 @@ package body Exp_Ch6 is --------------------------------- procedure Rewrite_Function_Call_For_C (N : Node_Id) is - function Rewritten_For_C_Proc_Id (Func_Id : Entity_Id) return Entity_Id; - -- Given the Id of the function that returns a constrained array type - -- return the Id of its internally built procedure with an extra out - -- parameter. - - ----------------------------- - -- Rewritten_For_C_Proc_Id -- - ----------------------------- - - function Rewritten_For_C_Proc_Id (Func_Id : Entity_Id) return Entity_Id - is - Func_Decl : constant Node_Id := Unit_Declaration_Node (Func_Id); - Proc_Decl : Node_Id; - Proc_Id : Entity_Id; - - begin - Proc_Decl := Next (Func_Decl); - - while Present (Proc_Decl) - and then - (Nkind (Proc_Decl) = N_Freeze_Entity - or else - Nkind (Proc_Decl) /= N_Subprogram_Declaration) - loop - Proc_Decl := Next (Proc_Decl); - end loop; - - pragma Assert (Present (Proc_Decl)); - Proc_Id := Defining_Entity (Proc_Decl); - pragma Assert (Chars (Proc_Id) = Chars (Func_Id)); - return Proc_Id; - end Rewritten_For_C_Proc_Id; - - -- Local variables - Orig_Func : constant Entity_Id := Entity (Name (N)); Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func); Par : constant Node_Id := Parent (N); - Proc_Id : constant Entity_Id := Rewritten_For_C_Proc_Id (Func_Id); + Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id); Loc : constant Source_Ptr := Sloc (Par); Actuals : List_Id; Last_Actual : Node_Id; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index d1475e7d1ea..302cc100834 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -507,7 +507,7 @@ package body Exp_Unst is elsif Ekind (Callee) = E_Function and then Rewritten_For_C (Callee) - and then Next_Entity (Callee) = Caller + and then Corresponding_Procedure (Callee) = Caller then return; end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7591c3afd27..fe0f5882f79 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -996,9 +996,12 @@ package body Exp_Util is Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False); - -- Mark the function as having a procedure form + -- Mark the function as having a procedure form and link the function + -- and its internally built procedure. Set_Rewritten_For_C (Subp); + Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl)); + Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp); end Build_Procedure_Form; ------------------------ diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 25022e95a9e..575a1d2ea3c 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -2052,6 +2052,13 @@ package body Sem_Aggr is Set_Parent (Expr, Parent (Expression (Assoc))); Analyze (Expr); + -- Compute its dimensions now, rather than at the end + -- of resolution, because in the case of multidimensional + -- aggregates subsequent expansion may lead to spurious + -- errors. + + Check_Expression_Dimensions (Expr, Component_Typ); + -- If the expression is a literal, propagate this info -- to the expression in the association, to enable some -- optimizations downstream. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a6f22b1744b..726c20ff3e8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2405,14 +2405,20 @@ package body Sem_Ch6 is Analyze (Subp_Decl); - -- Propagate the attribute Rewritten_For_C to the body since the - -- expander may generate calls using that entity. Required to ensure - -- that Expand_Call rewrites calls to this function by calls to the - -- built procedure. + -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to + -- the body since the expander may generate calls using that entity. + -- Required to ensure that Expand_Call rewrites calls to this + -- function by calls to the built procedure. - if Nkind (Body_Spec) = N_Function_Specification then - Set_Rewritten_For_C (Defining_Entity (Body_Spec), - Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))); + if Modify_Tree_For_C + and then Nkind (Body_Spec) = N_Function_Specification + and then + Rewritten_For_C (Defining_Entity (Specification (Subp_Decl))) + then + Set_Rewritten_For_C (Defining_Entity (Body_Spec)); + Set_Corresponding_Procedure (Defining_Entity (Body_Spec), + Corresponding_Procedure + (Defining_Entity (Specification (Subp_Decl)))); end if; -- Analyze any relocated source pragmas or pragmas created for aspect diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 50676987367..754be84ab0d 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2016, 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- -- @@ -1235,10 +1235,12 @@ package body Sem_Dim is -- since it may not be decorated at this point. We also don't want to -- issue the same error message multiple times on the same expression -- (may happen when an aggregate is converted into a positional - -- aggregate). + -- aggregate). We also must verify that this is a scalar component, + -- and not a subaggregate of a multidimensional aggregate. if Comes_From_Source (Original_Node (Expr)) and then Present (Etype (Expr)) + and then Is_Numeric_Type (Etype (Expr)) and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ and then Sloc (Comp) /= Sloc (Prev (Comp)) then @@ -2270,6 +2272,27 @@ package body Sem_Dim is end case; end Analyze_Dimension_Unary_Op; + --------------------------------- + -- Check_Expression_Dimensions -- + --------------------------------- + + procedure Check_Expression_Dimensions + (Expr : Node_Id; + Typ : Entity_Id) + is + begin + if Is_Floating_Point_Type (Etype (Expr)) then + Analyze_Dimension (Expr); + + if Dimensions_Of (Expr) /= Dimensions_Of (Typ) then + Error_Msg_N ("dimensions mismatch in array aggregate", Expr); + Error_Msg_N + ("\expected dimension " & Dimensions_Msg_Of (Typ) + & ", found " & Dimensions_Msg_Of (Expr), Expr); + end if; + end if; + end Check_Expression_Dimensions; + --------------------- -- Copy_Dimensions -- --------------------- diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index d1521e90826..bce497a5850 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2016, 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- -- @@ -164,6 +164,16 @@ package Sem_Dim is -- For sub spec N, issue a warning for each dimensioned formal with a -- literal default value in the list of formals Formals. + procedure Check_Expression_Dimensions + (Expr : Node_Id; + Typ : Entity_Id); + -- Compute dimensions of a floating-point expression and compare them + -- with the dimensions of a the given type. Used to verify dimensions + -- of the components of a multidimensional array type, for which components + -- are typically themselves arrays. The resolution of such arrays delays + -- the resolution of the ultimate components to a separate phase, which + -- forces this separate dimension verification. + procedure Copy_Dimensions (From, To : Node_Id); -- Copy dimension vector of node From to node To. Note that To must be a -- node that is allowed to contain a dimension (see OK_For_Dimension in diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c6effa379de..57a7fc9e539 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3107,6 +3107,10 @@ package body Sem_Res is -- interpretation, but the form of the actual can only be determined -- once the primitive operation is identified. + procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id); + -- Emit an error concerning the illegal usage of an effectively volatile + -- object in interfering context (SPARK RM 7.13(12)). + procedure Insert_Default; -- If the actual is missing in a call, insert in the actuals list -- an instance of the default expression. The insertion is always @@ -3360,6 +3364,55 @@ package body Sem_Res is end if; end Check_Prefixed_Call; + --------------------------------------- + -- Flag_Effectively_Volatile_Objects -- + --------------------------------------- + + procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id) is + function Flag_Object (N : Node_Id) return Traverse_Result; + -- Determine whether arbitrary node N denotes an effectively volatile + -- object and if it does, emit an error. + + ----------------- + -- Flag_Object -- + ----------------- + + function Flag_Object (N : Node_Id) return Traverse_Result is + Id : Entity_Id; + + begin + -- Do not consider nested function calls because they have already + -- been processed during their own resolution. + + if Nkind (N) = N_Function_Call then + return Skip; + + elsif Is_Entity_Name (N) and then Present (Entity (N)) then + Id := Entity (N); + + if Is_Object (Id) + and then Is_Effectively_Volatile (Id) + and then (Async_Writers_Enabled (Id) + or else Effective_Reads_Enabled (Id)) + then + Error_Msg_N + ("volatile object cannot appear in this context (SPARK " + & "RM 7.1.3(11))", N); + return Skip; + end if; + end if; + + return OK; + end Flag_Object; + + procedure Flag_Objects is new Traverse_Proc (Flag_Object); + + -- Start of processing for Flag_Effectively_Volatile_Objects + + begin + Flag_Objects (Expr); + end Flag_Effectively_Volatile_Objects; + -------------------- -- Insert_Default -- -------------------- @@ -3461,7 +3514,6 @@ package body Sem_Res is then Set_Is_Controlling_Actual (Actval); end if; - end if; -- If the default expression raises constraint error, then just @@ -4473,10 +4525,8 @@ package body Sem_Res is -- they are not standard Ada legality rule. Internally generated -- temporaries are ignored. - if SPARK_Mode = On - and then Comes_From_Source (A) - and then Is_Effectively_Volatile_Object (A) - then + if SPARK_Mode = On and then Comes_From_Source (A) then + -- An effectively volatile object may act as an actual when the -- corresponding formal is of a non-scalar effectively volatile -- type (SPARK RM 7.1.3(11)). @@ -4493,10 +4543,23 @@ package body Sem_Res is elsif Is_Unchecked_Conversion_Instance (Nam) then null; - else + -- The actual denotes an object + + elsif Is_Effectively_Volatile_Object (A) then Error_Msg_N ("volatile object cannot act as actual in a call (SPARK " & "RM 7.1.3(11))", A); + + -- Otherwise the actual denotes an expression. Inspect the + -- expression and flag each effectively volatile object with + -- enabled property Async_Writers or Effective_Reads as illegal + -- because it apprears within an interfering context. Note that + -- this is usually done in Resolve_Entity_Name, but when the + -- effectively volatile object appears as an actual in a call, + -- the call must be resolved first. + + else + Flag_Effectively_Volatile_Objects (A); end if; -- Detect an external variable with an enabled property that diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 46baf0bc882..b49c7888549 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9314,7 +9314,7 @@ package body Sem_Util is Has_Default_Aspect (Typ) or else Has_Full_Default_Initialization (Component_Type (Typ)); - -- A protected type, record type or type extension is fully default + -- A protected type, record type, or type extension is fully default -- initialized if all its components either carry an initialization -- expression or have a type that is fully default initialized. The -- parent type of a type extension must be fully default initialized. @@ -13159,7 +13159,7 @@ package body Sem_Util is when N_Function_Call => return Etype (N) /= Standard_Void_Type; - -- Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce + -- Attributes 'Input, 'Loop_Entry, 'Old, and 'Result produce -- objects. when N_Attribute_Reference => @@ -13346,14 +13346,15 @@ package body Sem_Util is is function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node denotes a call to a protected - -- entry, function or procedure in prefixed form where the prefix is + -- entry, function, or procedure in prefixed form where the prefix is -- Obj_Ref. function Within_Check (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node appears in a check node function Within_Subprogram_Call (Nod : Node_Id) return Boolean; - -- Determine whether an arbitrary node appears in a procedure call + -- Determine whether an arbitrary node appears in an entry, function, or + -- procedure call. function Within_Volatile_Function (Id : Entity_Id) return Boolean; -- Determine whether an arbitrary entity appears in a volatile function @@ -13405,7 +13406,7 @@ package body Sem_Util is if Nkind (Par) in N_Raise_xxx_Error then return True; - -- Prevent the search from going too far + -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then exit; @@ -13435,7 +13436,7 @@ package body Sem_Util is then return True; - -- Prevent the search from going too far + -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then exit; @@ -13481,8 +13482,8 @@ package body Sem_Util is if Nkind (Context) = N_Assignment_Statement then return True; - -- The volatile object is part of the initialization expression of - -- another object. + -- The volatile object is part of the initialization expression of + -- another object. elsif Nkind (Context) = N_Object_Declaration and then Present (Expression (Context)) @@ -13497,21 +13498,21 @@ package body Sem_Util is if Is_Return_Object (Obj_Id) then return Within_Volatile_Function (Obj_Id); - -- Otherwise this is a normal object initialization + -- Otherwise this is a normal object initialization else return True; end if; - -- The volatile object acts as the name of a renaming declaration + -- The volatile object acts as the name of a renaming declaration elsif Nkind (Context) = N_Object_Renaming_Declaration and then Name (Context) = Obj_Ref then return True; - -- The volatile object appears as an actual parameter in a call to an - -- instance of Unchecked_Conversion whose result is renamed. + -- The volatile object appears as an actual parameter in a call to an + -- instance of Unchecked_Conversion whose result is renamed. elsif Nkind (Context) = N_Function_Call and then Is_Entity_Name (Name (Context)) @@ -13520,14 +13521,14 @@ package body Sem_Util is then return True; - -- The volatile object is actually the prefix in a protected entry, - -- function, or procedure call. + -- The volatile object is actually the prefix in a protected entry, + -- function, or procedure call. elsif Is_Protected_Operation_Call (Context) then return True; - -- The volatile object appears as the expression of a simple return - -- statement that applies to a volatile function. + -- The volatile object appears as the expression of a simple return + -- statement that applies to a volatile function. elsif Nkind (Context) = N_Simple_Return_Statement and then Expression (Context) = Obj_Ref @@ -13535,8 +13536,8 @@ package body Sem_Util is return Within_Volatile_Function (Return_Statement_Entity (Context)); - -- The volatile object appears as the prefix of a name occurring in a - -- non-interfering context. + -- The volatile object appears as the prefix of a name occurring in a + -- non-interfering context. elsif Nkind_In (Context, N_Attribute_Reference, N_Explicit_Dereference, @@ -13550,8 +13551,8 @@ package body Sem_Util is then return True; - -- The volatile object appears as the expression of a type conversion - -- occurring in a non-interfering context. + -- The volatile object appears as the expression of a type conversion + -- occurring in a non-interfering context. elsif Nkind_In (Context, N_Type_Conversion, N_Unchecked_Type_Conversion) @@ -13562,21 +13563,22 @@ package body Sem_Util is then return True; - -- Allow references to volatile objects in various checks. This is - -- not a direct SPARK 2014 requirement. + -- Allow references to volatile objects in various checks. This is not a + -- direct SPARK 2014 requirement. elsif Within_Check (Context) then return True; - -- Assume that references to effectively volatile objects that appear - -- as actual parameters in a subprogram call are always legal. A full - -- legality check is done when the actuals are resolved. + -- Assume that references to effectively volatile objects that appear + -- as actual parameters in a subprogram call are always legal. A full + -- legality check is done when the actuals are resolved (see routine + -- Resolve_Actuals). elsif Within_Subprogram_Call (Context) then return True; - -- Otherwise the context is not suitable for an effectively volatile - -- object. + -- Otherwise the context is not suitable for an effectively volatile + -- object. else return False; @@ -13888,7 +13890,7 @@ package body Sem_Util is begin -- Verify that prefix is analyzed and has the proper form. Note that - -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also + -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also -- produce the address of an entity, do not analyze their prefix -- because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. @@ -16034,7 +16036,7 @@ package body Sem_Util is procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is begin - -- Translate Next_Entity, Scope and Etype fields, in case they + -- Translate Next_Entity, Scope, and Etype fields, in case they -- reference entities that have been mapped into copies. Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype))); @@ -19986,8 +19988,8 @@ package body Sem_Util is return False; end if; - -- Check that the size of the component is 8, 16, 32 or 64 bits and that - -- Typ is properly aligned. + -- Check that the size of the component is 8, 16, 32, or 64 bits and + -- that Typ is properly aligned. case Size is when 8 | 16 | 32 | 64 => -- 2.11.4.GIT