From: Samuel Tardieu Date: Sun, 9 Dec 2007 11:07:54 +0000 (+0000) Subject: re PR ada/34366 (Legal program rejected, various anonymous access-to-subprogram types... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5320014a061cd33f2e36baa9ec17a62519f0f8bd;p=gcc.git re PR ada/34366 (Legal program rejected, various anonymous access-to-subprogram types, Ada 2005) gcc/ada/ PR ada/34366 * sem_ch3.adb (Designates_T): New function. (Mentions_T): Factor reusable part of the logic into Designates_T. Consider non-access parameters and access and non-access result. (Check_Anonymous_Access_Components): Set ekind of anonymous access to E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type. * einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type. gcc/testsuite/ PR ada/34366 * gnat.dg/enclosing_record_reference.ads, gnat.dg/enclosing_record_reference.adb: New test. From-SVN: r130720 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 12065792f15..cf8b613d0ae 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2007-12-09 Samuel Tardieu + + PR ada/34366 + * sem_ch3.adb (Designates_T): New function. + (Mentions_T): Factor reusable part of the logic into Designates_T. + Consider non-access parameters and access and non-access result. + (Check_Anonymous_Access_Components): Set ekind of anonymous access to + E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type. + + * einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type. + 2007-12-07 Ludovic Brenta PR ada/34361 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8e659f12ab3..a24995c169f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3786,7 +3786,9 @@ package Einfo is E_Anonymous_Access_Subprogram_Type, -- An anonymous access to subprogram type, created by an access to - -- subprogram declaration. + -- subprogram declaration, or generated for a current instance of + -- a type name appearing within a component definition that has an + -- anonymous access to subprogram type. E_Access_Protected_Subprogram_Type, -- An access to a protected subprogram, created by the corresponding diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c16b4066d84..711023102da 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15983,12 +15983,15 @@ package body Sem_Ch3 is -- This is done only once, and only if there is no previous partial -- view of the type. + function Designates_T (Subt : Node_Id) return Boolean; + -- Check whether a node designates the enclosing record type + function Mentions_T (Acc_Def : Node_Id) return Boolean; -- Check whether an access definition includes a reference to - -- the enclosing record type. The reference can be a subtype - -- mark in the access definition itself, or a 'Class attribute - -- reference, or recursively a reference appearing in a parameter - -- type in an access_to_subprogram definition. + -- the enclosing record type. The reference can be a subtype mark + -- in the access definition itself, a 'Class attribute reference, or + -- recursively a reference appearing in a parameter specification + -- or result definition of an access_to_subprogram definition. -------------------------------------- -- Build_Incomplete_Type_Declaration -- @@ -16071,12 +16074,12 @@ package body Sem_Ch3 is end if; end Build_Incomplete_Type_Declaration; - ---------------- - -- Mentions_T -- - ---------------- + ------------------ + -- Designates_T -- + ------------------ + + function Designates_T (Subt : Node_Id) return Boolean is - function Mentions_T (Acc_Def : Node_Id) return Boolean is - Subt : Node_Id; Type_Id : constant Name_Id := Chars (Typ); function Names_T (Nam : Node_Id) return Boolean; @@ -16113,75 +16116,94 @@ package body Sem_Ch3 is end if; end Names_T; - -- Start of processing for Mentions_T + -- Start of processing for Designates_T begin - if No (Access_To_Subprogram_Definition (Acc_Def)) then - Subt := Subtype_Mark (Acc_Def); - - if Nkind (Subt) = N_Identifier then - return Chars (Subt) = Type_Id; + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Type_Id; -- Reference can be through an expanded name which has not been -- analyzed yet, and which designates enclosing scopes. - elsif Nkind (Subt) = N_Selected_Component then - if Names_T (Subt) then - return True; - - -- Otherwise it must denote an entity that is already visible. - -- The access definition may name a subtype of the enclosing - -- type, if there is a previous incomplete declaration for it. - - else - Find_Selected_Component (Subt); - return - Is_Entity_Name (Subt) - and then Scope (Entity (Subt)) = Current_Scope - and then (Chars (Base_Type (Entity (Subt))) = Type_Id - or else - (Is_Class_Wide_Type (Entity (Subt)) - and then - Chars (Etype (Base_Type (Entity (Subt)))) - = Type_Id)); - end if; + elsif Nkind (Subt) = N_Selected_Component then + if Names_T (Subt) then + return True; - -- A reference to the current type may appear as the prefix of - -- a 'Class attribute. + -- Otherwise it must denote an entity that is already visible. + -- The access definition may name a subtype of the enclosing + -- type, if there is a previous incomplete declaration for it. - elsif Nkind (Subt) = N_Attribute_Reference - and then Attribute_Name (Subt) = Name_Class - then - return Names_T (Prefix (Subt)); else - return False; + Find_Selected_Component (Subt); + return + Is_Entity_Name (Subt) + and then Scope (Entity (Subt)) = Current_Scope + and then + (Chars (Base_Type (Entity (Subt))) = Type_Id + or else + (Is_Class_Wide_Type (Entity (Subt)) + and then + Chars (Etype (Base_Type (Entity (Subt)))) + = Type_Id)); end if; + -- A reference to the current type may appear as the prefix of + -- a 'Class attribute. + + elsif Nkind (Subt) = N_Attribute_Reference + and then Attribute_Name (Subt) = Name_Class + then + return Names_T (Prefix (Subt)); + else - -- Component is an access_to_subprogram: examine its formals + return False; + end if; + end Designates_T; - declare - Param_Spec : Node_Id; + ---------------- + -- Mentions_T -- + ---------------- - begin - Param_Spec := - First - (Parameter_Specifications - (Access_To_Subprogram_Definition (Acc_Def))); - while Present (Param_Spec) loop - if Nkind (Parameter_Type (Param_Spec)) - = N_Access_Definition - and then Mentions_T (Parameter_Type (Param_Spec)) - then - return True; - end if; + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Param_Spec : Node_Id; - Next (Param_Spec); - end loop; + Acc_Subprg : constant Node_Id := + Access_To_Subprogram_Definition (Acc_Def); - return False; - end; + begin + if No (Acc_Subprg) then + return Designates_T (Subtype_Mark (Acc_Def)); end if; + + -- Component is an access_to_subprogram: examine its formals, + -- and result definition in the case of an access_to_function. + + Param_Spec := First (Parameter_Specifications (Acc_Subprg)); + while Present (Param_Spec) loop + if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition + and then Mentions_T (Parameter_Type (Param_Spec)) + then + return True; + + elsif Designates_T (Parameter_Type (Param_Spec)) then + return True; + end if; + + Next (Param_Spec); + end loop; + + if Nkind (Acc_Subprg) = N_Access_Function_Definition then + if Nkind (Result_Definition (Acc_Subprg)) = + N_Access_Definition + then + return Mentions_T (Result_Definition (Acc_Subprg)); + else + return Designates_T (Result_Definition (Acc_Subprg)); + end if; + end if; + + return False; + end Mentions_T; -- Start of processing for Check_Anonymous_Access_Components @@ -16279,7 +16301,13 @@ package body Sem_Ch3 is Make_Component_Definition (Loc, Subtype_Indication => New_Occurrence_Of (Anon_Access, Loc))); - Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + + if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then + Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); + else + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + end if; + Set_Is_Local_Anonymous_Access (Anon_Access); end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c56d1efa7ce..8127e050fde 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-12-09 Samuel Tardieu + + PR ada/34366 + * gnat.dg/enclosing_record_reference.ads, + gnat.dg/enclosing_record_reference.adb: New test. + 2007-12-09 Paul Thomas PR fortran/32129 diff --git a/gcc/testsuite/gnat.dg/enclosing_record_reference.adb b/gcc/testsuite/gnat.dg/enclosing_record_reference.adb new file mode 100644 index 00000000000..69c85bcc66e --- /dev/null +++ b/gcc/testsuite/gnat.dg/enclosing_record_reference.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +package body Enclosing_Record_Reference is + + R: aliased T; + + function F1 (x: integer) return T is begin return R; end; + function F2 (x: T) return integer is begin return 0; end; + function F3 (x: T) return T is begin return R; end; + function F4 (x: integer) return access T is begin return R'access; end; + function F5 (x: access T) return integer is begin return 0; end; + function F6 (x: access T) return access T is begin return R'access; end; + function F7 (x: T) return access T is begin return R'access; end; + function F8 (x: access T) return T is begin return R; end; + +begin + R.F1 := F1'Access; + R.F2 := F2'Access; + R.F3 := F3'Access; + R.F4 := F4'Access; + R.F5 := F5'Access; + R.F6 := F6'Access; + R.F7 := F7'Access; + R.F8 := F8'Access; +end Enclosing_Record_Reference; diff --git a/gcc/testsuite/gnat.dg/enclosing_record_reference.ads b/gcc/testsuite/gnat.dg/enclosing_record_reference.ads new file mode 100644 index 00000000000..6573b1d5434 --- /dev/null +++ b/gcc/testsuite/gnat.dg/enclosing_record_reference.ads @@ -0,0 +1,15 @@ +package Enclosing_Record_Reference is + pragma elaborate_body; + + type T is record + F1: access function(x: integer) return T; + F2: access function(x: T) return integer; --?? + F3: access function(x: T) return T; --?? + F4: access function(x: integer) return access T; --?? + F5: access function(x: access T) return integer; + F6: access function(x: access T) return access T; + F7: access function(x: T) return access T; --?? + F8: access function(x: access T) return T; + end record; + +end Enclosing_Record_Reference;