From 5941a4e9f20abea8c68f43fa4a62b46f10023d0d Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 7 Oct 2010 13:06:22 +0000 Subject: [PATCH] 2010-10-07 Robert Dewar * einfo.ads (No_Pool_Assigned): Update documentation. * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Storage_Size): We only set No_Pool_Assigned if the expression is a static constant and zero. * sem_res.adb (Resolve_Allocator): Allocation from empty storage pool should be an error not a warning. 2010-10-07 Ed Schonberg * exp_aggr.adb (Expand_Array_Aggregate): Recognize additional cases where an aggregate in an assignment can be built directly into the target, and does not require the creation of a temporary that may overflow the stack. 2010-10-07 Ed Schonberg * sem_aggr.adb (Analyze_Record_Aggregate): In Ada2012, a choice list in a record aggregate can correspond to several components of anonymous access types, as long as the designated subtypes match. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165104 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 22 +++++++++++++++++++++ gcc/ada/einfo.ads | 12 ++++++------ gcc/ada/exp_aggr.adb | 54 ++++++++++++++++++++++++++++++++++++---------------- gcc/ada/sem_aggr.adb | 17 ++++++++++++++++- gcc/ada/sem_ch13.adb | 2 +- gcc/ada/sem_res.adb | 10 +--------- 6 files changed, 84 insertions(+), 33 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a5d6633..070e8e5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2010-10-07 Robert Dewar + * einfo.ads (No_Pool_Assigned): Update documentation. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Storage_Size): We only set No_Pool_Assigned if the expression is a + static constant and zero. + * sem_res.adb (Resolve_Allocator): Allocation from empty storage pool + should be an error not a warning. + +2010-10-07 Ed Schonberg + + * exp_aggr.adb (Expand_Array_Aggregate): Recognize additional cases + where an aggregate in an assignment can be built directly into the + target, and does not require the creation of a temporary that may + overflow the stack. + +2010-10-07 Ed Schonberg + + * sem_aggr.adb (Analyze_Record_Aggregate): In Ada2012, a choice list + in a record aggregate can correspond to several components of + anonymous access types, as long as the designated subtypes match. + +2010-10-07 Robert Dewar + * gnat_rm.texi, exp_util.adb, sinfo.adb, sinfo.ads, sem_ch12.adb, sem.adb, gnat_ugn.texi, sem_util.ads, par-ch6.adb, targparm.ads, restrict.adb, sem_ch6.adb, sem_ch6.ads, sprint.adb, i-c.ads: Change diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ed91d5e..6c1aa2f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3035,12 +3035,12 @@ package Einfo is -- interpreted as true. Currently this is set true for derived Boolean -- types which have a convention of C, C++ or Fortran. --- No_Pool_Assigned (Flag131) [root type only] --- Present in access types. Set if a storage size clause applies to --- the variable with a compile time known value of zero. This flag is --- used to generate warnings if any attempt is made to allocate or free --- an instance of such an access type. This is set only in the root --- type, since derived types must have the same pool. +-- No_Pool_Assigned (Flag131) [root type only] Present in access types. +-- Set if a storage size clause applies to the variable with a static +-- expression value of zero. This flag is used to generate errors if any +-- attempt is made to allocate or free an instance of such an access +-- type. This is set only in the root type, since derived types must +-- have the same pool. -- No_Return (Flag113) -- Present in all entities. Always false except in the case of procedures diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 27ad463..3a7e46f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3768,12 +3768,13 @@ package body Exp_Aggr is then Expr := First (Component_Associations (N)); while Present (Expr) loop - if Nkind (Expression (Expr)) = N_Integer_Literal then + if Nkind_In (Expression (Expr), N_Integer_Literal, + N_Real_Literal) + then null; elsif Nkind (Expression (Expr)) /= N_Aggregate - or else - not Compile_Time_Known_Aggregate (Expression (Expr)) + or else not Compile_Time_Known_Aggregate (Expression (Expr)) or else Expansion_Delayed (Expression (Expr)) then Static_Components := False; @@ -4194,6 +4195,11 @@ package body Exp_Aggr is -- Sub_Aggr is an array sub-aggregate. Dim is the dimension -- corresponding to the sub-aggregate. + function Safe_Left_Hand_Side (N : Node_Id) return Boolean; + -- In addition to Maybe_In_Place_OK, in order for an aggregate to be + -- built directly into the target of the assignment it must be free + -- of side-effects. + ---------------------------- -- Build_Constrained_Type -- ---------------------------- @@ -4922,7 +4928,33 @@ package body Exp_Aggr is end if; end Others_Check; - -- Remaining Expand_Array_Aggregate variables + ------------------------- + -- Safe_Left_Hand_Side -- + ------------------------- + + function Safe_Left_Hand_Side (N : Node_Id) return Boolean is + begin + if Is_Entity_Name (N) then + return True; + + elsif Nkind_In (N, N_Explicit_Dereference, N_Selected_Component) + and then Safe_Left_Hand_Side (Prefix (N)) + then + return True; + + elsif Nkind (N) = N_Indexed_Component + and then Safe_Left_Hand_Side (Prefix (N)) + and then + (Is_Entity_Name (First (Expressions (N))) + or else Nkind (First (Expressions (N))) = N_Integer_Literal) + then + return True; + else + return False; + end if; + end Safe_Left_Hand_Side; + + -- Local variables Tmp : Entity_Id; -- Holds the temporary aggregate value @@ -5230,9 +5262,9 @@ package body Exp_Aggr is -- In the remaining cases the aggregate is the RHS of an assignment elsif Maybe_In_Place_OK - and then Is_Entity_Name (Name (Parent (N))) + and then Safe_Left_Hand_Side (Name (Parent (N))) then - Tmp := Entity (Name (Parent (N))); + Tmp := Name (Parent (N)); if Etype (Tmp) /= Etype (N) then Apply_Length_Check (N, Etype (Tmp)); @@ -5246,16 +5278,6 @@ package body Exp_Aggr is end if; elsif Maybe_In_Place_OK - and then Nkind (Name (Parent (N))) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Name (Parent (N)))) - then - Tmp := Name (Parent (N)); - - if Etype (Tmp) /= Etype (N) then - Apply_Length_Check (N, Etype (Tmp)); - end if; - - elsif Maybe_In_Place_OK and then Nkind (Name (Parent (N))) = N_Slice and then Safe_Slice_Assignment (N) then diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 50af15c..6ef11bb 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3890,8 +3890,23 @@ package body Sem_Aggr is elsif No (Typech) then Typech := Base_Type (Etype (Component)); + -- AI05-0199: In Ada2012, several components of anonymous + -- access types can appear in a choice list, as long as the + -- designated types match. + elsif Typech /= Base_Type (Etype (Component)) then - if not Box_Present (Parent (Selectr)) then + if Ada_Version >= Ada_12 + and then Ekind (Typech) = E_Anonymous_Access_Type + and then + Ekind (Etype (Component)) = E_Anonymous_Access_Type + and then Base_Type (Designated_Type (Typech)) = + Base_Type (Designated_Type (Etype (Component))) + and then + Subtypes_Statically_Match (Typech, (Etype (Component))) + then + null; + + elsif not Box_Present (Parent (Selectr)) then Error_Msg_N ("components in choice list must have same type", Selectr); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a583dde..bfa1373 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1859,7 +1859,7 @@ package body Sem_Ch13 is return; end if; - if Compile_Time_Known_Value (Expr) + if Is_OK_Static_Expression (Expr) and then Expr_Value (Expr) = 0 then Set_No_Pool_Assigned (Btype); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9dafd64..56a53be 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4296,15 +4296,7 @@ package body Sem_Res is -- Check for allocation from an empty storage pool if No_Pool_Assigned (Typ) then - declare - Loc : constant Source_Ptr := Sloc (N); - begin - Error_Msg_N ("?allocation from empty storage pool!", N); - Error_Msg_N ("\?Storage_Error will be raised at run time!", N); - Insert_Action (N, - Make_Raise_Storage_Error (Loc, - Reason => SE_Empty_Storage_Pool)); - end; + Error_Msg_N ("allocation from empty storage pool!", N); -- If the context is an unchecked conversion, as may happen within -- an inlined subprogram, the allocator is being resolved with its -- 2.7.4