From 46413d9ea9ce2b3d5b59cc141842fa2d84d74b69 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 30 Jan 2015 16:02:09 +0100 Subject: [PATCH] [multiple changes] 2015-01-30 Gary Dismukes * sem_attr.adb (Declared_Within_Generic_Unit): New function to test whether an entity is declared within the declarative region of a given generic unit. (Resolve_Attribute): For checking legality of subprogram'Access within a generic unit, call new Boolean function Declared_Within_Generic_Unit instead of simply comparing the results of Enclosing_Generic_Unit on the prefix and access type. Correct minor comment typos. 2015-01-30 Robert Dewar * freeze.adb, exp_util.ads: Update comment. * exp_util.adb, exp_ch3.adb: Minor code reorganization and reformatting. * sem_util.adb: Minor: fix typo. From-SVN: r220283 --- gcc/ada/ChangeLog | 16 ++++++++++++++++ gcc/ada/exp_ch3.adb | 25 +++++++++++------------- gcc/ada/exp_util.adb | 1 + gcc/ada/exp_util.ads | 3 ++- gcc/ada/freeze.adb | 6 ++++++ gcc/ada/sem_attr.adb | 45 +++++++++++++++++++++++++++++++++++++++----- gcc/ada/sem_util.adb | 2 +- 7 files changed, 77 insertions(+), 21 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c703eb928c5..593ea391f60 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2015-01-30 Gary Dismukes + + * sem_attr.adb (Declared_Within_Generic_Unit): + New function to test whether an entity is declared within the + declarative region of a given generic unit. + (Resolve_Attribute): For checking legality of subprogram'Access within + a generic unit, call new Boolean function Declared_Within_Generic_Unit + instead of simply comparing the results of Enclosing_Generic_Unit on + the prefix and access type. Correct minor comment typos. + +2015-01-30 Robert Dewar + + * freeze.adb, exp_util.ads: Update comment. + * exp_util.adb, exp_ch3.adb: Minor code reorganization and reformatting. + * sem_util.adb: Minor: fix typo. + 2015-01-30 Hristian Kirtchev * sem_attr.adb (Analyze_Attribute): Ensure that diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 2a4b0875003..f2fd707b282 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1138,13 +1138,12 @@ package body Exp_Ch3 is or else Frontend_Layout_On_Target then Func_Id := Build_Dcheck_Function (Discr_Name, Variant); + Decl := First_Non_Pragma (Component_Items (Component_List_Node)); - while Present (Decl) loop Set_Discriminant_Checking_Func (Defining_Identifier (Decl), Func_Id); - Next_Non_Pragma (Decl); end loop; @@ -1492,11 +1491,10 @@ package body Exp_Ch3 is return Empty_List; end if; - Full_Type := Typ; - -- Use the [underlying] full view when dealing with a private type. This -- may require several steps depending on derivations. + Full_Type := Typ; loop if Is_Private_Type (Full_Type) then if Present (Full_View (Full_Type)) then @@ -1594,7 +1592,6 @@ package body Exp_Ch3 is if Has_Discriminants (Full_Init_Type) then Discr := First_Discriminant (Full_Init_Type); - while Present (Discr) loop -- If this is a discriminated concurrent type, the init_proc @@ -2395,14 +2392,16 @@ package body Exp_Ch3 is declare Parent_IP : constant Name_Id := Make_Init_Proc_Name (Etype (Rec_Ent)); - Stmt : Node_Id := First (Stmts); - IP_Call : Node_Id := Empty; + Stmt : Node_Id; + IP_Call : Node_Id; IP_Stmts : List_Id; begin -- Look for a call to the parent IP at the beginning -- of Stmts associated with the record extension + Stmt := First (Stmts); + IP_Call := Empty; while Present (Stmt) loop if Nkind (Stmt) = N_Procedure_Call_Statement and then Chars (Name (Stmt)) = Parent_IP @@ -3297,7 +3296,6 @@ package body Exp_Ch3 is end if; S := First (Constraints (C)); - while Present (S) loop Number_Of_Constraints := Number_Of_Constraints + 1; Next (S); @@ -3666,10 +3664,9 @@ package body Exp_Ch3 is Set_Itype (Ref, Etype (First_Index (Typ))); Append_Freeze_Action (Rec_Type, Ref); - Sub_Aggr := First (Expressions (Comp)); - -- Recurse on nested arrays + Sub_Aggr := First (Expressions (Comp)); while Present (Sub_Aggr) loop Collect_Itypes (Sub_Aggr); Next (Sub_Aggr); @@ -3810,7 +3807,7 @@ package body Exp_Ch3 is Decl := First_Non_Pragma (Component_Items (Comp_List)); while Present (Decl) loop if Nkind (Decl) = N_Component_Declaration then - Id := Defining_Identifier (Decl); + Id := Defining_Identifier (Decl); if Has_Invariants (Etype (Id)) and then In_Open_Scopes (Scope (R_Type)) @@ -6450,9 +6447,10 @@ package body Exp_Ch3 is --------------------- function Is_C_Derivation (Typ : Entity_Id) return Boolean is - T : Entity_Id := Typ; + T : Entity_Id; begin + T := Typ; loop if Is_CPP_Class (T) or else Convention (T) = Convention_C @@ -7847,7 +7845,7 @@ package body Exp_Ch3 is elsif Needs_Finalization (Desig_Type) or else (Is_Incomplete_Type (Desig_Type) - and then No (Full_View (Desig_Type))) + and then No (Full_View (Desig_Type))) then Build_Finalization_Master (Def_Id); @@ -8850,7 +8848,6 @@ package body Exp_Ch3 is Body_List := New_List; Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); - while Present (Prim_Elmt) loop Subp := Node (Prim_Elmt); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 6c35fd6ad6b..ef463c28e8d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2411,6 +2411,7 @@ package body Exp_Util is if Is_Untagged_Derivation (Typ) then if Is_Protected_Type (Typ) then Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 68302602a1b..b8c54fa5966 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -451,7 +451,8 @@ package Exp_Util is -- class-wide). function Finalize_Address (Typ : Entity_Id) return Entity_Id; - -- Locate TSS primitive Finalize_Address in type Typ + -- Locate TSS primitive Finalize_Address in type Typ. Return Empty if the + -- subprogram is not available. function Find_Interface_ADT (T : Entity_Id; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index fd06aa14623..12154a0e75a 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1798,6 +1798,12 @@ package body Freeze is end; end if; + -- Historical note: We used to create a finalization master for an + -- access type whose designated type is not controlled, but contains + -- private controlled compoments. This form of post processing is no + -- longer needed because the finalization master is now created when + -- the access type is frozen (see Exp_Ch3.Freeze_Type). + Next_Entity (E); end loop; end Freeze_All; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 36ee0d2a4ce..8ce79d80588 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -9762,6 +9762,12 @@ package body Sem_Attr is -- Error, or warning within an instance, if the static accessibility -- rules of 3.10.2 are violated. + function Declared_Within_Generic_Unit + (Entity : Entity_Id; + Generic_Unit : Node_Id) return Boolean; + -- Returns True if Declared_Entity is declared within the declarative + -- region of Generic_Unit; otherwise returns False. + --------------------------- -- Accessibility_Message -- --------------------------- @@ -9811,6 +9817,33 @@ package body Sem_Attr is end if; end Accessibility_Message; + ---------------------------------- + -- Declared_Within_Generic_Unit -- + ---------------------------------- + + function Declared_Within_Generic_Unit + (Entity : Entity_Id; + Generic_Unit : Node_Id) return Boolean + is + Generic_Encloser : Node_Id := Enclosing_Generic_Unit (Entity); + + begin + while Present (Generic_Encloser) loop + if Generic_Encloser = Generic_Unit then + return True; + end if; + + -- We have to step to the scope of the generic's entity, because + -- otherwise we'll just get back the same generic. + + Generic_Encloser := + Enclosing_Generic_Unit + (Scope (Defining_Entity (Generic_Encloser))); + end loop; + + return False; + end Declared_Within_Generic_Unit; + -- Start of processing for Resolve_Attribute begin @@ -10058,11 +10091,11 @@ package body Sem_Attr is -- level of the actual type is not known). This restriction -- does not apply when the attribute type is an anonymous -- access-to-subprogram type. Note that this check was - -- revised by AI-229, because the originally Ada 95 rule + -- revised by AI-229, because the original Ada 95 rule -- was too lax. The original rule only applied when the -- subprogram was declared within the body of the generic, -- which allowed the possibility of dangling references). - -- The rule was also too strict in some case, in that it + -- The rule was also too strict in some cases, in that it -- didn't permit the access to be declared in the generic -- spec, whereas the revised rule does (as long as it's not -- a formal type). @@ -10106,13 +10139,15 @@ package body Sem_Attr is then -- The attribute type's ultimate ancestor must be -- declared within the same generic unit as the - -- subprogram is declared. The error message is + -- subprogram is declared (including within another + -- nested generic unit). The error message is -- specialized to say "ancestor" for the case where the -- access type is not its own ancestor, since saying -- simply "access type" would be very confusing. - if Enclosing_Generic_Unit (Entity (P)) /= - Enclosing_Generic_Unit (Root_Type (Btyp)) + if not Declared_Within_Generic_Unit + (Root_Type (Btyp), + Enclosing_Generic_Unit (Entity (P))) then Error_Msg_N ("''Access attribute not allowed in generic body", diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3ba1085dbca..a8767b850c3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- -- 2.30.2