From: Yannick Moy <m...@adacore.com> Function Sem_Aux.Is_Limited_View returns whether the type is "inherently limited" in a slightly different way from the "immutably limited" definition in Ada 2012. Rename for clarity.
gcc/ada/ * exp_aggr.adb: Apply the renaming. * exp_ch3.adb: Same. * exp_ch4.adb: Same. * exp_ch6.adb: Same. * exp_ch7.adb: Same. * exp_util.adb: Same. * freeze.adb: Same. * sem_aggr.adb: Same. * sem_attr.adb: Same. * sem_aux.adb: Alphabetize Is_Limited_Type. Rename. * sem_aux.ads: Same. * sem_ch3.adb: Apply the renaming. * sem_ch6.adb: Same. * sem_ch8.adb: Same. * sem_prag.adb: Same. * sem_res.adb: Same. * sem_util.adb: Same. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 10 ++-- gcc/ada/exp_ch3.adb | 6 +-- gcc/ada/exp_ch4.adb | 2 +- gcc/ada/exp_ch6.adb | 4 +- gcc/ada/exp_ch7.adb | 4 +- gcc/ada/exp_util.adb | 4 +- gcc/ada/freeze.adb | 5 +- gcc/ada/sem_aggr.adb | 2 +- gcc/ada/sem_attr.adb | 4 +- gcc/ada/sem_aux.adb | 116 +++++++++++++++++++++---------------------- gcc/ada/sem_aux.ads | 16 +++--- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 6 +-- gcc/ada/sem_ch8.adb | 2 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 4 +- gcc/ada/sem_util.adb | 10 ++-- 17 files changed, 101 insertions(+), 98 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 340c8c68465..319254dfd63 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -945,7 +945,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_Limited_View (Component_Type (Typ)) then + if Is_Inherently_Limited_Type (Component_Type (Typ)) then return False; end if; @@ -3026,7 +3026,7 @@ package body Exp_Aggr is -- call will be generated by Make_Tag_Ctrl_Assignment). if Needs_Finalization (Init_Typ) - and then not Is_Limited_View (Init_Typ) + and then not Is_Inherently_Limited_Type (Init_Typ) then Set_No_Finalize_Actions (First (Assign)); else @@ -8166,7 +8166,9 @@ package body Exp_Aggr is -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. - elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then + elsif Ada_Version >= Ada_2005 + and then Is_Inherently_Limited_Type (Typ) + then if Nkind (Parent (N)) not in N_Component_Association | N_Object_Declaration then @@ -8400,7 +8402,7 @@ package body Exp_Aggr is -- of their individual elements will receive an adjustment of its own. if Finalization_OK - and then not Is_Limited_View (Comp_Typ) + and then not Is_Inherently_Limited_Type (Comp_Typ) and then not (Is_Array_Type (Etype (N)) and then Is_Array_Type (Comp_Typ) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0217f8d7eb0..511d4c09b22 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7255,7 +7255,7 @@ package body Exp_Ch3 is else pragma Assert (Is_Definite_Subtype (Typ) or else (Has_Unknown_Discriminants (Typ) - and then Is_Limited_View (Typ))); + and then Is_Inherently_Limited_Type (Typ))); Alloc_Typ := Typ; end if; @@ -7692,7 +7692,7 @@ package body Exp_Ch3 is -- and attached to the finalization list. if Needs_Finalization (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) then Adj_Call := Make_Adjust_Call ( @@ -8137,7 +8137,7 @@ package body Exp_Ch3 is -- the object declaration into a renaming declaration. if Needs_Finalization (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) and then Nkind (Expr_Q) /= N_Function_Call and then not Rewrite_As_Renaming then diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ec95d8b830b..f04ac615be9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -941,7 +941,7 @@ package body Exp_Ch4 is if Needs_Finalization (DesigT) and then Needs_Finalization (T) - and then not Is_Limited_View (T) + and then not Is_Inherently_Limited_Type (T) and then not Aggr_In_Place and then Nkind (Exp) /= N_Function_Call and then not For_Special_Return_Object (N) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1a2a027265c..d4802402670 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6913,7 +6913,7 @@ package body Exp_Ch6 is Set_Enclosing_Sec_Stack_Return (N); end if; - elsif Is_Limited_View (R_Type) then + elsif Is_Inherently_Limited_Type (R_Type) then null; -- No copy needed for thunks returning interface type objects since @@ -8219,7 +8219,7 @@ package body Exp_Ch6 is -- of a function with a limited interface result, where the function -- may return objects of nonlimited descendants. - return Is_Limited_View (Typ) + return Is_Inherently_Limited_Type (Typ) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; end Is_Build_In_Place_Result_Type; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 00b7692c964..369f0b07999 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -788,7 +788,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); - if not Is_Limited_View (Typ) then + if not Is_Inherently_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, @@ -3814,7 +3814,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - if not Is_Limited_View (Typ) then + if not Is_Inherently_Limited_Type (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 1aff5a062ce..3e8d5997949 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5927,7 +5927,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_Limited_View (Exp_Typ) + elsif Is_Inherently_Limited_Type (Exp_Typ) and then (Is_Class_Wide_Type (Exp_Typ) or else Is_Interface (Exp_Typ) @@ -12363,7 +12363,7 @@ package body Exp_Util is if Ada_Version >= Ada_2005 and then Nkind (Exp) = N_Function_Call - and then Is_Limited_View (Etype (Exp)) + and then Is_Inherently_Limited_Type (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 efd95d757c4..61099138814 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -798,7 +798,7 @@ package body Freeze is -- limited objects. if Present (Init) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) then -- Capture initialization value at point of declaration, and make -- explicit assignment legal, because object may be a constant. @@ -7446,7 +7446,8 @@ package body Freeze is -- be an array type, or a nonlimited record type). if Has_Private_Declaration (E) then - if (not Is_Record_Type (E) or else not Is_Limited_View (E)) + if (not Is_Record_Type (E) + or else not Is_Inherently_Limited_Type (E)) and then not Is_Private_Type (E) then Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 597c3ce2dd1..36db7987d91 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4305,7 +4305,7 @@ package body Sem_Aggr is -- extensions, and maybe for nondiscriminated types. -- This is wrong for limited, but those were wrong already. - if not Is_Limited_View (A_Type) + if not Is_Inherently_Limited_Type (A_Type) and then Is_Build_In_Place_Function_Call (A) then Transform_BIP_Assignment (A_Type); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3eba3a29362..531bc112c91 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4981,7 +4981,7 @@ package body Sem_Attr is -- Loop_Entry must create a constant initialized by the evaluated -- prefix. - if Is_Limited_View (Etype (P)) then + if Is_Inherently_Limited_Type (Etype (P)) then Error_Attr_P ("prefix of attribute % cannot be limited"); end if; @@ -7357,7 +7357,7 @@ package body Sem_Attr is then Error_Attr_P ("prefix of attribute % must be a record or array"); - elsif Is_Limited_View (P_Type) then + elsif Is_Inherently_Limited_Type (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 e7e096fa1cf..c8fbdb0b117 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1017,55 +1017,6 @@ package body Sem_Aux is end if; end Is_Generic_Formal; - ------------------------------- - -- Is_Immutably_Limited_Type -- - ------------------------------- - - function Is_Immutably_Limited_Type (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 - return False; - end if; - - elsif Is_Concurrent_Type (Btype) then - return True; - - else - return False; - end if; - end Is_Immutably_Limited_Type; - --------------------- -- Is_Limited_Type -- --------------------- @@ -1148,11 +1099,60 @@ package body Sem_Aux is end if; end Is_Limited_Type; - --------------------- - -- Is_Limited_View -- - --------------------- + ------------------------------- + -- Is_Immutably_Limited_Type -- + ------------------------------- + + function Is_Immutably_Limited_Type (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 + return False; + end if; + + elsif Is_Concurrent_Type (Btype) then + return True; + + else + return False; + end if; + end Is_Immutably_Limited_Type; + + -------------------------------- + -- Is_Inherently_Limited_Type -- + -------------------------------- - function Is_Limited_View (Ent : Entity_Id) return Boolean is + function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Available_View (Base_Type (Ent)); begin @@ -1192,7 +1192,7 @@ package body Sem_Aux is if No (Utyp) then return False; else - return Is_Limited_View (Utyp); + return Is_Inherently_Limited_Type (Utyp); end if; end; end if; @@ -1210,7 +1210,7 @@ package body Sem_Aux is -- of a type that is not inherently limited. if Is_Class_Wide_Type (Btype) then - return Is_Limited_View (Root_Type (Btype)); + return Is_Inherently_Limited_Type (Root_Type (Btype)); else declare @@ -1227,7 +1227,7 @@ package body Sem_Aux is -- limited interfaces. if not Is_Interface (Etype (C)) - and then Is_Limited_View (Etype (C)) + and then Is_Inherently_Limited_Type (Etype (C)) then return True; end if; @@ -1240,12 +1240,12 @@ package body Sem_Aux is end if; elsif Is_Array_Type (Btype) then - return Is_Limited_View (Component_Type (Btype)); + return Is_Inherently_Limited_Type (Component_Type (Btype)); else return False; end if; - end Is_Limited_View; + end Is_Inherently_Limited_Type; ---------------------- -- Nearest_Ancestor -- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index a490fd3edd1..5447fa8d0d3 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -311,13 +311,20 @@ package Sem_Aux is -- used to set the visibility of generic formals of a generic package -- declared with a box or with partial parameterization. + function Is_Limited_Type (Ent : Entity_Id) return Boolean; + -- 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). This older routine overlaps with the next ones, this + -- should be cleaned up??? + 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, e.g. when -- checking the legality of an access to the current instance. - function Is_Limited_View (Ent : Entity_Id) return Boolean; + function Is_Inherently_Limited_Type (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". @@ -327,13 +334,6 @@ package Sem_Aux is -- for other types, too. This is also used for identifying pure procedures -- whose calls should not be eliminated (RM 10.2.1(18/2)). - function Is_Limited_Type (Ent : Entity_Id) return Boolean; - -- 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). 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 -- which constraints and predicates are inherited. There is no simple link diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a38275133f4..ca60850a2b3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11636,7 +11636,7 @@ package body Sem_Ch3 is -- or else be a partial view. if Nkind (Discriminant_Type (D)) = N_Access_Definition then - if Is_Limited_View (Current_Scope) + if Is_Inherently_Limited_Type (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 3dd265901dd..4f2521a1dfb 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1065,7 +1065,7 @@ package body Sem_Ch6 is -- get generated elsewhere. if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) - and then Is_Limited_View (Etype (Scope_Id)) + and then Is_Inherently_Limited_Type (Etype (Scope_Id)) and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level) > Subprogram_Access_Level (Scope_Id) then @@ -6662,7 +6662,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_Limited_View (R_Type) then + if Is_Inherently_Limited_Type (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; @@ -6682,7 +6682,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_Limited_View (R_Type) then + elsif Is_Inherently_Limited_Type (R_Type) then Error_Msg_N ("return by reference not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 7f6accd7768..88be8aeaff2 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1143,7 +1143,7 @@ package body Sem_Ch8 is -- there is no copy involved and no performance hit. if Nkind (Nam) = N_Function_Call - and then Is_Limited_View (Etype (Nam)) + and then Is_Inherently_Limited_Type (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 b9172cd9719..c49cb278c59 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -24027,7 +24027,7 @@ package body Sem_Prag is -- in Freeze_Entity). if Is_Record_Type (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (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 e7b0b8ba7e1..fa1365c2641 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5451,7 +5451,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_Limited_View (Desig_T) + if Is_Inherently_Limited_Type (Desig_T) and then Nkind (Expression (E)) = N_Function_Call then declare @@ -5716,7 +5716,7 @@ package body Sem_Res is if Ada_Version >= Ada_2012 and then Is_Limited_Type (Desig_T) - and then not Is_Limited_View (Scope (Discr)) + and then not Is_Inherently_Limited_Type (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 afe69da6a84..3d870b1049c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1879,7 +1879,7 @@ package body Sem_Util is return False; end if; - return Is_Definite_Subtype (T) and then Is_Limited_View (T); + return Is_Definite_Subtype (T) and then Is_Inherently_Limited_Type (T); end Build_Default_Subtype_OK; -------------------------------------------- @@ -6190,7 +6190,7 @@ package body Sem_Util is -- In Ada 95, limited types are returned by reference, but not if the -- convention is other than Ada. - elsif Is_Limited_View (Typ) + elsif Is_Inherently_Limited_Type (Typ) and then not Has_Foreign_Convention (Func) then Set_Returns_By_Ref (Func); @@ -15325,7 +15325,7 @@ package body Sem_Util is -- statement is aliased if its type is immutably limited. or else (Is_Return_Object (E) - and then Is_Limited_View (Etype (E))) + and then Is_Inherently_Limited_Type (Etype (E))) -- The current instance of a limited type is aliased, so -- we want to allow uses of T'Access in the init proc for @@ -15334,7 +15334,7 @@ package body Sem_Util is or else (Is_Formal (E) and then Chars (E) = Name_uInit - and then Is_Limited_View (Etype (E))); + and then Is_Inherently_Limited_Type (Etype (E))); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj))); @@ -22592,7 +22592,7 @@ package body Sem_Util is begin if Is_Record_Type (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) and then Has_Defaulted_Discriminants (Typ) then -- Loop through the components, looking for an array whose upper -- 2.42.0