From 2eda24e95cb9232031a0b7e0be3ca109cfd86a2d Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Mon, 18 Sep 2017 09:52:11 +0000 Subject: [PATCH] sem_ch4.adb (Complete_Object_Operation): Do not insert 'Access for reference types in the access-to-access case. gcc/ada/ 2017-09-18 Bob Duff * sem_ch4.adb (Complete_Object_Operation): Do not insert 'Access for reference types in the access-to-access case. 2017-09-18 Eric Botcazou * sem_attr.adb (Analyze_Access_Attribute): Move check for the presence of the "aliased" keyword on the prefix from here to... (Resolve_Attribute) : ...here. Remove useless call to Check_No_Implicit_Aliasing. * sinfo.ads (Non_Aliased_Prefix): Delete. (Set_Non_Aliased_Prefix): Likewise. * sinfo.adb (Non_Aliased_Prefix): Delete. (Set_Non_Aliased_Prefix): Likewise. 2017-09-18 Bob Duff * exp_ch5.adb (Build_Formal_Container_Iteration, Expand_Formal_Container_Element_Loop): Convert the container to the root type before passing it to the iteration operations, so it will be of the right type. 2017-09-18 Bob Duff * einfo.ads, validsw.ads, treepr.ads, sem_util.ads: Comment fixes. 2017-09-18 Bob Duff * exp_ch3.adb (Build_Array_Init_Proc): If validity checking is enabled, and it's a bit-packed array, pass False to the Consider_IS parameter of Needs_Simple_Initialization. 2017-09-18 Hristian Kirtchev * sem_ch6.adb (Check_Inline_Pragma): Link the newly generated spec to the preexisting body. * sem_prag.adb (Check_Inline_Always_Placement): New routine. (Process_Inline): Verify the placement of pragma Inline_Always. The pragma must now appear on the initial declaration of the related subprogram. 2017-09-18 Ed Schonberg * sem_ch3.adb (Analyze_Declarations): In ASIS mode, At the end of the declarative list in a subprogram body, analyze aspext specifications to provide basic semantic information, because otherwise the aspect specifications might only be snalyzed during expansion, when related subprograms are generated. 2017-09-18 Bob Duff * exp_ch9.adb (Is_Simple_Barrier_Name): Follow Original_Node, in case validity checks have rewritten the tree. 2017-09-18 Bob Duff * sem_util.adb: Comment fixes, and remove redundant Is_Itype check. 2017-09-18 Ed Schonberg * sem_ch12.adb (Save_References_In_Aggregate): When constructing a qualified exxpression for an aggregate in a generic unit, verify that the scope of the type is itself visible and not hidden, so that the qualified expression is correctly resolved in any instance. gcc/testsuite/ 2017-09-18 Bob Duff * gnat.dg/validity_check.adb: New testcase. 2017-09-18 Eric Botcazou * gnat.dg/overload.ads, gnat.dg/overload.adb: New testcase. 2017-09-18 Bob Duff * gnat.dg/tagged_prefix_call.adb: New testcase. From-SVN: r252916 --- gcc/ada/ChangeLog | 66 +++++ gcc/ada/einfo.ads | 2 +- gcc/ada/exp_ch3.adb | 10 +- gcc/ada/exp_ch5.adb | 43 ++- gcc/ada/exp_ch9.adb | 8 +- gcc/ada/sem_attr.adb | 109 ++++---- gcc/ada/sem_ch12.adb | 12 +- gcc/ada/sem_ch3.adb | 11 + gcc/ada/sem_ch4.adb | 15 +- gcc/ada/sem_ch6.adb | 5 + gcc/ada/sem_prag.adb | 263 +++++++++++++++++-- gcc/ada/sem_util.adb | 14 +- gcc/ada/sem_util.ads | 2 +- gcc/ada/sinfo.adb | 18 +- gcc/ada/sinfo.ads | 16 -- gcc/ada/treepr.ads | 4 +- gcc/ada/validsw.ads | 4 +- gcc/testsuite/ChangeLog | 12 + gcc/testsuite/gnat.dg/overload.adb | 23 ++ gcc/testsuite/gnat.dg/overload.ads | 20 ++ gcc/testsuite/gnat.dg/tagged_prefix_call.adb | 24 ++ gcc/testsuite/gnat.dg/validity_check.adb | 18 ++ 22 files changed, 545 insertions(+), 154 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/overload.adb create mode 100644 gcc/testsuite/gnat.dg/overload.ads create mode 100644 gcc/testsuite/gnat.dg/tagged_prefix_call.adb create mode 100644 gcc/testsuite/gnat.dg/validity_check.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5dba677203f..b90a2623342 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,69 @@ +2017-09-18 Bob Duff + + * sem_ch4.adb (Complete_Object_Operation): Do not insert 'Access for + reference types in the access-to-access case. + +2017-09-18 Eric Botcazou + + * sem_attr.adb (Analyze_Access_Attribute): Move check for the presence + of the "aliased" keyword on the prefix from here to... + (Resolve_Attribute) : ...here. Remove useless call + to Check_No_Implicit_Aliasing. + * sinfo.ads (Non_Aliased_Prefix): Delete. + (Set_Non_Aliased_Prefix): Likewise. + * sinfo.adb (Non_Aliased_Prefix): Delete. + (Set_Non_Aliased_Prefix): Likewise. + +2017-09-18 Bob Duff + + * exp_ch5.adb (Build_Formal_Container_Iteration, + Expand_Formal_Container_Element_Loop): Convert the container to the + root type before passing it to the iteration operations, so it will be + of the right type. + +2017-09-18 Bob Duff + + * einfo.ads, validsw.ads, treepr.ads, sem_util.ads: Comment fixes. + +2017-09-18 Bob Duff + + * exp_ch3.adb (Build_Array_Init_Proc): If validity checking is enabled, + and it's a bit-packed array, pass False to the Consider_IS parameter of + Needs_Simple_Initialization. + +2017-09-18 Hristian Kirtchev + + * sem_ch6.adb (Check_Inline_Pragma): Link the newly generated spec to + the preexisting body. + * sem_prag.adb (Check_Inline_Always_Placement): New routine. + (Process_Inline): Verify the placement of pragma Inline_Always. The + pragma must now appear on the initial declaration of the related + subprogram. + +2017-09-18 Ed Schonberg + + * sem_ch3.adb (Analyze_Declarations): In ASIS mode, At the end of the + declarative list in a subprogram body, analyze aspext specifications to + provide basic semantic information, because otherwise the aspect + specifications might only be snalyzed during expansion, when related + subprograms are generated. + +2017-09-18 Bob Duff + + * exp_ch9.adb (Is_Simple_Barrier_Name): Follow Original_Node, in case + validity checks have rewritten the tree. + +2017-09-18 Bob Duff + + * sem_util.adb: Comment fixes, and remove redundant Is_Itype check. + +2017-09-18 Ed Schonberg + + * sem_ch12.adb (Save_References_In_Aggregate): When constructing a + qualified exxpression for an aggregate in a generic unit, verify that + the scope of the type is itself visible and not hidden, so that the + qualified expression is correctly resolved in any instance. + 2017-09-18 Bob Duff * sem_ch4.adb (Analyze_Qualified_Expression): Give an error if the type diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 22a8b737fec..13bf62019d7 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -323,7 +323,7 @@ package Einfo is -- only]. These are representation attributes which must always apply to a -- full non-private type, and where the attributes are always on the full -- type. The attribute can be referenced on a subtype (and automatically --- retries the value from the implementation base type). However, it is an +-- retrieves the value from the implementation base type). However, it is an -- error to try to set the attribute on other than the implementation base -- type, and if assertions are enabled, an attempt to set the attribute on a -- subtype will raise an assert error. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0fcf7235eee..6e90fb686a7 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -517,6 +517,10 @@ package body Exp_Ch3 is procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is Comp_Type : constant Entity_Id := Component_Type (A_Type); + Comp_Type_Simple : constant Boolean := + Needs_Simple_Initialization + (Comp_Type, Consider_IS => + not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type))); Body_Stmts : List_Id; Has_Default_Init : Boolean; Index_List : List_Id; @@ -557,7 +561,7 @@ package body Exp_Ch3 is Convert_To (Comp_Type, Default_Aspect_Component_Value (First_Subtype (A_Type))))); - elsif Needs_Simple_Initialization (Comp_Type) then + elsif Comp_Type_Simple then Set_Assignment_OK (Comp); return New_List ( Make_Assignment_Statement (Loc, @@ -589,7 +593,7 @@ package body Exp_Ch3 is -- the dummy Init_Proc needed for Initialize_Scalars processing. if not Has_Non_Null_Base_Init_Proc (Comp_Type) - and then not Needs_Simple_Initialization (Comp_Type) + and then not Comp_Type_Simple and then not Has_Task (Comp_Type) and then not Has_Default_Aspect (A_Type) then @@ -679,7 +683,7 @@ package body Exp_Ch3 is -- init_proc. Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) - or else Needs_Simple_Initialization (Comp_Type) + or else Comp_Type_Simple or else Has_Task (Comp_Type) or else Has_Default_Aspect (A_Type); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index d8d22d02af9..e682bfd0fb4 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -74,6 +74,12 @@ package body Exp_Ch5 is -- Utility to create declarations and loop statement for both forms -- of formal container iterators. + function Convert_To_Iterable_Type + (Container : Entity_Id; Loc : Source_Ptr) return Node_Id; + -- Returns New_Occurrence_Of (Container), possibly converted to an + -- ancestor type, if the type of Container inherited the Iterable + -- aspect_specification from that ancestor. + function Change_Of_Representation (N : Node_Id) return Boolean; -- Determine if the right-hand side of assignment N is a type conversion -- which requires a change of representation. Called only for the array @@ -189,7 +195,7 @@ package body Exp_Ch5 is Make_Function_Call (Loc, Name => New_Occurrence_Of (First_Op, Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Container, Loc)))); + Convert_To_Iterable_Type (Container, Loc)))); -- Statement that advances cursor in loop @@ -200,7 +206,7 @@ package body Exp_Ch5 is Make_Function_Call (Loc, Name => New_Occurrence_Of (Next_Op, Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Container, Loc), + Convert_To_Iterable_Type (Container, Loc), New_Occurrence_Of (Cursor, Loc)))); -- Iterator is rewritten as a while_loop @@ -211,13 +217,12 @@ package body Exp_Ch5 is Make_Iteration_Scheme (Loc, Condition => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Has_Element_Op, Loc), + Name => New_Occurrence_Of (Has_Element_Op, Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Container, Loc), + Convert_To_Iterable_Type (Container, Loc), New_Occurrence_Of (Cursor, Loc)))), - Statements => Stats, - End_Label => Empty); + Statements => Stats, + End_Label => Empty); end Build_Formal_Container_Iteration; ------------------------------ @@ -233,6 +238,26 @@ package body Exp_Ch5 is not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); end Change_Of_Representation; + ------------------------------ + -- Convert_To_Iterable_Type -- + ------------------------------ + + function Convert_To_Iterable_Type + (Container : Entity_Id; Loc : Source_Ptr) return Node_Id + is + Typ : constant Entity_Id := Base_Type (Etype (Container)); + Aspect : constant Node_Id := Find_Aspect (Typ, Aspect_Iterable); + Result : Node_Id := New_Occurrence_Of (Container, Loc); + begin + if Entity (Aspect) /= Typ then + Result := Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Aspect), Loc), + Expression => Result); + end if; + + return Result; + end Convert_To_Iterable_Type; + ------------------------- -- Expand_Assign_Array -- ------------------------- @@ -3207,7 +3232,7 @@ package body Exp_Ch5 is Make_Function_Call (Loc, Name => New_Occurrence_Of (Element_Op, Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Container, Loc), + Convert_To_Iterable_Type (Container, Loc), New_Occurrence_Of (Cursor, Loc)))); Set_Statements (New_Loop, @@ -3226,7 +3251,7 @@ package body Exp_Ch5 is Make_Function_Call (Loc, Name => New_Occurrence_Of (Element_Op, Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Container, Loc), + Convert_To_Iterable_Type (Container, Loc), New_Occurrence_Of (Cursor, Loc)))); Prepend (Elmt_Ref, Stats); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 64bc84a9151..0cd4fde15b1 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6000,11 +6000,13 @@ package body Exp_Ch9 is begin -- Check if the name is a component of the protected object. If - -- the expander is active, the component has been transformed into - -- a renaming of _object.all.component. + -- the expander is active, the component has been transformed into a + -- renaming of _object.all.component. Original_Node is needed in case + -- validity checking is enabled, in which case the simple object + -- reference will have been rewritten. if Expander_Active then - Renamed := Renamed_Object (Entity (N)); + Renamed := Renamed_Object (Entity (Original_Node (N))); return Present (Renamed) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 641ac87eb9b..9500b1a5a18 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1074,49 +1074,6 @@ package body Sem_Attr is end if; end loop; end; - - -- Check for aliased view. We allow a nonaliased prefix when within - -- an instance because the prefix may have been a tagged formal - -- object, which is defined to be aliased even when the actual - -- might not be (other instance cases will have been caught in the - -- generic). Similarly, within an inlined body we know that the - -- attribute is legal in the original subprogram, and therefore - -- legal in the expansion. - - if not Is_Aliased_View (P) - and then not In_Instance - and then not In_Inlined_Body - and then Comes_From_Source (N) - then - -- Here we have a non-aliased view. This is illegal unless we - -- have the case of Unrestricted_Access, where for now we allow - -- this (we will reject later if expected type is access to an - -- unconstrained array with a thin pointer). - - -- No need for an error message on a generated access reference - -- for the controlling argument in a dispatching call: error will - -- be reported when resolving the call. - - if Aname /= Name_Unrestricted_Access then - Error_Attr_P ("prefix of % attribute must be aliased"); - Check_No_Implicit_Aliasing (P); - - -- For Unrestricted_Access, record that prefix is not aliased - -- to simplify legality check later on. - - else - Set_Non_Aliased_Prefix (N); - end if; - - -- If we have an aliased view, and we have Unrestricted_Access, then - -- output a warning that Unchecked_Access would have been fine, and - -- change the node to be Unchecked_Access. - - else - -- For now, hold off on this change ??? - - null; - end if; end Analyze_Access_Attribute; ---------------------------------- @@ -11120,24 +11077,56 @@ package body Sem_Attr is end if; end if; - -- Check for unrestricted access where expected type is a thin - -- pointer to an unconstrained array. - - if Non_Aliased_Prefix (N) - and then Has_Size_Clause (Typ) - and then RM_Size (Typ) = System_Address_Size + -- Check for aliased view. We allow a nonaliased prefix when in + -- an instance because the prefix may have been a tagged formal + -- object, which is defined to be aliased even when the actual + -- might not be (other instance cases will have been caught in + -- the generic). Similarly, within an inlined body we know that + -- the attribute is legal in the original subprogram, therefore + -- legal in the expansion. + + if not (Is_Entity_Name (P) + and then Is_Overloadable (Entity (P))) + and then not (Nkind (P) = N_Selected_Component + and then + Is_Overloadable (Entity (Selector_Name (P)))) + and then not Is_Aliased_View (P) + and then not In_Instance + and then not In_Inlined_Body + and then Comes_From_Source (N) then - declare - DT : constant Entity_Id := Designated_Type (Typ); - begin - if Is_Array_Type (DT) and then not Is_Constrained (DT) then - Error_Msg_N - ("illegal use of Unrestricted_Access attribute", P); - Error_Msg_N - ("\attempt to generate thin pointer to unaliased " - & "object", P); - end if; - end; + -- Here we have a non-aliased view. This is illegal unless we + -- have the case of Unrestricted_Access, where for now we allow + -- this (we will reject later if expected type is access to an + -- unconstrained array with a thin pointer). + + -- No need for an error message on a generated access reference + -- for the controlling argument in a dispatching call: error + -- will be reported when resolving the call. + + if Attr_Id /= Attribute_Unrestricted_Access then + Error_Msg_N ("prefix of % attribute must be aliased", P); + + -- Check for unrestricted access where expected type is a thin + -- pointer to an unconstrained array. + + elsif Has_Size_Clause (Typ) + and then RM_Size (Typ) = System_Address_Size + then + declare + DT : constant Entity_Id := Designated_Type (Typ); + begin + if Is_Array_Type (DT) + and then not Is_Constrained (DT) + then + Error_Msg_N + ("illegal use of Unrestricted_Access attribute", P); + Error_Msg_N + ("\attempt to generate thin pointer to unaliased " + & "object", P); + end if; + end; + end if; end if; -- Mark that address of entity is taken in case of diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 86d2808c170..058809e78b4 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -15118,10 +15118,10 @@ package body Sem_Ch12 is -- preserved. In order to preserve some of this information, -- wrap the aggregate in a qualified expression, using the id -- of its type. For further disambiguation we qualify the type - -- name with its scope (if visible) because both id's will have - -- corresponding entities in an instance. This resolves most of - -- the problems with missing type information on aggregates in - -- instances. + -- name with its scope (if visible and not hidden by a local + -- homograph) because both id's will have corresponding + -- entities in an instance. This resolves most of the problems + -- with missing type information on aggregates in instances. if Present (N2) and then Nkind (N2) = Nkind (N) @@ -15131,7 +15131,9 @@ package body Sem_Ch12 is then Nam := Make_Identifier (Loc, Chars (Typ)); - if Is_Immediately_Visible (Scope (Typ)) then + if Is_Immediately_Visible (Scope (Typ)) + and then Current_Entity (Scope (Typ)) = Scope (Typ) + then Nam := Make_Selected_Component (Loc, Prefix => diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 803ff81c24a..2d9cacaebf0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2666,6 +2666,16 @@ package body Sem_Ch3 is Freeze_From := Last_Entity (Current_Scope); else + -- For declarations in a subprogram body there is no issue + -- with name resolution in aspect specifications, but in + -- ASIS mode we need to preanalyze aspect specifications + -- that may otherwise only be analyzed during expansion + -- (e.g. during generation of a related subprogram). + + if ASIS_Mode then + Resolve_Aspects; + end if; + Freeze_All (First_Entity (Current_Scope), Decl); Freeze_From := Last_Entity (Current_Scope); end if; @@ -13510,6 +13520,7 @@ package body Sem_Ch3 is end if; Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + Set_First_Private_Entity (Def_Id, First_Private_Entity (T_Ent)); Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); Set_Corresponding_Record_Type (Def_Id, diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 01f5f5e7732..555217c2f16 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -8554,14 +8554,21 @@ package body Sem_Ch4 is ("expect variable in call to&", Prefix (N), Entity (Subprog)); end if; - -- Conversely, if the formal is an access parameter and the object - -- is not, replace the actual with a 'Access reference. Its analysis - -- will check that the object is aliased. + -- Conversely, if the formal is an access parameter and the object is + -- not an access type or a reference type (i.e. a type with the + -- Implicit_Dereference aspect specified), replace the actual with a + -- 'Access reference. Its analysis will check that the object is + -- aliased. elsif Is_Access_Type (Formal_Type) and then not Is_Access_Type (Etype (Obj)) + and then (not Has_Implicit_Dereference (Etype (Obj)) + or else + not Is_Access_Type + (Designated_Type + (Etype (Get_Reference_Discriminant (Etype (Obj)))))) then - -- A special case: A.all'access is illegal if A is an access to a + -- A special case: A.all'Access is illegal if A is an access to a -- constant and the context requires an access to a variable. if not Is_Access_Constant (Formal_Type) then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5ca3584cf3f..468c112d01e 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2882,6 +2882,11 @@ package body Sem_Ch6 is New_Copy_Tree (Specification (N))); begin + -- Link the body and the generated spec + + Set_Corresponding_Body (Decl, Body_Id); + Set_Corresponding_Spec (N, Subp); + Set_Defining_Unit_Name (Specification (Decl), Subp); -- To ensure proper coverage when body is inlined, indicate diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 69338d4d29b..417de9267df 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9097,14 +9097,9 @@ package body Sem_Prag is -- The entity of the first Ghost subprogram encountered while -- processing the arguments of the pragma. - procedure Make_Inline (Subp : Entity_Id); - -- Subp is the defining unit name of the subprogram declaration. If - -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on - -- the corresponding body, if there is one present. - - procedure Set_Inline_Flags (Subp : Entity_Id); - -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp. - -- Also set or clear Is_Inlined flag on Subp depending on Status. + procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id); + -- Verify the placement of pragma Inline_Always with respect to the + -- initial declaration of subprogram Spec_Id. function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; -- Returns True if it can be determined at this stage that inlining @@ -9116,6 +9111,222 @@ package body Sem_Prag is -- ??? is business with link symbols still valid, or does it relate -- to front end ZCX which is being phased out ??? + procedure Make_Inline (Subp : Entity_Id); + -- Subp is the defining unit name of the subprogram declaration. If + -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on + -- the corresponding body, if there is one present. + + procedure Set_Inline_Flags (Subp : Entity_Id); + -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp. + -- Also set or clear Is_Inlined flag on Subp depending on Status. + + ----------------------------------- + -- Check_Inline_Always_Placement -- + ----------------------------------- + + procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is + Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + + function Compilation_Unit_OK return Boolean; + pragma Inline (Compilation_Unit_OK); + -- Determine whether pragma Inline_Always applies to a compatible + -- compilation unit denoted by Spec_Id. + + function Declarative_List_OK return Boolean; + pragma Inline (Declarative_List_OK); + -- Determine whether the initial declaration of subprogram Spec_Id + -- and the pragma appear in compatible declarative lists. + + function Subprogram_Body_OK return Boolean; + pragma Inline (Subprogram_Body_OK); + -- Determine whether pragma Inline_Always applies to a compatible + -- subprogram body denoted by Spec_Id. + + ------------------------- + -- Compilation_Unit_OK -- + ------------------------- + + function Compilation_Unit_OK return Boolean is + Comp_Unit : constant Node_Id := Parent (Spec_Decl); + + begin + -- The pragma appears after the initial declaration of a + -- compilation unit. + + -- procedure Comp_Unit; + -- pragma Inline_Always (Comp_Unit); + + -- Note that for compatibility reasons, the following case is + -- also accepted. + + -- procedure Stand_Alone_Body_Comp_Unit is + -- ... + -- end Stand_Alone_Body_Comp_Unit; + -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit); + + return + Nkind (Comp_Unit) = N_Compilation_Unit + and then Present (Aux_Decls_Node (Comp_Unit)) + and then Is_List_Member (N) + and then List_Containing (N) = + Pragmas_After (Aux_Decls_Node (Comp_Unit)); + end Compilation_Unit_OK; + + ------------------------- + -- Declarative_List_OK -- + ------------------------- + + function Declarative_List_OK return Boolean is + Context : constant Node_Id := Parent (Spec_Decl); + + Init_Decl : Node_Id; + Init_List : List_Id; + Prag_List : List_Id; + + begin + -- Determine the proper initial declaration. In general this is + -- the declaration node of the subprogram except when the input + -- denotes a generic instantiation. + + -- procedure Inst is new Gen; + -- pragma Inline_Always (Inst); + + -- In this case the original subprogram is moved inside an + -- anonymous package while pragma Inline_Always remains at the + -- level of the anonymous package. Use the declaration of the + -- package because it reflects the placement of the original + -- instantiation. + + -- package Anon_Pack is + -- procedure Inst is ... end Inst; -- original + -- end Anon_Pack; + + -- procedure Inst renames Anon_Pack.Inst; + -- pragma Inline_Always (Inst); + + if Is_Generic_Instance (Spec_Id) then + Init_Decl := Parent (Parent (Spec_Decl)); + pragma Assert (Nkind (Init_Decl) = N_Package_Declaration); + else + Init_Decl := Spec_Decl; + end if; + + if Is_List_Member (Init_Decl) and then Is_List_Member (N) then + Init_List := List_Containing (Init_Decl); + Prag_List := List_Containing (N); + + -- The pragma and then initial declaration appear within the + -- same declarative list. + + if Init_List = Prag_List then + return True; + + -- A special case of the above is when both the pragma and + -- the initial declaration appear in different lists of a + -- package spec, protected definition, or a task definition. + + -- package Pack is + -- procedure Proc; + -- private + -- pragma Inline_Always (Proc); + -- end Pack; + + elsif Nkind_In (Context, N_Package_Specification, + N_Protected_Definition, + N_Task_Definition) + and then Init_List = Visible_Declarations (Context) + and then Prag_List = Private_Declarations (Context) + then + return True; + end if; + end if; + + return False; + end Declarative_List_OK; + + ------------------------ + -- Subprogram_Body_OK -- + ------------------------ + + function Subprogram_Body_OK return Boolean is + Body_Decl : Node_Id; + + begin + -- The pragma appears within the declarative list of a stand- + -- alone subprogram body. + + -- procedure Stand_Alone_Body is + -- pragma Inline_Always (Stand_Alone_Body); + -- begin + -- ... + -- end Stand_Alone_Body; + + -- The compiler creates a dummy spec in this case, however the + -- pragma remains within the declarative list of the body. + + if Nkind (Spec_Decl) = N_Subprogram_Declaration + and then not Comes_From_Source (Spec_Decl) + and then Present (Corresponding_Body (Spec_Decl)) + then + Body_Decl := + Unit_Declaration_Node (Corresponding_Body (Spec_Decl)); + + if Present (Declarations (Body_Decl)) + and then Is_List_Member (N) + and then List_Containing (N) = Declarations (Body_Decl) + then + return True; + end if; + end if; + + return False; + end Subprogram_Body_OK; + + -- Start of processing for Check_Inline_Always_Placement + + begin + -- This check is relevant only for pragma Inline_Always + + if Pname /= Name_Inline_Always then + return; + + -- Nothing to do when the pragma is internally generated on the + -- assumption that it is properly placed. + + elsif not Comes_From_Source (N) then + return; + + -- Nothing to do for internally generated subprograms that act + -- as accidental homonyms of a source subprogram being inlined. + + elsif not Comes_From_Source (Spec_Id) then + return; + + -- Nothing to do for generic formal subprograms that act as + -- homonyms of another source subprogram being inlined. + + elsif Is_Formal_Subprogram (Spec_Id) then + return; + + elsif Compilation_Unit_OK + or else Declarative_List_OK + or else Subprogram_Body_OK + then + return; + end if; + + -- At this point it is known that the pragma applies to or appears + -- within a completing body, a completing stub, or a subunit. + + Error_Msg_Name_1 := Pname; + Error_Msg_Name_2 := Chars (Spec_Id); + Error_Msg_Sloc := Sloc (Spec_Id); + + Error_Msg_N + ("pragma % must appear on initial declaration of subprogram " + & "% defined #", N); + end Check_Inline_Always_Placement; + --------------------------- -- Inlining_Not_Possible -- --------------------------- @@ -9236,6 +9447,12 @@ package body Sem_Prag is -- retrieve it as the alias of the visible subprogram instance. if Is_Subprogram (Subp) then + + -- Ensure that pragma Inline_Always is associated with the + -- initial declaration of the subprogram. + + Check_Inline_Always_Placement (Subp); + if Is_Wrapper_Package (Scope (Subp)) then Inner_Subp := Subp; else @@ -13662,8 +13879,8 @@ package body Sem_Prag is -- related subprogram [body] when it is: -- aspect on subprogram declaration - -- aspect on stand alone subprogram body - -- pragma on stand alone subprogram body + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body -- The annotation must prepare its own template when it is: @@ -14523,8 +14740,8 @@ package body Sem_Prag is -- related subprogram [body] when it is: -- aspect on subprogram declaration - -- aspect on stand alone subprogram body - -- pragma on stand alone subprogram body + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body -- The annotation must prepare its own template when it is: @@ -15463,8 +15680,8 @@ package body Sem_Prag is -- related subprogram [body] when it is: -- aspect on subprogram declaration - -- aspect on stand alone subprogram body - -- pragma on stand alone subprogram body + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body -- The annotation must prepare its own template when it is: @@ -15906,7 +16123,7 @@ package body Sem_Prag is then Id := Defining_Entity (Context); - -- Pragma Ghost applies to a stand alone subprogram body + -- Pragma Ghost applies to a stand-alone subprogram body elsif Nkind (Context) = N_Subprogram_Body and then No (Corresponding_Spec (Context)) @@ -16050,8 +16267,8 @@ package body Sem_Prag is -- related subprogram [body] when it is: -- aspect on subprogram declaration - -- aspect on stand alone subprogram body - -- pragma on stand alone subprogram body + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body -- The annotation must prepare its own template when it is: @@ -19828,8 +20045,8 @@ package body Sem_Prag is -- related subprogram [body] when it is: -- aspect on subprogram declaration - -- aspect on stand alone subprogram body - -- pragma on stand alone subprogram body + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body -- The annotation must prepare its own template when it is: @@ -19875,8 +20092,8 @@ package body Sem_Prag is -- related subprogram [body] when it is: -- aspect on subprogram declaration - -- aspect on stand alone subprogram body - -- pragma on stand alone subprogram body + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body -- The annotation must prepare its own template when it is: @@ -21859,7 +22076,7 @@ package body Sem_Prag is if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then - -- A stand alone subprogram body + -- A stand-alone subprogram body if Body_Id = Spec_Id then Check_Pragma_Conformance @@ -28644,7 +28861,7 @@ package body Sem_Prag is Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends); Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); - -- Subprogram declaration or stand alone body case, look for pragmas + -- Subprogram declaration or stand-alone body case, look for pragmas -- Depends and Global else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 69819ed3340..0b731125c7a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -22049,14 +22049,14 @@ package body Sem_Util is end if; end if; - -- If E is an object or component, and the type of E is an anonymous - -- access type with no convention set, then also set the convention of - -- the anonymous access type. We do not do this for anonymous protected - -- types, since protected types always have the default convention. + -- If E is an object, including a component, and the type of E is an + -- anonymous access type with no convention set, then also set the + -- convention of the anonymous access type. We do not do this for + -- anonymous protected types, since protected types always have the + -- default convention. if Present (Etype (E)) and then (Is_Object (E) - or else Ekind (E) = E_Component -- Allow E_Void (happens for pragma Convention appearing -- in the middle of a record applying to a component) @@ -22075,15 +22075,13 @@ package body Sem_Util is Set_Has_Convention_Pragma (Typ); -- And for the access subprogram type, deal similarly with the - -- designated E_Subprogram_Type if it is also internal (which - -- it always is?) + -- designated E_Subprogram_Type, which is always internal. if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then declare Dtype : constant Entity_Id := Designated_Type (Typ); begin if Ekind (Dtype) = E_Subprogram_Type - and then Is_Itype (Dtype) and then not Has_Convention_Pragma (Dtype) then Basic_Set_Convention (Dtype, Val); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 5049ad6a7f8..30c35cb1591 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1056,7 +1056,7 @@ package Sem_Util is (Typ : Entity_Id; Nam : Name_Id) return Entity_Id; -- Retrieve one of the primitives First, Next, Has_Element, Element from - -- the value of the Iterable aspect of a formal type. + -- the value of the Iterable aspect of a type. procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); -- Retrieve the fully expanded name of the library unit declared by diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 400ac421932..4a902e82e4f 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -2464,14 +2464,6 @@ package body Sinfo is return Flag17 (N); end No_Truncation; - function Non_Aliased_Prefix - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Attribute_Reference); - return Flag18 (N); - end Non_Aliased_Prefix; - function Null_Excluding_Subtype (N : Node_Id) return Boolean is begin @@ -5774,14 +5766,6 @@ package body Sinfo is Set_Flag17 (N, Val); end Set_No_Truncation; - procedure Set_Non_Aliased_Prefix - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Attribute_Reference); - Set_Flag18 (N, Val); - end Set_Non_Aliased_Prefix; - procedure Set_Null_Excluding_Subtype (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0aef4b6f723..a5a6413200b 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2083,13 +2083,6 @@ package Sinfo is -- is used for properly setting out of range values for use by pragmas -- Initialize_Scalars and Normalize_Scalars. - -- Non_Aliased_Prefix (Flag18-Sem) - -- Present in N_Attribute_Reference nodes. Set only for the case of an - -- Unrestricted_Access reference whose prefix is non-aliased, which is - -- the case that is permitted for Unrestricted_Access except when the - -- expected type is a thin pointer to unconstrained array. This flag is - -- to assist in detecting this illegal use of Unrestricted_Access. - -- Null_Excluding_Subtype (Flag16) -- Present in N_Access_To_Object_Definition. Indicates that the subtype -- indication carries a null-exclusion indicator, which is distinct from @@ -3944,7 +3937,6 @@ package Sinfo is -- Do_Overflow_Check (Flag17-Sem) -- Header_Size_Added (Flag11-Sem) -- Must_Be_Byte_Aligned (Flag14-Sem) - -- Non_Aliased_Prefix (Flag18-Sem) -- Redundant_Use (Flag13-Sem) -- plus fields for expression @@ -9732,9 +9724,6 @@ package Sinfo is function No_Truncation (N : Node_Id) return Boolean; -- Flag17 - function Non_Aliased_Prefix - (N : Node_Id) return Boolean; -- Flag18 - function Null_Excluding_Subtype (N : Node_Id) return Boolean; -- Flag16 @@ -10791,9 +10780,6 @@ package Sinfo is procedure Set_No_Truncation (N : Node_Id; Val : Boolean := True); -- Flag17 - procedure Set_Non_Aliased_Prefix - (N : Node_Id; Val : Boolean := True); -- Flag18 - procedure Set_Null_Excluding_Subtype (N : Node_Id; Val : Boolean := True); -- Flag16 @@ -13129,7 +13115,6 @@ package Sinfo is pragma Inline (No_Minimize_Eliminate); pragma Inline (No_Side_Effect_Removal); pragma Inline (No_Truncation); - pragma Inline (Non_Aliased_Prefix); pragma Inline (Null_Excluding_Subtype); pragma Inline (Null_Exclusion_Present); pragma Inline (Null_Exclusion_In_Return_Present); @@ -13478,7 +13463,6 @@ package Sinfo is pragma Inline (Set_No_Minimize_Eliminate); pragma Inline (Set_No_Side_Effect_Removal); pragma Inline (Set_No_Truncation); - pragma Inline (Set_Non_Aliased_Prefix); pragma Inline (Set_Null_Excluding_Subtype); pragma Inline (Set_Null_Exclusion_Present); pragma Inline (Set_Null_Exclusion_In_Return_Present); diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads index 6ba58d6b2b2..c49d5e5a229 100644 --- a/gcc/ada/treepr.ads +++ b/gcc/ada/treepr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -49,7 +49,7 @@ package Treepr is -- of the nodes in the list procedure Print_Node_Subtree (N : Node_Id); - -- Prints the subtree routed at a specified tree node, including all + -- Prints the subtree rooted at a specified tree node, including all -- referenced descendants. procedure Print_List_Subtree (L : List_Id); diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads index db9ceb214b8..7ea18159532 100644 --- a/gcc/ada/validsw.ads +++ b/gcc/ada/validsw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2017, 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- -- @@ -54,7 +54,7 @@ package Validsw is Validity_Check_Default : Boolean := True; -- Controls default (reference manual) validity checking. If this switch is - -- set to True using -gnatVd or a 'd' in the argument of a Validity_ Checks + -- set to True using -gnatVd or a 'd' in the argument of a Validity_Checks -- pragma (or the initial default value is used, set True), then left side -- subscripts and case statement arguments are checked for validity. This -- switch is also set by default if no -gnatV switch is used and no diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d7e95dc7f4e..a84419551de 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2017-09-18 Bob Duff + + * gnat.dg/validity_check.adb: New testcase. + +2017-09-18 Eric Botcazou + + * gnat.dg/overload.ads, gnat.dg/overload.adb: New testcase. + +2017-09-18 Bob Duff + + * gnat.dg/tagged_prefix_call.adb: New testcase. + 2017-09-18 Ed Schonberg * gnat.dg/default_variants.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/overload.adb b/gcc/testsuite/gnat.dg/overload.adb new file mode 100644 index 00000000000..9e82815a0cb --- /dev/null +++ b/gcc/testsuite/gnat.dg/overload.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } + +package body Overload is + + function Get (I : Integer) return Ptr1 is + P : Ptr1 := null; + begin + return P; + end; + + function Get (I : Integer) return Ptr2 is + P : Ptr2 := null; + begin + return P; + end; + + function F (I : Integer) return Ptr1 is + P : Ptr1 := Get (I).Data'Access; + begin + return P; + end; + +end Overload; diff --git a/gcc/testsuite/gnat.dg/overload.ads b/gcc/testsuite/gnat.dg/overload.ads new file mode 100644 index 00000000000..42ec6795568 --- /dev/null +++ b/gcc/testsuite/gnat.dg/overload.ads @@ -0,0 +1,20 @@ +package Overload is + + type Rec1 is record + Data : Integer; + end record; + type Ptr1 is access all Rec1; + + type Rec2 is record + Data : aliased Rec1; + end record; + + type Ptr2 is access Rec2; + + function Get (I : Integer) return Ptr1; + + function Get (I : Integer) return Ptr2; + + function F (I : Integer) return Ptr1; + +end Overload; diff --git a/gcc/testsuite/gnat.dg/tagged_prefix_call.adb b/gcc/testsuite/gnat.dg/tagged_prefix_call.adb new file mode 100644 index 00000000000..15d1ba15223 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged_prefix_call.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +procedure Tagged_Prefix_Call is + + package Defs is + type Database_Connection_Record is abstract tagged null record; + type Database_Connection is access all Database_Connection_Record'Class; + + procedure Start_Transaction + (Self : not null access Database_Connection_Record'Class) + is null; + + type DB_Connection (Elem : access Database_Connection) + is null record + with Implicit_Dereference => Elem; + end Defs; + + use Defs; + + DB : DB_Connection(null); + +begin + DB.Start_Transaction; +end Tagged_Prefix_Call; diff --git a/gcc/testsuite/gnat.dg/validity_check.adb b/gcc/testsuite/gnat.dg/validity_check.adb new file mode 100644 index 00000000000..a37a5955201 --- /dev/null +++ b/gcc/testsuite/gnat.dg/validity_check.adb @@ -0,0 +1,18 @@ +-- { dg-do run } +-- { dg-options "-cargs -O -gnatn -gnatVa -gnatws -margs" } + +pragma Initialize_Scalars; + +procedure Validity_Check is + + type Small_Int is mod 2**6; + + type Arr is array (1 .. 16) of Small_Int; + pragma Pack (Arr); + + S : Small_Int; + A : Arr; + +begin + null; +end; -- 2.30.2