From 5168a9b3d09e3da03cc51a09fd28813ff6b49b96 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Mon, 9 Oct 2017 15:17:16 +0000 Subject: [PATCH] exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking code so if BIPAlloc is not passed in... gcc/ada/ 2017-10-09 Bob Duff * exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking code so if BIPAlloc is not passed in, it will likely raise Program_Error instead of cause miscellaneous chaos. (Is_Build_In_Place_Result_Type): Return False if not Expander_Active, as for the other Is_B-I-P... functions. * sem_aggr.adb (Resolve_Extension_Aggregate): For an extension aggregate whose ancestor part is a build-in-place call returning a nonlimited type, transform the assignment to the ancestor part to use a temp. * sem_ch3.adb (Build_Itype_Reference): Handle the case where we're creating an Itype for a library unit entity. (Check_Initialization): Avoid spurious error message on internally-generated call. * sem_ch5.adb (Analyze_Assignment): Handle the case where the right-hand side is a build-in-place call. This didn't happen when b-i-p was only for limited types. * sem_ch6.adb (Create_Extra_Formals): Remove assumption that b-i-p implies >= Ada 2005. * sem_ch7.adb (Scan_Subprogram_Refs): Avoid traversing the same nodes repeatedly. * sem_util.adb (Next_Actual): Handle case of build-in-place call. 2017-10-09 Arnaud Charlet * doc/gnat_ugn/gnat_and_program_execution.rst: Minor edit. 2017-10-09 Piotr Trojanek * libgnarl/s-taprob.adb: Minor whitespace fix. 2017-10-09 Bob Duff * namet.ads: Minor comment fix. 2017-10-09 Piotr Trojanek * sem_aux.adb (Unit_Declaration_Node): Detect protected declarations, just like other program units listed in Ada RM 10.1(1). 2017-10-09 Justin Squirek * sem_ch8.adb (Update_Chain_In_Scope): Modify warning messages. 2017-10-09 Ed Schonberg * sem_ch12.adb (Analyze_Associations, Check_Generic_Parent): If an actual for a formal package is an instantiation of a child unit, create a freeze node for the instance of the parent if it appears in the same scope and is not frozen yet. 2017-10-09 Pierre-Marie de Rodat * exp_atag.ads, libgnat/a-tags.adb, libgnat/a-tags.ads: Enhance in-source documentation for tagged types's Offset_To_Top. 2017-10-09 Bob Duff * exp_ch3.adb (Build_Assignment): Parameter name N was somewhat confusing. Same for N_Loc. Remove assumption that b-i-p implies limited. This is for the case of a function call that occurs as the default for a record component. (Expand_N_Object_Declaration): Deal with the case where expansion has created an object declaration initialized with something like F(...)'Reference. * exp_ch3.adb: Minor reformatting. 2017-10-09 Ed Schonberg * exp_attr.adb (Expand_Attribute_Reference, case 'Valid): The prefix of the attribute is an object, but it may appear within a conversion. The object itself must be retrieved when generating the range test that implements the validity check on a scalar type. gcc/testsuite/ 2017-10-09 Ed Schonberg * gnat.dg/validity_check2.adb, gnat.dg/validity_check2_pkg.ads: New testcase. From-SVN: r253548 --- gcc/ada/ChangeLog | 75 +++++++++++ .../gnat_ugn/gnat_and_program_execution.rst | 5 +- gcc/ada/exp_atag.ads | 4 +- gcc/ada/exp_attr.adb | 6 +- gcc/ada/exp_ch3.adb | 70 +++++++---- gcc/ada/exp_ch6.adb | 43 +++++-- gcc/ada/libgnarl/s-taprob.adb | 2 +- gcc/ada/libgnat/a-tags.adb | 12 ++ gcc/ada/libgnat/a-tags.ads | 13 +- gcc/ada/namet.ads | 2 +- gcc/ada/sem_aggr.adb | 37 +++++- gcc/ada/sem_aux.adb | 1 + gcc/ada/sem_ch12.adb | 74 ++++++++--- gcc/ada/sem_ch3.adb | 34 ++++- gcc/ada/sem_ch5.adb | 119 ++++++++++++++++-- gcc/ada/sem_ch6.adb | 2 +- gcc/ada/sem_ch7.adb | 35 +++++- gcc/ada/sem_ch8.adb | 4 +- gcc/ada/sem_util.adb | 13 +- gcc/testsuite/gnat.dg/validity_check2.adb | 11 ++ gcc/testsuite/gnat.dg/validity_check2_pkg.ads | 16 +++ 21 files changed, 495 insertions(+), 83 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/validity_check2.adb create mode 100644 gcc/testsuite/gnat.dg/validity_check2_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f4588406422..2ba6e707def 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,78 @@ +2017-10-09 Bob Duff + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking + code so if BIPAlloc is not passed in, it will likely raise + Program_Error instead of cause miscellaneous chaos. + (Is_Build_In_Place_Result_Type): Return False if not Expander_Active, + as for the other Is_B-I-P... functions. + * sem_aggr.adb (Resolve_Extension_Aggregate): For an extension + aggregate whose ancestor part is a build-in-place call returning a + nonlimited type, transform the assignment to the ancestor part to use a + temp. + * sem_ch3.adb (Build_Itype_Reference): Handle the case where we're + creating an Itype for a library unit entity. + (Check_Initialization): Avoid spurious error message on + internally-generated call. + * sem_ch5.adb (Analyze_Assignment): Handle the case where the + right-hand side is a build-in-place call. This didn't happen when b-i-p + was only for limited types. + * sem_ch6.adb (Create_Extra_Formals): Remove assumption that b-i-p + implies >= Ada 2005. + * sem_ch7.adb (Scan_Subprogram_Refs): Avoid traversing the same nodes + repeatedly. + * sem_util.adb (Next_Actual): Handle case of build-in-place call. + +2017-10-09 Arnaud Charlet + + * doc/gnat_ugn/gnat_and_program_execution.rst: Minor edit. + +2017-10-09 Piotr Trojanek + + * libgnarl/s-taprob.adb: Minor whitespace fix. + +2017-10-09 Bob Duff + + * namet.ads: Minor comment fix. + +2017-10-09 Piotr Trojanek + + * sem_aux.adb (Unit_Declaration_Node): Detect protected declarations, + just like other program units listed in Ada RM 10.1(1). + +2017-10-09 Justin Squirek + + * sem_ch8.adb (Update_Chain_In_Scope): Modify warning messages. + +2017-10-09 Ed Schonberg + + * sem_ch12.adb (Analyze_Associations, Check_Generic_Parent): If an + actual for a formal package is an instantiation of a child unit, create + a freeze node for the instance of the parent if it appears in the same + scope and is not frozen yet. + +2017-10-09 Pierre-Marie de Rodat + + * exp_atag.ads, libgnat/a-tags.adb, libgnat/a-tags.ads: Enhance + in-source documentation for tagged types's Offset_To_Top. + +2017-10-09 Bob Duff + + * exp_ch3.adb (Build_Assignment): Parameter name N was somewhat + confusing. Same for N_Loc. Remove assumption that b-i-p implies + limited. This is for the case of a function call that occurs as the + default for a record component. + (Expand_N_Object_Declaration): Deal with the case where expansion has + created an object declaration initialized with something like + F(...)'Reference. + * exp_ch3.adb: Minor reformatting. + +2017-10-09 Ed Schonberg + + * exp_attr.adb (Expand_Attribute_Reference, case 'Valid): The prefix of + the attribute is an object, but it may appear within a conversion. The + object itself must be retrieved when generating the range test that + implements the validity check on a scalar type. + 2017-10-05 Eric Botcazou PR ada/82393 diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index 68117ae2c49..ac45cee3305 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -4093,9 +4093,8 @@ execution of this erroneous program: ``gnatmem`` makes use of the output created by the special version of allocation and deallocation routines that record call information. This allows it to obtain accurate dynamic memory usage history at a minimal cost to the - execution speed. Note however, that ``gnatmem`` is not supported on all - platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, Solaris and - Windows). + execution speed. Note however, that ``gnatmem`` is only supported on + GNU/Linux and Windows. The ``gnatmem`` command has the form diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index d53466fc39c..73af9a05059 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-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- -- @@ -147,7 +147,7 @@ package Exp_Atag is -- -- Generates: -- Offset_To_Top_Ptr - -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset) + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all function Build_Set_Predefined_Prim_Op_Address (Loc : Source_Ptr; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 552cd0295b5..719699566e4 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6512,7 +6512,9 @@ package body Exp_Attr is begin -- The prefix of attribute 'Valid should always denote an object -- reference. The reference is either coming directly from source - -- or is produced by validity check expansion. + -- or is produced by validity check expansion. The object may be + -- wrapped in a conversion in which case the call to Unqual_Conv + -- will yield it. -- If the prefix denotes a variable which captures the value of -- an object for validation purposes, use the variable in the @@ -6523,7 +6525,7 @@ package body Exp_Attr is -- if not Temp in ... then if Is_Validation_Variable_Reference (Pref) then - Temp := New_Occurrence_Of (Entity (Pref), Loc); + Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc); -- Otherwise the prefix is either a source object or a constant -- produced by validity check expansion. Generate: diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0198e3e5f7e..514e4d2ebaf 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1711,10 +1711,11 @@ package body Exp_Ch3 is Rec_Type : Entity_Id; Set_Tag : Entity_Id := Empty; - function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; - -- Build an assignment statement which assigns the default expression - -- to its corresponding record component if defined. The left hand side - -- of the assignment is marked Assignment_OK so that initialization of + function Build_Assignment + (Id : Entity_Id; Default : Node_Id) return List_Id; + -- Build an assignment statement that assigns the default expression to + -- its corresponding record component if defined. The left-hand side of + -- the assignment is marked Assignment_OK so that initialization of -- limited private records works correctly. This routine may also build -- an adjustment call if the component is controlled. @@ -1783,13 +1784,15 @@ package body Exp_Ch3 is -- Build_Assignment -- ---------------------- - function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is - N_Loc : constant Source_Ptr := Sloc (N); + function Build_Assignment + (Id : Entity_Id; Default : Node_Id) return List_Id + is + Default_Loc : constant Source_Ptr := Sloc (Default); Typ : constant Entity_Id := Underlying_Type (Etype (Id)); Adj_Call : Node_Id; - Exp : Node_Id := N; - Kind : Node_Kind := Nkind (N); + Exp : Node_Id := Default; + Kind : Node_Kind := Nkind (Default); Lhs : Node_Id; Res : List_Id; @@ -1815,10 +1818,11 @@ package body Exp_Ch3 is and then Present (Discriminal_Link (Entity (N))) then Val := - Make_Selected_Component (N_Loc, + Make_Selected_Component (Default_Loc, Prefix => New_Copy_Tree (Lhs), Selector_Name => - New_Occurrence_Of (Discriminal_Link (Entity (N)), N_Loc)); + New_Occurrence_Of + (Discriminal_Link (Entity (N)), Default_Loc)); if Present (Val) then Rewrite (N, New_Copy_Tree (Val)); @@ -1835,9 +1839,9 @@ package body Exp_Ch3 is begin Lhs := - Make_Selected_Component (N_Loc, + Make_Selected_Component (Default_Loc, Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, N_Loc)); + Selector_Name => New_Occurrence_Of (Id, Default_Loc)); Set_Assignment_OK (Lhs); if Nkind (Exp) = N_Aggregate @@ -1866,16 +1870,16 @@ package body Exp_Ch3 is -- traversing the expression. ??? if Kind = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Unchecked_Access, + and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access, Name_Unrestricted_Access) - and then Is_Entity_Name (Prefix (N)) - and then Is_Type (Entity (Prefix (N))) - and then Entity (Prefix (N)) = Rec_Type + and then Is_Entity_Name (Prefix (Default)) + and then Is_Type (Entity (Prefix (Default))) + and then Entity (Prefix (Default)) = Rec_Type then Exp := - Make_Attribute_Reference (N_Loc, + Make_Attribute_Reference (Default_Loc, Prefix => - Make_Identifier (N_Loc, Name_uInit), + Make_Identifier (Default_Loc, Name_uInit), Attribute_Name => Name_Unrestricted_Access); end if; @@ -1899,13 +1903,14 @@ package body Exp_Ch3 is if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Append_To (Res, - Make_Assignment_Statement (N_Loc, + Make_Assignment_Statement (Default_Loc, Name => - Make_Selected_Component (N_Loc, + Make_Selected_Component (Default_Loc, Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id), Selector_Name => - New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)), + New_Occurrence_Of + (First_Tag_Component (Typ), Default_Loc)), Expression => Unchecked_Convert_To (RTE (RE_Tag), @@ -1913,19 +1918,19 @@ package body Exp_Ch3 is (Node (First_Elmt (Access_Disp_Table (Underlying_Type (Typ)))), - N_Loc)))); + Default_Loc)))); end if; -- Adjust the component if controlled except if it is an aggregate -- that will be expanded inline. if Kind = N_Qualified_Expression then - Kind := Nkind (Expression (N)); + Kind := Nkind (Expression (Default)); end if; if Needs_Finalization (Typ) and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) - and then not Is_Limited_View (Typ) + and then not Is_Build_In_Place_Function_Call (Exp) then Adj_Call := Make_Adjust_Call @@ -6308,6 +6313,23 @@ package body Exp_Ch3 is return; + -- This is the same as the previous 'elsif', except that the call has + -- been transformed by other expansion activities into something like + -- F(...)'Reference. + + elsif Nkind (Expr_Q) = N_Reference + and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q)) + and then not Is_Expanded_Build_In_Place_Call + (Unqual_Conv (Prefix (Expr_Q))) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q)); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + -- Ada 2005 (AI-318-02): Specialization of the previous case for -- expressions containing a build-in-place function call whose -- returned object covers interface types, and Expr_Q has calls to diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 715e74cfebe..9204179fee7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5298,16 +5298,39 @@ package body Exp_Ch6 is Temp_Typ => Ref_Type, Func_Id => Func_Id, Ret_Typ => Ret_Obj_Typ, - Alloc_Expr => Heap_Allocator)))), + Alloc_Expr => Heap_Allocator))), + + -- ???If all is well, we can put the following + -- 'elsif' in the 'else', but this is a useful + -- self-check in case caller and callee don't agree + -- on whether BIPAlloc and so on should be passed. + + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (User_Storage_Pool)))), + + Then_Statements => New_List ( + Pool_Decl, + Build_Heap_Allocator + (Temp_Id => Alloc_Obj_Id, + Temp_Typ => Ref_Type, + Func_Id => Func_Id, + Ret_Typ => Ret_Obj_Typ, + Alloc_Expr => Pool_Allocator)))), + + -- Raise Program_Error if it's none of the above; + -- this is a compiler bug. ???PE_All_Guards_Closed + -- is bogus; we should have a new code. Else_Statements => New_List ( - Pool_Decl, - Build_Heap_Allocator - (Temp_Id => Alloc_Obj_Id, - Temp_Typ => Ref_Type, - Func_Id => Func_Id, - Ret_Typ => Ret_Obj_Typ, - Alloc_Expr => Pool_Allocator))); + Make_Raise_Program_Error (Loc, + Reason => PE_All_Guards_Closed))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the @@ -7205,6 +7228,10 @@ package body Exp_Ch6 is function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is begin + if not Expander_Active then + return False; + end if; + -- In Ada 2005 all functions with an inherently limited return type -- must be handled using a build-in-place profile, including the case -- of a function with a limited interface result, where the function diff --git a/gcc/ada/libgnarl/s-taprob.adb b/gcc/ada/libgnarl/s-taprob.adb index 517b92d8af2..c4d33c53365 100644 --- a/gcc/ada/libgnarl/s-taprob.adb +++ b/gcc/ada/libgnarl/s-taprob.adb @@ -75,7 +75,7 @@ package body System.Tasking.Protected_Objects is begin if Init_Priority = Unspecified_Priority then - Init_Priority := System.Priority'Last; + Init_Priority := System.Priority'Last; end if; Initialize_Lock (Init_Priority, Object.L'Access); diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb index 322f9915f6e..f3c2c0e969c 100644 --- a/gcc/ada/libgnat/a-tags.adb +++ b/gcc/ada/libgnat/a-tags.adb @@ -842,9 +842,21 @@ package body Ada.Tags is begin Curr_DT := DT (To_Tag_Ptr (This).all); + -- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top + if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then + + -- The parent record type has variable-size components, so the + -- instance-specific offset is stored in the tagged record, right + -- after the reference to Curr_DT (which is a secondary dispatch + -- table). + return To_Storage_Offset_Ptr (This + Tag_Size).all; + else + -- The offset is compile-time known, so it is simply stored in the + -- Offset_To_Top field. + return Curr_DT.Offset_To_Top; end if; end Offset_To_Top; diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads index 564ce205f49..a11cdd4a44d 100644 --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -380,12 +380,21 @@ private -- Prims_Ptr table. Offset_To_Top : SSE.Storage_Offset; - TSD : System.Address; + -- Offset between the _Tag field and the field that contains the + -- reference to this dispatch table. For primary dispatch tables it is + -- zero. For secondary dispatch tables: if the parent record type (if + -- any) has a compile-time-known size, then Offset_To_Top contains the + -- expected value, otherwise it contains SSE.Storage_Offset'Last and the + -- actual offset is to be found in the tagged record, right after the + -- field that contains the reference to this dispatch table. See the + -- implementation of Ada.Tags.Offset_To_Top for the corresponding logic. + + TSD : System.Address; Prims_Ptr : aliased Address_Array (1 .. Num_Prims); -- The size of the Prims_Ptr array actually depends on the tagged type -- to which it applies. For each tagged type, the expander computes the - -- actual array size, allocates the Dispatch_Table record accordingly. + -- actual array size, allocating the Dispatch_Table record accordingly. end record; type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 124f7782036..72ac8fabf30 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -477,7 +477,7 @@ package Namet is -- Sets the Int value associated with the given name function Is_Internal_Name (Id : Name_Id) return Boolean; - -- Returns True if the name is an internal name (i.e. contains a character + -- Returns True if the name is an internal name, i.e. contains a character -- for which Is_OK_Internal_Letter is true, or if the name starts or ends -- with an underscore. -- diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index ad6e1ea9a3e..e361bacaa14 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -30,6 +30,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; @@ -2932,6 +2933,11 @@ package body Sem_Aggr is -- Verify that the type of the ancestor part is a non-private ancestor -- of the expected type, which must be a type extension. + procedure Transform_BIP_Assignment (Typ : Entity_Id); + -- For an extension aggregate whose ancestor part is a build-in-place + -- call returning a nonlimited type, this is used to transform the + -- assignment to the ancestor part to use a temp. + ---------------------------- -- Valid_Limited_Ancestor -- ---------------------------- @@ -3013,6 +3019,23 @@ package body Sem_Aggr is return False; end Valid_Ancestor_Type; + procedure Transform_BIP_Assignment (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A); + Obj_Decl : constant Node_Id := + Make_Object_Declaration + (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => A, + Has_Init_Expression => True); + begin + Set_Etype (Def_Id, Typ); + Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc)); + Insert_Action (N, Obj_Decl); + end Transform_BIP_Assignment; + -- Start of processing for Resolve_Extension_Aggregate begin @@ -3081,7 +3104,7 @@ package body Sem_Aggr is Get_First_Interp (A, I, It); while Present (It.Typ) loop - -- Only consider limited interpretations in the Ada 2005 case + -- Consider limited interpretations if Ada 2005 or higher if Is_Tagged_Type (It.Typ) and then (Ada_Version >= Ada_2005 @@ -3177,6 +3200,18 @@ package body Sem_Aggr is Error_Msg_N ("ancestor part must be statically tagged", A); else + -- We are using the build-in-place protocol, but we can't build + -- in place, because we need to call the function before + -- allocating the aggregate. Could do better for null + -- extensions, and maybe for nondiscriminated types. + -- This is wrong for limited, but those were wrong already. + + if not Is_Limited_View (A_Type) + and then Is_Build_In_Place_Function_Call (A) + then + Transform_BIP_Assignment (A_Type); + end if; + Resolve_Record_Aggregate (N, Typ); end if; end if; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4f60f41e122..d34ed078be7 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1693,6 +1693,7 @@ package body Sem_Aux is and then Nkind (N) /= N_Package_Renaming_Declaration and then Nkind (N) /= N_Procedure_Instantiation and then Nkind (N) /= N_Protected_Body + and then Nkind (N) /= N_Protected_Type_Declaration and then Nkind (N) /= N_Subprogram_Declaration and then Nkind (N) /= N_Subprogram_Body and then Nkind (N) /= N_Subprogram_Body_Stub diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ec270f3ad19..aeec421b5a3 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1903,7 +1903,8 @@ package body Sem_Ch12 is -- body. Explicit_Freeze_Check : declare - Actual : constant Entity_Id := Entity (Match); + Actual : constant Entity_Id := Entity (Match); + Gen_Par : Entity_Id; Needs_Freezing : Boolean; S : Entity_Id; @@ -1912,7 +1913,11 @@ package body Sem_Ch12 is -- The actual may be an instantiation of a unit -- declared in a previous instantiation. If that -- one is also in the current compilation, it must - -- itself be frozen before the actual. + -- itself be frozen before the actual. The actual + -- may be an instantiation of a generic child unit, + -- in which case the same applies to the instance + -- of the parent which must be frozen before the + -- actual. -- Should this itself be recursive ??? -------------------------- @@ -1920,30 +1925,71 @@ package body Sem_Ch12 is -------------------------- procedure Check_Generic_Parent is - Par : Entity_Id; + Inst : constant Node_Id := + Next (Unit_Declaration_Node (Actual)); + Par : Entity_Id; begin - if Nkind (Parent (Actual)) = - N_Package_Specification + Par := Empty; + + if Nkind (Parent (Actual)) = N_Package_Specification then Par := Scope (Generic_Parent (Parent (Actual))); - - if Is_Generic_Instance (Par) - and then Scope (Par) = Current_Scope - and then - (No (Freeze_Node (Par)) - or else - not Is_List_Member (Freeze_Node (Par))) + if Is_Generic_Instance (Par) then + null; + + -- If the actual is a child generic unit, check + -- whether the instantiation of the parent is + -- also local and must also be frozen now. + -- We must retrieve the instance node to locate + -- the parent instance if any. + + elsif Ekind (Par) = E_Generic_Package + and then Is_Child_Unit (Gen_Par) + and then Ekind (Scope (Gen_Par)) + = E_Generic_Package then - Set_Has_Delayed_Freeze (Par); - Append_Elmt (Par, Actuals_To_Freeze); + if Nkind (Inst) = N_Package_Instantiation + and then + Nkind (Name (Inst)) = N_Expanded_Name + then + + -- Retrieve entity of psarent instance. + + Par := Entity (Prefix (Name (Inst))); + end if; + + else + Par := Empty; end if; end if; + + if Present (Par) + and then Is_Generic_Instance (Par) + and then Scope (Par) = Current_Scope + and then + (No (Freeze_Node (Par)) + or else + not Is_List_Member (Freeze_Node (Par))) + then + Set_Has_Delayed_Freeze (Par); + Append_Elmt (Par, Actuals_To_Freeze); + end if; end Check_Generic_Parent; -- Start of processing for Explicit_Freeze_Check begin + if Present (Renamed_Entity (Actual)) then + Gen_Par := + Generic_Parent (Specification ( + Unit_Declaration_Node ( + Renamed_Entity (Actual)))); + else + Gen_Par := Generic_Parent + (Specification (Unit_Declaration_Node (Actual))); + end if; + if not Expander_Active or else not Has_Completion (Actual) or else not In_Same_Source_Unit (I_Node, Actual) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f6705d67232..eea0778c1a2 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10257,7 +10257,22 @@ package body Sem_Ch3 is return; else Set_Itype (IR, Ityp); - Insert_After (Nod, IR); + + -- If Nod is a library unit entity, then Insert_After won't work, + -- because Nod is not a member of any list. Therefore, we use + -- Add_Global_Declaration in this case. This can happen if we have a + -- build-in-place library function. + + if (Nkind (Nod) in N_Entity + and then Is_Compilation_Unit (Nod)) + or else + (Nkind (Nod) = N_Defining_Program_Unit_Name + and then Is_Compilation_Unit (Defining_Identifier (Nod))) + then + Add_Global_Declaration (IR); + else + Insert_After (Nod, IR); + end if; end if; end Build_Itype_Reference; @@ -11777,9 +11792,20 @@ package body Sem_Ch3 is if Nkind (Exp) = N_Type_Conversion and then Nkind (Expression (Exp)) = N_Function_Call then - Error_Msg_N - ("illegal context for call" - & " to function with limited result", Exp); + -- No error for internally-generated object declarations, + -- which can come from build-in-place assignment statements. + + if Nkind (Parent (Exp)) = N_Object_Declaration + and then not Comes_From_Source + (Defining_Identifier (Parent (Exp))) + then + null; + + else + Error_Msg_N + ("illegal context for call" + & " to function with limited result", Exp); + end if; else Error_Msg_N diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e3aa50b2ddd..54d0a8600d2 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -101,13 +101,7 @@ package body Sem_Ch5 is procedure Analyze_Assignment (N : Node_Id) is Lhs : constant Node_Id := Name (N); - Rhs : constant Node_Id := Expression (N); - - Decl : Node_Id; - T1 : Entity_Id; - T2 : Entity_Id; - - Save_Full_Analysis : Boolean := False; -- initialize to prevent warning + Rhs : Node_Id := Expression (N); procedure Diagnose_Non_Variable_Lhs (N : Node_Id); -- N is the node for the left hand side of an assignment, and it is not @@ -126,6 +120,93 @@ package body Sem_Ch5 is -- nominal subtype. This procedure is used to deal with cases where the -- nominal subtype must be replaced by the actual subtype. + procedure Transform_BIP_Assignment (Typ : Entity_Id); + function Should_Transform_BIP_Assignment + (Typ : Entity_Id) return Boolean; + -- If the right-hand side of an assignment statement is a build-in-place + -- call we cannot build in place, so we insert a temp initialized with + -- the call, and transform the assignment statement to copy the temp. + -- Transform_BIP_Assignment does the tranformation, and + -- Should_Transform_BIP_Assignment determines whether we should. + -- The same goes for qualified expressions and conversions whose + -- operand is such a call. + -- + -- This is only for nonlimited types; assignment statements are illegal + -- for limited types, but are generated internally for aggregates and + -- init procs. These limited-type are not really assignment statements + -- -- conceptually, they are initializations, so should not be + -- transformed. + -- + -- Similarly, for nonlimited types, aggregates and init procs generate + -- assignment statements that are really initializations. These are + -- marked No_Ctrl_Actions. + + function Should_Transform_BIP_Assignment + (Typ : Entity_Id) return Boolean + is + Result : Boolean; + begin + if Expander_Active + and then not Is_Limited_View (Typ) + and then Is_Build_In_Place_Result_Type (Typ) + and then not No_Ctrl_Actions (N) + then + -- This function is called early, before name resolution is + -- complete, so we have to deal with things that might turn into + -- function calls later. N_Function_Call and N_Op nodes are the + -- obvious case. An N_Identifier or N_Expanded_Name is a + -- parameterless function call if it denotes a function. + -- Finally, an attribute reference can be a function call. + + case Nkind (Unqual_Conv (Rhs)) is + when N_Function_Call | N_Op => + Result := True; + when N_Identifier | N_Expanded_Name => + case Ekind (Entity (Unqual_Conv (Rhs))) is + when E_Function | E_Operator => + Result := True; + when others => + Result := False; + end case; + when N_Attribute_Reference => + Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input; + -- T'Input will turn into a call whose result type is T + when others => + Result := False; + end case; + else + Result := False; + end if; + return Result; + end Should_Transform_BIP_Assignment; + + procedure Transform_BIP_Assignment (Typ : Entity_Id) is + -- Tranform "X : [constant] T := F (...);" into: + -- + -- Temp : constant T := F (...); + -- X := Temp; + + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); + Obj_Decl : constant Node_Id := + Make_Object_Declaration + (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Rhs, + Has_Init_Expression => True); + begin + Set_Etype (Def_Id, Typ); + Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); + + -- At this point, Rhs is no longer equal to Expression (N), so: + + Rhs := Expression (N); + + Insert_Action (N, Obj_Decl); + end Transform_BIP_Assignment; + ------------------------------- -- Diagnose_Non_Variable_Lhs -- ------------------------------- @@ -232,6 +313,7 @@ package body Sem_Ch5 is (Opnd : Node_Id; Opnd_Type : in out Entity_Id) is + Decl : Node_Id; begin Require_Entity (Opnd); @@ -284,6 +366,11 @@ package body Sem_Ch5 is -- Local variables + T1 : Entity_Id; + T2 : Entity_Id; + + Save_Full_Analysis : Boolean; + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; -- Save the Ghost mode to restore on exit @@ -360,8 +447,9 @@ package body Sem_Ch5 is null; elsif Has_Compatible_Type (Rhs, It.Typ) then - if T1 /= Any_Type then - + if T1 = Any_Type then + T1 := It.Typ; + else -- An explicit dereference is overloaded if the prefix -- is. Try to remove the ambiguity on the prefix, the -- error will be posted there if the ambiguity is real. @@ -412,8 +500,6 @@ package body Sem_Ch5 is ("ambiguous left-hand side in assignment", Lhs); exit; end if; - else - T1 := It.Typ; end if; end if; @@ -429,6 +515,15 @@ package body Sem_Ch5 is end if; end if; + -- Deal with build-in-place calls for nonlimited types. + -- We don't do this later, because resolving the rhs + -- tranforms it incorrectly for build-in-place. + + if Should_Transform_BIP_Assignment (Typ => T1) then + Transform_BIP_Assignment (Typ => T1); + end if; + pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); + -- The resulting assignment type is T1, so now we will resolve the left -- hand side of the assignment using this determined type. @@ -971,6 +1066,8 @@ package body Sem_Ch5 is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; end if; + + pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); end Analyze_Assignment; ----------------------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index cf1b83f0ade..3e892f836ad 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8002,7 +8002,7 @@ package body Sem_Ch6 is -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. - if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then + if Is_Build_In_Place_Function (E) then declare Result_Subt : constant Entity_Id := Etype (E); Full_Subt : constant Entity_Id := Available_View (Result_Subt); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index ba7ff3c848c..1565662ca12 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -199,7 +199,7 @@ package body Sem_Ch7 is subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1; -- Range of headers in hash table - function Entity_Hash (Id : Entity_Id) return Entity_Header_Num; + function Node_Hash (Id : Entity_Id) return Entity_Header_Num; -- Simple hash function for Entity_Ids package Subprogram_Table is new GNAT.Htable.Simple_HTable @@ -207,19 +207,29 @@ package body Sem_Ch7 is Element => Boolean, No_Element => False, Key => Entity_Id, - Hash => Entity_Hash, + Hash => Node_Hash, Equal => "="); -- Hash table to record which subprograms are referenced. It is declared -- at library level to avoid elaborating it for every call to Analyze. + package Traversed_Table is new GNAT.Htable.Simple_HTable + (Header_Num => Entity_Header_Num, + Element => Boolean, + No_Element => False, + Key => Node_Id, + Hash => Node_Hash, + Equal => "="); + -- Hash table to record which nodes we have traversed, so we can avoid + -- traversing the same nodes repeatedly. + ----------------- - -- Entity_Hash -- + -- Node_Hash -- ----------------- - function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is + function Node_Hash (Id : Entity_Id) return Entity_Header_Num is begin return Entity_Header_Num (Id mod Entity_Table_Size); - end Entity_Hash; + end Node_Hash; --------------------------------- -- Analyze_Package_Body_Helper -- @@ -260,13 +270,25 @@ package body Sem_Ch7 is function Scan_Subprogram_Ref (N : Node_Id) return Traverse_Result; -- Determine whether a node denotes a reference to a subprogram - procedure Scan_Subprogram_Refs is + procedure Traverse_And_Scan_Subprogram_Refs is new Traverse_Proc (Scan_Subprogram_Ref); -- Subsidiary to routine Has_Referencer. Determine whether a node -- contains references to a subprogram and record them. -- WARNING: this is a very expensive routine as it performs a full -- tree traversal. + procedure Scan_Subprogram_Refs (Node : Node_Id); + -- If we haven't already traversed Node, then mark it and traverse + -- it. + + procedure Scan_Subprogram_Refs (Node : Node_Id) is + begin + if not Traversed_Table.Get (Node) then + Traversed_Table.Set (Node, True); + Traverse_And_Scan_Subprogram_Refs (Node); + end if; + end Scan_Subprogram_Refs; + -------------------- -- Has_Referencer -- -------------------- @@ -581,6 +603,7 @@ package body Sem_Ch7 is -- actual parameters of the instantiations matter here, and they are -- present in the declarations list of the instantiated packages. + Traversed_Table.Reset; Subprogram_Table.Reset; Discard := Has_Referencer (Decls, Top_Level => True); end Hide_Public_Entities; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index a51cc636298..95bb0fe4a97 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -9069,7 +9069,7 @@ package body Sem_Ch8 is (Current_Use_Clause (Associated_Node (N)))) then Error_Msg_Node_1 := Entity (N); - Error_Msg_NE ("ineffective use clause for package &?", + Error_Msg_NE ("use clause for package &? has no effect", Curr, Entity (N)); end if; @@ -9077,7 +9077,7 @@ package body Sem_Ch8 is else Error_Msg_Node_1 := Etype (N); - Error_Msg_NE ("ineffective use clause for }?", + Error_Msg_NE ("use clause for }? has no effect", Curr, Etype (N)); end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 20cda2d800e..60df83840f7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -19059,7 +19059,18 @@ package body Sem_Util is N := Next (Actual_Id); if Nkind (N) = N_Parameter_Association then - return First_Named_Actual (Parent (Actual_Id)); + -- In case of a build-in-place call, the call will no longer be a + -- call; it will have been rewritten. + + if Nkind_In (Parent (Actual_Id), + N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) + then + return First_Named_Actual (Parent (Actual_Id)); + else + return Empty; + end if; else return N; end if; diff --git a/gcc/testsuite/gnat.dg/validity_check2.adb b/gcc/testsuite/gnat.dg/validity_check2.adb new file mode 100644 index 00000000000..f349cf16036 --- /dev/null +++ b/gcc/testsuite/gnat.dg/validity_check2.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatVi -gnatws" } + +with Validity_Check2_Pkg; use Validity_Check2_Pkg; + +procedure Validity_Check2 (R : access Rec) is +begin + if Op_Code_To_Msg (R.Code) in Valid_Msg then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/validity_check2_pkg.ads b/gcc/testsuite/gnat.dg/validity_check2_pkg.ads new file mode 100644 index 00000000000..c9b6a01e191 --- /dev/null +++ b/gcc/testsuite/gnat.dg/validity_check2_pkg.ads @@ -0,0 +1,16 @@ +with Ada.unchecked_conversion; + +package Validity_Check2_Pkg is + + type Op_Code is (One, Two, Three, Four); + + subtype Valid_Msg is Integer range 0 .. 15; + + function Op_Code_To_Msg is + new Ada.Unchecked_Conversion (Source => Op_code, Target => Valid_Msg); + + type Rec is record + Code : Op_Code; + end record; + +end Validity_Check2_Pkg; -- 2.30.2