From 51245e2db08facc4d1ce09aa57782b43526c8055 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 17 Oct 2013 13:54:29 +0000 Subject: [PATCH] sem_aux.ads, [...] (Is_Immutably_Limited_Type): Make predicate compatible with Ada 2012 definition 2013-10-17 Ed Schonberg * sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make predicate compatible with Ada 2012 definition (Is_Limited_View): New name for previous version of Is_Immutably_Limited_Type. Predicate is true for an untagged record type with a limited component. * exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb, sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb, sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View * freeze.adb Use Is_Immutably_Limited_Type to check the legality of references to the current instance, Is_Limited_View otherwise. From-SVN: r203762 --- gcc/ada/ChangeLog | 13 ++++ gcc/ada/exp_aggr.adb | 6 +- gcc/ada/exp_ch3.adb | 6 +- gcc/ada/exp_ch4.adb | 2 +- gcc/ada/exp_ch6.adb | 12 ++-- gcc/ada/exp_ch7.adb | 4 +- gcc/ada/exp_util.adb | 4 +- gcc/ada/freeze.adb | 2 +- gcc/ada/sem_attr.adb | 4 +- gcc/ada/sem_aux.adb | 141 ++++++++++++++++++++++++++++++------------- gcc/ada/sem_aux.ads | 9 ++- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 10 +-- gcc/ada/sem_ch8.adb | 2 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 4 +- gcc/ada/sem_util.adb | 2 +- 17 files changed, 151 insertions(+), 74 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9f55cad9753..0580bf2d972 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2013-10-17 Ed Schonberg + + * sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make + predicate compatible with Ada 2012 definition + (Is_Limited_View): New name for previous version of + Is_Immutably_Limited_Type. Predicate is true for an untagged + record type with a limited component. + * exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb, + sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb, + sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View + * freeze.adb Use Is_Immutably_Limited_Type to check the legality + of references to the current instance, Is_Limited_View otherwise. + 2013-10-17 Hristian Kirtchev * sem_ch13.adb (Analyze_Aspect_Specifications): Flag aspect diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9d72485773b..20a82b1d7f1 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -628,7 +628,7 @@ package body Exp_Aggr is -- If component is limited, aggregate must be expanded because each -- component assignment must be built in place. - if Is_Immutably_Limited_Type (Component_Type (Typ)) then + if Is_Limited_View (Component_Type (Typ)) then return False; end if; @@ -3347,7 +3347,7 @@ package body Exp_Aggr is -- in place within the caller's scope). or else - (Is_Immutably_Limited_Type (Typ) + (Is_Limited_View (Typ) and then (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement or else Nkind (Parent_Node) = N_Simple_Return_Statement)) @@ -5668,7 +5668,7 @@ package body Exp_Aggr is -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. - if Ada_Version >= Ada_2005 and then Is_Immutably_Limited_Type (Typ) then + if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then if not Nkind_In (Parent (N), N_Object_Declaration, N_Component_Association) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e7d0cb0ac21..f1ab0c5e765 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1893,7 +1893,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) - and then not Is_Immutably_Limited_Type (Typ) + and then not Is_Limited_View (Typ) then Append_To (Res, Make_Adjust_Call @@ -5310,7 +5310,7 @@ package body Exp_Ch3 is -- creating the object (via allocator) and initializing it. if Is_Return_Object (Def_Id) - and then Is_Immutably_Limited_Type (Typ) + and then Is_Limited_View (Typ) then null; @@ -5578,7 +5578,7 @@ package body Exp_Ch3 is -- renaming declaration. if Needs_Finalization (Typ) - and then not Is_Immutably_Limited_Type (Typ) + and then not Is_Limited_View (Typ) and then not Rewrite_As_Renaming then Insert_Action_After (Init_After, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8df4576e1ef..00da14726b1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1244,7 +1244,7 @@ package body Exp_Ch4 is -- want to Adjust. if not Aggr_In_Place - and then not Is_Immutably_Limited_Type (T) + and then not Is_Limited_View (T) then Insert_Action (N, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 542126773a3..adc0987fc44 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3947,7 +3947,7 @@ package body Exp_Ch6 is -- result from the secondary stack. if Needs_Finalization (Etype (Subp)) then - if not Is_Immutably_Limited_Type (Etype (Subp)) + if not Is_Limited_View (Etype (Subp)) and then (No (First_Formal (Subp)) or else @@ -7100,7 +7100,7 @@ package body Exp_Ch6 is then null; - elsif Is_Immutably_Limited_Type (Typ) then + elsif Is_Limited_View (Typ) then Set_Returns_By_Ref (Spec_Id); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then @@ -7702,7 +7702,7 @@ package body Exp_Ch6 is -- the type of the expression may be. if not Comes_From_Extended_Return_Statement (N) - and then Is_Immutably_Limited_Type (Etype (Expression (N))) + and then Is_Limited_View (Etype (Expression (N))) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L @@ -7781,7 +7781,7 @@ package body Exp_Ch6 is -- type that requires special processing (indicated by the fact that -- it requires a cleanup scope for the secondary stack case). - if Is_Immutably_Limited_Type (Exptyp) + if Is_Limited_View (Exptyp) or else Is_Limited_Interface (Exptyp) then null; @@ -9572,7 +9572,7 @@ package body Exp_Ch6 is -- may return objects of nonlimited descendants. else - return Is_Immutably_Limited_Type (Etype (E)) + return Is_Limited_View (Etype (E)) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; end if; @@ -9813,7 +9813,7 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Etype (Subp); Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Immutably_Limited_Type (Typ) then + if Is_Limited_View (Typ) then Set_Returns_By_Ref (Subp); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 9d76d2c9f01..8449f6aba1f 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -432,7 +432,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); - if not Is_Immutably_Limited_Type (Typ) then + if not Is_Limited_View (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, @@ -3227,7 +3227,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - if not Is_Immutably_Limited_Type (Typ) then + if not Is_Limited_View (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1d8df6b2c66..2e0185ea7fa 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2227,7 +2227,7 @@ package body Exp_Util is -- function being called is build-in-place. This will have to be revised -- when build-in-place functions are generalized to other types. - elsif Is_Immutably_Limited_Type (Exp_Typ) + elsif Is_Limited_View (Exp_Typ) and then (Is_Class_Wide_Type (Exp_Typ) or else Is_Interface (Exp_Typ) @@ -7081,7 +7081,7 @@ package body Exp_Util is if Ada_Version >= Ada_2005 and then Nkind (Exp) = N_Function_Call - and then Is_Immutably_Limited_Type (Etype (Exp)) + and then Is_Limited_View (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration then declare diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f9691d726d3..a554eceaf3e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4786,7 +4786,7 @@ package body Freeze is if Has_Private_Declaration (E) then if (not Is_Record_Type (E) - or else not Is_Immutably_Limited_Type (E)) + or else not Is_Limited_View (E)) and then not Is_Private_Type (E) then Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 5234d47db6e..231d0b2e296 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3893,7 +3893,7 @@ package body Sem_Attr is -- Loop_Entry must create a constant initialized by the evaluated -- prefix. - if Is_Immutably_Limited_Type (Etype (P)) then + if Is_Limited_View (Etype (P)) then Error_Attr_P ("prefix of attribute % cannot be limited"); end if; @@ -5994,7 +5994,7 @@ package body Sem_Attr is then Error_Attr_P ("prefix of attribute % must be a record or array"); - elsif Is_Immutably_Limited_Type (P_Type) then + elsif Is_Limited_View (P_Type) then Error_Attr ("prefix of attribute % cannot be limited", N); elsif Nkind (E1) /= N_Aggregate then diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4e6fc1c7c2e..24470edfafc 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -813,6 +813,105 @@ package body Sem_Aux is end if; end Is_Generic_Formal; + --------------------- + -- Is_Limited_View -- + --------------------- + + function Is_Limited_View (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Available_View (Base_Type (Ent)); + + begin + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type + and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration + then + return not In_Package_Body (Scope ((Btype))); + + elsif Is_Private_Type (Btype) then + + -- AI05-0063: A type derived from a limited private formal type is + -- not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then + return False; + + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Btype)); + + else + return False; + end if; + + else + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Limited_View (Utyp); + end if; + end; + end if; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + + -- Note that we return True for all limited interfaces, even though + -- (unsynchronized) limited interfaces can have descendants that are + -- nonlimited, because this is a predicate on the type itself, and + -- things like functions with limited interface results need to be + -- handled as build in place even though they might return objects + -- of a type that is not inherently limited. + + if Is_Class_Wide_Type (Btype) then + return Is_Limited_View (Root_Type (Btype)); + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + + -- Don't consider components with interface types (which can + -- only occur in the case of a _parent component anyway). + -- They don't have any components, plus it would cause this + -- function to return true for nonlimited types derived from + -- limited interfaces. + + if not Is_Interface (Etype (C)) + and then Is_Limited_View (Etype (C)) + then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Limited_View (Component_Type (Btype)); + + else + return False; + end if; + end Is_Limited_View; + ------------------------------- -- Is_Immutably_Limited_Type -- ------------------------------- @@ -865,48 +964,6 @@ package body Sem_Aux is elsif Is_Concurrent_Type (Btype) then return True; - elsif Is_Record_Type (Btype) then - - -- Note that we return True for all limited interfaces, even though - -- (unsynchronized) limited interfaces can have descendants that are - -- nonlimited, because this is a predicate on the type itself, and - -- things like functions with limited interface results need to be - -- handled as build in place even though they might return objects - -- of a type that is not inherently limited. - - if Is_Class_Wide_Type (Btype) then - return Is_Immutably_Limited_Type (Root_Type (Btype)); - - else - declare - C : Entity_Id; - - begin - C := First_Component (Btype); - while Present (C) loop - - -- Don't consider components with interface types (which can - -- only occur in the case of a _parent component anyway). - -- They don't have any components, plus it would cause this - -- function to return true for nonlimited types derived from - -- limited interfaces. - - if not Is_Interface (Etype (C)) - and then Is_Immutably_Limited_Type (Etype (C)) - then - return True; - end if; - - C := Next_Component (C); - end loop; - end; - - return False; - end if; - - elsif Is_Array_Type (Btype) then - return Is_Immutably_Limited_Type (Component_Type (Btype)); - else return False; end if; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index a4b1a673bce..0e2818e7bb5 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -281,6 +281,12 @@ package Sem_Aux is -- so. False for other type entities, or any entities that are not types. function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; + -- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the + -- following predicate in that an untagged record with immutably limited + -- components is NOT by itself immutably limited. This matters, eg. when + -- checking the legality of an access to the current instance. + + function Is_Limited_View (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". @@ -294,7 +300,8 @@ package Sem_Aux is -- Ent is any entity. Returns true if Ent is a limited type (limited -- private type, limited interface type, task type, protected type, -- composite containing a limited component, or a subtype of any of - -- these types). + -- these types). This older routine overlaps with the previous one, this + -- should be cleaned up? function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; -- Given a subtype Typ, this function finds out the nearest ancestor from diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 50ef808e013..3dffc053d6a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9556,7 +9556,7 @@ package body Sem_Ch3 is -- or else be a partial view. if Nkind (Discriminant_Type (D)) = N_Access_Definition then - if Is_Immutably_Limited_Type (Current_Scope) + if Is_Limited_View (Current_Scope) or else (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration and then Limited_Present (Parent (Current_Scope))) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1ad5f2d525e..3b5eee1680b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -586,7 +586,7 @@ package body Sem_Ch6 is ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); - if Is_Immutably_Limited_Type (R_Type) then + if Is_Limited_View (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; @@ -606,7 +606,7 @@ package body Sem_Ch6 is ("return of limited object not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); - elsif Is_Immutably_Limited_Type (R_Type) then + elsif Is_Limited_View (R_Type) then Error_Msg_N ("return by reference not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); @@ -880,7 +880,7 @@ package body Sem_Ch6 is ("aliased only allowed for limited" & " return objects in Ada 2012?", N); - elsif not Is_Immutably_Limited_Type (R_Type) then + elsif not Is_Limited_View (R_Type) then Error_Msg_N ("aliased only allowed for limited" & " return objects", N); end if; @@ -963,7 +963,7 @@ package body Sem_Ch6 is -- check the static cases. if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) - and then Is_Immutably_Limited_Type (Etype (Scope_Id)) + and then Is_Limited_View (Etype (Scope_Id)) and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then @@ -6593,7 +6593,7 @@ package body Sem_Ch6 is Typ : constant Entity_Id := Etype (Designator); Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Immutably_Limited_Type (Typ) then + if Is_Limited_View (Typ) then Set_Returns_By_Ref (Designator); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 34b52593db5..61d97667840 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -883,7 +883,7 @@ package body Sem_Ch8 is -- there is no copy involved and no performance hit. if Nkind (Nam) = N_Function_Call - and then Is_Immutably_Limited_Type (Etype (Nam)) + and then Is_Limited_View (Etype (Nam)) and then not Is_Constrained (Etype (Nam)) and then Comes_From_Source (N) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1193a9cc349..62aa1b1ea04 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17678,7 +17678,7 @@ package body Sem_Prag is -- in Freeze_Entity). if Is_Record_Type (Typ) - and then not Is_Immutably_Limited_Type (Typ) + and then not Is_Limited_View (Typ) then Error_Pragma ("pragma% can only apply to explicitly limited record type"); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8b610126159..805dc68a923 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4356,7 +4356,7 @@ package body Sem_Res is -- of the current b-i-p implementation to unify the handling for -- multiple kinds of storage pools). ??? - if Is_Immutably_Limited_Type (Desig_T) + if Is_Limited_View (Desig_T) and then Nkind (Expression (E)) = N_Function_Call then declare @@ -4595,7 +4595,7 @@ package body Sem_Res is if Ada_Version >= Ada_2012 and then Is_Limited_Type (Desig_T) - and then not Is_Immutably_Limited_Type (Scope (Discr)) + and then not Is_Limited_View (Scope (Discr)) then Error_Msg_N ("only immutably limited types can have anonymous " diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d2d8a41554c..f0dcd0333c3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8145,7 +8145,7 @@ package body Sem_Util is -- statement is aliased if its type is immutably limited. or else (Is_Return_Object (E) - and then Is_Immutably_Limited_Type (Etype (E))); + and then Is_Limited_View (Etype (E))); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj)));