[multiple changes]

2015-01-30  Gary Dismukes  <dismukes@adacore.com>

	* 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  <dewar@adacore.com>

	* 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

+2015-01-30  Gary Dismukes  <dismukes@adacore.com>
+
+	* 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  <dewar@adacore.com>
+
+	* 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  <kirtchev@adacore.com>
 
 	* sem_attr.adb (Analyze_Attribute): Ensure that

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);
 

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)));
 

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;

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;

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",

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- --