sem_ch3.adb (Access_Subprogram_Definition): Additional checks on illegal uses of incomplete types in formal parts and...

2009-04-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Access_Subprogram_Definition): Additional checks on
	illegal uses of incomplete types in formal parts and return types.

	* sem_ch6.adb (Process_Formals): Taft-amendment types are legal in
	access to subprograms.

	* sem_ch7.adb (Uninstall_Declarations): diagnose attempts to use
	Taft-amendment types as the return type of an access_to_function type.

	* freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete
	type for access_to_subprograms. The check is performed on package exit.

From-SVN: r146229

4 files changed, 202 insertions, 206 deletions

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 9530c75..31e32af 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3497,50 +3497,11 @@ package body Freeze is
 
             Freeze_Subprogram (E);
 
-            --  Ada 2005 (AI-326): Check wrong use of tag incomplete type
-
-            --    type T;  --   tagged or untagged, may be from limited view
-            --    type Acc is access function (X : T) return T; -- ERROR
-
-            if Ekind (Etype (E)) = E_Incomplete_Type
-              and then No (Full_View (Etype (E)))
-              and then not Is_Value_Type (Etype (E))
-            then
-               Error_Msg_NE
-                 ("invalid use of incomplete type&", E, Etype (E));
-            end if;
-
          --  For access to a protected subprogram, freeze the equivalent type
          --  (however this is not set if we are not generating code or if this
          --  is an anonymous type used just for resolution).
 
          elsif Is_Access_Protected_Subprogram_Type (E) then
-
-            --  AI-326: Check wrong use of tagged incomplete types
-
-            --    type T is tagged;
-            --    type As3D is access protected
-            --      function (X : Float) return T; -- ERROR
-
-            declare
-               Etyp : Entity_Id;
-
-            begin
-               Etyp := Etype (Directly_Designated_Type (E));
-
-               if Is_Class_Wide_Type (Etyp) then
-                  Etyp := Etype (Etyp);
-               end if;
-
-               if Ekind (Etyp) = E_Incomplete_Type
-                 and then No (Full_View (Etyp))
-                 and then not Is_Value_Type (Etype (E))
-               then
-                  Error_Msg_NE
-                    ("invalid use of incomplete type&", E, Etyp);
-               end if;
-            end;
-
             if Present (Equivalent_Type (E)) then
                Freeze_And_Append (Equivalent_Type (E), Loc, Result);
             end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 5a105db..8b9071a 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1135,7 +1135,27 @@ package body Sem_Ch3 is
                       (T           => Typ,
                        Related_Nod => T_Def,
                        Scope_Id    => Current_Scope));
+
                else
+                  if From_With_Type (Typ) then
+                     Error_Msg_NE
+                      ("illegal use of incomplete type&",
+                         Result_Definition (T_Def), Typ);
+
+                  elsif Ekind (Current_Scope) = E_Package
+                    and then In_Private_Part (Current_Scope)
+                  then
+                     if Ekind (Typ) = E_Incomplete_Type then
+                        Append_Elmt (Desig_Type, Private_Dependents (Typ));
+
+                     elsif Is_Class_Wide_Type (Typ)
+                       and then Ekind (Etype (Typ)) = E_Incomplete_Type
+                     then
+                        Append_Elmt
+                          (Desig_Type, Private_Dependents (Etype (Typ)));
+                     end if;
+                  end if;
+
                   Set_Etype (Desig_Type, Typ);
                end if;
             end;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 17e3d25..080b3e0 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -7716,7 +7716,8 @@ package body Sem_Ch6 is
                --  primitive operations, as long as their completion is
                --  in the same declarative part. If in the private part
                --  this means that the type cannot be a Taft-amendment type.
-               --  Check is done on package exit.
+               --  Check is done on package exit. For access to subprograms,
+               --  the use is legal for Taft-amendment types.
 
                if Is_Tagged_Type (Formal_Type) then
                   if Ekind (Scope (Current_Scope)) = E_Package
@@ -7724,9 +7725,14 @@ package body Sem_Ch6 is
                     and then not From_With_Type (Formal_Type)
                     and then not Is_Class_Wide_Type (Formal_Type)
                   then
-                     Append_Elmt
-                       (Current_Scope,
-                          Private_Dependents (Base_Type (Formal_Type)));
+                     if not Nkind_In
+                       (Parent (T), N_Access_Function_Definition,
+                                    N_Access_Procedure_Definition)
+                     then
+                        Append_Elmt
+                          (Current_Scope,
+                             Private_Dependents (Base_Type (Formal_Type)));
+                     end if;
                   end if;
 
                --  Special handling of Value_Type for CIL case
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 7e84f7b..ba005a3 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -25,8 +25,8 @@
 
 --  This package contains the routines to process package specifications and
 --  bodies. The most important semantic aspects of package processing are the
---  handling of private and full declarations, and the construction of
---  dispatch tables for tagged types.
+--  handling of private and full declarations, and the construction of dispatch
+--  tables for tagged types.
 
 with Atree;    use Atree;
 with Debug;    use Debug;
@@ -102,9 +102,9 @@ package body Sem_Ch7 is
    --  before other body declarations.
 
    procedure Install_Package_Entity (Id : Entity_Id);
-   --  Supporting procedure for Install_{Visible,Private}_Declarations.
-   --  Places one entity on its visibility chain, and recurses on the visible
-   --  part if the entity is an inner package.
+   --  Supporting procedure for Install_{Visible,Private}_Declarations. Places
+   --  one entity on its visibility chain, and recurses on the visible part if
+   --  the entity is an inner package.
 
    function Is_Private_Base_Type (E : Entity_Id) return Boolean;
    --  True for a private type that is not a subtype
@@ -144,10 +144,10 @@ package body Sem_Ch7 is
       Pack_Decl        : Node_Id;
 
       procedure Install_Composite_Operations (P : Entity_Id);
-      --  Composite types declared in the current scope may depend on
-      --  types that were private at the point of declaration, and whose
-      --  full view is now in  scope. Indicate that the corresponding
-      --  operations on the composite type are available.
+      --  Composite types declared in the current scope may depend on types
+      --  that were private at the point of declaration, and whose full view
+      --  is now in scope. Indicate that the corresponding operations on the
+      --  composite type are available.
 
       ----------------------------------
       -- Install_Composite_Operations --
@@ -175,12 +175,12 @@ package body Sem_Ch7 is
    --  Start of processing for Analyze_Package_Body
 
    begin
-      --  Find corresponding package specification, and establish the
-      --  current scope. The visible defining entity for the package is the
-      --  defining occurrence in the spec. On exit from the package body, all
-      --  body declarations are attached to the defining entity for the body,
-      --  but the later is never used for name resolution. In this fashion
-      --  there is only one visible entity that denotes the package.
+      --  Find corresponding package specification, and establish the current
+      --  scope. The visible defining entity for the package is the defining
+      --  occurrence in the spec. On exit from the package body, all body
+      --  declarations are attached to the defining entity for the body, but
+      --  the later is never used for name resolution. In this fashion there
+      --  is only one visible entity that denotes the package.
 
       if Debug_Flag_C then
          Write_Str ("====  Compiling package body ");
@@ -190,15 +190,15 @@ package body Sem_Ch7 is
          Write_Eol;
       end if;
 
-      --  Set Body_Id. Note that this Will be reset to point to the
-      --  generic copy later on in the generic case.
+      --  Set Body_Id. Note that this Will be reset to point to the generic
+      --  copy later on in the generic case.
 
       Body_Id := Defining_Entity (N);
 
       if Present (Corresponding_Spec (N)) then
 
-         --  Body is body of package instantiation. Corresponding spec
-         --  has already been set.
+         --  Body is body of package instantiation. Corresponding spec has
+         --  already been set.
 
          Spec_Id := Corresponding_Spec (N);
          Pack_Decl := Unit_Declaration_Node (Spec_Id);
@@ -257,8 +257,8 @@ package body Sem_Ch7 is
 
       if Ekind (Spec_Id) = E_Generic_Package then
 
-         --  Disable expansion and perform semantic analysis on copy.
-         --  The unannotated body will be used in all instantiations.
+         --  Disable expansion and perform semantic analysis on copy. The
+         --  unannotated body will be used in all instantiations.
 
          Body_Id := Defining_Entity (N);
          Set_Ekind (Body_Id, E_Package_Body);
@@ -270,23 +270,23 @@ package body Sem_Ch7 is
          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
          Rewrite (N, New_N);
 
-         --  Update Body_Id to point to the copied node for the remainder
-         --  of the processing.
+         --  Update Body_Id to point to the copied node for the remainder of
+         --  the processing.
 
          Body_Id := Defining_Entity (N);
          Start_Generic;
       end if;
 
       --  The Body_Id is that of the copied node in the generic case, the
-      --  current node otherwise. Note that N was rewritten above, so we
-      --  must be sure to get the latest Body_Id value.
+      --  current node otherwise. Note that N was rewritten above, so we must
+      --  be sure to get the latest Body_Id value.
 
       Set_Ekind (Body_Id, E_Package_Body);
       Set_Body_Entity (Spec_Id, Body_Id);
       Set_Spec_Entity (Body_Id, Spec_Id);
 
-      --  Defining name for the package body is not a visible entity: Only
-      --  the defining name for the declaration is visible.
+      --  Defining name for the package body is not a visible entity: Only the
+      --  defining name for the declaration is visible.
 
       Set_Etype (Body_Id, Standard_Void_Type);
       Set_Scope (Body_Id, Scope (Spec_Id));
@@ -340,7 +340,7 @@ package body Sem_Ch7 is
          Inspect_Deferred_Constant_Completion (Declarations (N));
       end if;
 
-      --  Analyze_Declarations has caused freezing of all types; now generate
+      --  Analyze_Declarations has caused freezing of all types. Now generate
       --  bodies for RACW primitives and stream attributes, if any.
 
       if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then
@@ -416,9 +416,8 @@ package body Sem_Ch7 is
             Set_Is_Potentially_Use_Visible (E, False);
             Set_Is_Hidden (E);
 
-            --  Child units may appear on the entity list (for example if
-            --  they appear in the context of a subunit) but they are not
-            --  body entities.
+            --  Child units may appear on the entity list (e.g. if they appear
+            --  in the context of a subunit) but they are not body entities.
 
             if not Is_Child_Unit (E) then
                Set_Is_Package_Body_Entity (E);
@@ -444,9 +443,9 @@ package body Sem_Ch7 is
       --  following loop runs backwards from the end of the entities of the
       --  package body making these entities invisible until we reach a
       --  referencer, i.e. a declaration that could reference a previous
-      --  declaration, a generic body or an inlined body, or a stub (which
-      --  may contain either of these). This is of course an approximation,
-      --  but it is conservative and definitely correct.
+      --  declaration, a generic body or an inlined body, or a stub (which may
+      --  contain either of these). This is of course an approximation, but it
+      --  is conservative and definitely correct.
 
       --  We only do this at the outer (library) level non-generic packages.
       --  The reason is simply to cut down on the number of external symbols
@@ -464,16 +463,15 @@ package body Sem_Ch7 is
                Outer : Boolean)
                return  Boolean;
             --  Traverse the given list of declarations in reverse order.
-            --  Return True as soon as a referencer is reached. Return
-            --  False if none is found. The Outer parameter is True for
-            --  the outer level call, and False for inner level calls for
-            --  nested packages. If Outer is True, then any entities up
-            --  to the point of hitting a referencer get their Is_Public
-            --  flag cleared, so that the entities will be treated as
-            --  static entities in the C sense, and need not have fully
-            --  qualified names. For inner levels, we need all names to
-            --  be fully qualified to deal with the same name appearing
-            --  in parallel packages (right now this is tied to their
+            --  Return True as soon as a referencer is reached. Return False if
+            --  none is found. The Outer parameter is True for the outer level
+            --  call, and False for inner level calls for nested packages. If
+            --  Outer is True, then any entities up to the point of hitting a
+            --  referencer get their Is_Public flag cleared, so that the
+            --  entities will be treated as static entities in the C sense, and
+            --  need not have fully qualified names. For inner levels, we need
+            --  all names to be fully qualified to deal with the same name
+            --  appearing in parallel packages (right now this is tied to their
             --  being external).
 
             --------------------
@@ -512,10 +510,10 @@ package body Sem_Ch7 is
 
                         --  Note that we test Has_Pragma_Inline here rather
                         --  than Is_Inlined. We are compiling this for a
-                        --  client, and it is the client who will decide
-                        --  if actual inlining should occur, so we need to
-                        --  assume that the procedure could be inlined for
-                        --  the purpose of accessing global entities.
+                        --  client, and it is the client who will decide if
+                        --  actual inlining should occur, so we need to assume
+                        --  that the procedure could be inlined for the purpose
+                        --  of accessing global entities.
 
                         if Has_Pragma_Inline (E) then
                            return True;
@@ -542,20 +540,19 @@ package body Sem_Ch7 is
                   then
                      E := Corresponding_Spec (D);
 
-                     --  Generic package body is a referencer. It would
-                     --  seem that we only have to consider generics that
-                     --  can be exported, i.e. where the corresponding spec
-                     --  is the spec of the current package, but because of
-                     --  nested instantiations, a fully private generic
-                     --  body may export other private body entities.
+                     --  Generic package body is a referencer. It would seem
+                     --  that we only have to consider generics that can be
+                     --  exported, i.e. where the corresponding spec is the
+                     --  spec of the current package, but because of nested
+                     --  instantiations, a fully private generic body may
+                     --  export other private body entities.
 
                      if Is_Generic_Unit (E) then
                         return True;
 
-                     --  For non-generic package body, recurse into body
-                     --  unless this is an instance, we ignore instances
-                     --  since they cannot have references that affect
-                     --  outer entities.
+                     --  For non-generic package body, recurse into body unless
+                     --  this is an instance, we ignore instances since they
+                     --  cannot have references that affect outer entities.
 
                      elsif not Is_Generic_Instance (E) then
                         if Has_Referencer
@@ -583,10 +580,10 @@ package body Sem_Ch7 is
                         end if;
                      end if;
 
-                  --  Objects and exceptions need not be public if we have
-                  --  not encountered a referencer so far. We only reset
-                  --  the flag for outer level entities that are not
-                  --  imported/exported, and which have no interface name.
+                  --  Objects and exceptions need not be public if we have not
+                  --  encountered a referencer so far. We only reset the flag
+                  --  for outer level entities that are not imported/exported,
+                  --  and which have no interface name.
 
                   elsif Nkind_In (K, N_Object_Declaration,
                                      N_Exception_Declaration,
@@ -623,10 +620,10 @@ package body Sem_Ch7 is
       end if;
 
       --  If expander is not active, then here is where we turn off the
-      --  In_Package_Body flag, otherwise it is turned off at the end of
-      --  the corresponding expansion routine. If this is an instance body,
-      --  we need to qualify names of local entities, because the body may
-      --  have been compiled as a preliminary to another instantiation.
+      --  In_Package_Body flag, otherwise it is turned off at the end of the
+      --  corresponding expansion routine. If this is an instance body, we need
+      --  to qualify names of local entities, because the body may have been
+      --  compiled as a preliminary to another instantiation.
 
       if not Expander_Active then
          Set_In_Package_Body (Spec_Id, False);
@@ -692,9 +689,9 @@ package body Sem_Ch7 is
 
       Body_Required := Unit_Requires_Body (Id);
 
-      --  When this spec does not require an explicit body, we know that
-      --  there are no entities requiring completion in the language sense;
-      --  we call Check_Completion here only to ensure that any nested package
+      --  When this spec does not require an explicit body, we know that there
+      --  are no entities requiring completion in the language sense; we call
+      --  Check_Completion here only to ensure that any nested package
       --  declaration that requires an implicit body gets one. (In the case
       --  where a body is required, Check_Completion is called at the end of
       --  the body's declarative part.)
@@ -734,8 +731,8 @@ package body Sem_Ch7 is
    -- Analyze_Package_Specification --
    -----------------------------------
 
-   --  Note that this code is shared for the analysis of generic package
-   --  specs (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
+   --  Note that this code is shared for the analysis of generic package specs
+   --  (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
 
    procedure Analyze_Package_Specification (N : Node_Id) is
       Id           : constant Entity_Id  := Defining_Entity (N);
@@ -760,10 +757,10 @@ package body Sem_Ch7 is
       --  visibility analysis for preconditions and postconditions in specs.
 
       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
-      --  Clears constant indications (Never_Set_In_Source, Constant_Value,
-      --  and Is_True_Constant) on all variables that are entities of Id,
-      --  and on the chain whose first element is FE. A recursive call is
-      --  made for all packages and generic packages.
+      --  Clears constant indications (Never_Set_In_Source, Constant_Value, and
+      --  Is_True_Constant) on all variables that are entities of Id, and on
+      --  the chain whose first element is FE. A recursive call is made for all
+      --  packages and generic packages.
 
       procedure Generate_Parent_References;
       --  For a child unit, generate references to parent units, for
@@ -822,18 +819,17 @@ package body Sem_Ch7 is
          E : Entity_Id;
 
       begin
-         --  Ignore package renamings, not interesting and they can
-         --  cause self referential loops in the code below.
+         --  Ignore package renamings, not interesting and they can cause self
+         --  referential loops in the code below.
 
          if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
             return;
          end if;
 
-         --  Note: in the loop below, the check for Next_Entity pointing
-         --  back to the package entity may seem odd, but it is needed,
-         --  because a package can contain a renaming declaration to itself,
-         --  and such renamings are generated automatically within package
-         --  instances.
+         --  Note: in the loop below, the check for Next_Entity pointing back
+         --  to the package entity may seem odd, but it is needed, because a
+         --  package can contain a renaming declaration to itself, and such
+         --  renamings are generated automatically within package instances.
 
          E := FE;
          while Present (E) and then E /= Id loop
@@ -873,8 +869,8 @@ package body Sem_Ch7 is
          elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
                                                        N_Subunit)
          then
-            --  If current unit is an ancestor of main unit, generate
-            --  a reference to its own parent.
+            --  If current unit is an ancestor of main unit, generate a
+            --  reference to its own parent.
 
             declare
                U         : Node_Id;
@@ -1065,11 +1061,11 @@ package body Sem_Ch7 is
          Validate_RCI_Declarations (Id);
       end if;
 
-      --  Save global references in the visible declarations, before
-      --  installing private declarations of parent unit if there is one,
-      --  because the privacy status of types defined in the parent will
-      --  change. This is only relevant for generic child units, but is
-      --  done in all cases for uniformity.
+      --  Save global references in the visible declarations, before installing
+      --  private declarations of parent unit if there is one, because the
+      --  privacy status of types defined in the parent will change. This is
+      --  only relevant for generic child units, but is done in all cases for
+      --  uniformity.
 
       if Ekind (Id) = E_Generic_Package
         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
@@ -1360,8 +1356,8 @@ package body Sem_Ch7 is
    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
 
       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-      --  Check whether an inherited subprogram is an operation of an
-      --  untagged derived type.
+      --  Check whether an inherited subprogram is an operation of an untagged
+      --  derived type.
 
       ---------------------
       -- Is_Primitive_Of --
@@ -1371,9 +1367,9 @@ package body Sem_Ch7 is
          Formal : Entity_Id;
 
       begin
-         --  If the full view is a scalar type, the type is the anonymous
-         --  base type, but the operation mentions the first subtype, so
-         --  check the signature against the base type.
+         --  If the full view is a scalar type, the type is the anonymous base
+         --  type, but the operation mentions the first subtype, so check the
+         --  signature against the base type.
 
          if Base_Type (Etype (S)) = Base_Type (T) then
             return True;
@@ -1409,10 +1405,10 @@ package body Sem_Ch7 is
       E := First_Entity (Id);
       while Present (E) loop
 
-         --  If the entity is a nonprivate type extension whose parent
-         --  type is declared in an open scope, then the type may have
-         --  inherited operations that now need to be made visible.
-         --  Ditto if the entity is a formal derived type in a child unit.
+         --  If the entity is a nonprivate type extension whose parent type
+         --  is declared in an open scope, then the type may have inherited
+         --  operations that now need to be made visible. Ditto if the entity
+         --  is a formal derived type in a child unit.
 
          if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
                or else
@@ -1498,16 +1494,15 @@ package body Sem_Ch7 is
                        (Is_Dispatching_Operation (New_Op)
                          and then Node (Last_Elmt (Op_List)) = New_Op);
 
-                     --  Substitute the new operation for the old one
-                     --  in the type's primitive operations list. Since
-                     --  the new operation was also just added to the end
-                     --  of list, the last element must be removed.
+                     --  Substitute the new operation for the old one in the
+                     --  type's primitive operations list. Since the new
+                     --  operation was also just added to the end of list,
+                     --  the last element must be removed.
 
-                     --  (Question: is there a simpler way of declaring
-                     --  the operation, say by just replacing the name
-                     --  of the earlier operation, reentering it in the
-                     --  in the symbol table (how?), and marking it as
-                     --  private???)
+                     --  (Question: is there a simpler way of declaring the
+                     --  operation, say by just replacing the name of the
+                     --  earlier operation, reentering it in the in the symbol
+                     --  table (how?), and marking it as private???)
 
                      Replace_Elmt (Op_Elmt, New_Op);
                      Remove_Last_Elmt (Op_List);
@@ -1524,8 +1519,8 @@ package body Sem_Ch7 is
                end if;
 
             else
-               --   Non-tagged type, scan forward to locate
-               --   inherited hidden operations.
+               --   Non-tagged type, scan forward to locate inherited hidden
+               --   operations.
 
                Prim_Op := Next_Entity (E);
                while Present (Prim_Op) loop
@@ -1581,8 +1576,8 @@ package body Sem_Ch7 is
       Next2 := Next_Entity (Full_Id);
       H2    := Homonym (Full_Id);
 
-      --  Reset full declaration pointer to reflect the switched entities
-      --  and readjust the next entity chains.
+      --  Reset full declaration pointer to reflect the switched entities and
+      --  readjust the next entity chains.
 
       Exchange_Entities (Id, Full_Id);
 
@@ -1625,13 +1620,13 @@ package body Sem_Ch7 is
       Full      : Entity_Id;
 
    begin
-      --  First exchange declarations for private types, so that the
-      --  full declaration is visible. For each private type, we check
-      --  its Private_Dependents list and also exchange any subtypes of
-      --  or derived types from it. Finally, if this is a Taft amendment
-      --  type, the incomplete declaration is irrelevant, and we want to
-      --  link the eventual full declaration with the original private
-      --  one so we also skip the exchange.
+      --  First exchange declarations for private types, so that the full
+      --  declaration is visible. For each private type, we check its
+      --  Private_Dependents list and also exchange any subtypes of or derived
+      --  types from it. Finally, if this is a Taft amendment type, the
+      --  incomplete declaration is irrelevant, and we want to link the
+      --  eventual full declaration with the original private one so we also
+      --  skip the exchange.
 
       Id := First_Entity (P);
       while Present (Id) and then Id /= First_Private_Entity (P) loop
@@ -1659,12 +1654,12 @@ package body Sem_Ch7 is
                --  can only happen in a package nested within a child package,
                --  when the parent type is defined in the parent unit. At this
                --  point the current type is not private either, and we have to
-               --  install the underlying full view, which is now visible.
-               --  Save the current full view as well, so that all views can
-               --  be restored on exit. It may seem that after compiling the
-               --  child body there are not environments to restore, but the
-               --  back-end expects those links to be valid, and freeze nodes
-               --  depend on them.
+               --  install the underlying full view, which is now visible. Save
+               --  the current full view as well, so that all views can be
+               --  restored on exit. It may seem that after compiling the child
+               --  body there are not environments to restore, but the back-end
+               --  expects those links to be valid, and freeze nodes depend on
+               --  them.
 
                if No (Full_View (Full))
                  and then Present (Underlying_Full_View (Full))
@@ -1686,8 +1681,8 @@ package body Sem_Ch7 is
                Priv := Node (Priv_Elmt);
 
                --  Before the exchange, verify that the presence of the
-               --  Full_View field. It will be empty if the entity
-               --  has already been installed due to a previous call.
+               --  Full_View field. It will be empty if the entity has already
+               --  been installed due to a previous call.
 
                if Present (Full_View (Priv))
                  and then Is_Visible_Dependent (Priv)
@@ -1772,8 +1767,7 @@ package body Sem_Ch7 is
       S : constant Entity_Id := Scope (Dep);
 
    begin
-      --  Renamings created for actual types have the visibility of the
-      --  actual.
+      --  Renamings created for actual types have the visibility of the actual
 
       if Ekind (S) = E_Package
         and then Is_Generic_Instance (S)
@@ -1785,9 +1779,9 @@ package body Sem_Ch7 is
       elsif not (Is_Derived_Type (Dep))
         and then Is_Derived_Type (Full_View (Dep))
       then
-         --  When instantiating a package body, the scope stack is empty,
-         --  so check instead whether the dependent type is defined in
-         --  the same scope as the instance itself.
+         --  When instantiating a package body, the scope stack is empty, so
+         --  check instead whether the dependent type is defined in the same
+         --  scope as the instance itself.
 
          return In_Open_Scopes (S)
            or else (Is_Generic_Instance (Current_Scope)
@@ -1856,8 +1850,8 @@ package body Sem_Ch7 is
         No (Discriminant_Specifications (N))
           and then not Unknown_Discriminants_Present (N));
 
-      --  Set tagged flag before processing discriminants, to catch
-      --  illegal usage.
+      --  Set tagged flag before processing discriminants, to catch illegal
+      --  usage.
 
       Set_Is_Tagged_Type (Id, Tagged_Present (Def));
 
@@ -1900,8 +1894,8 @@ package body Sem_Ch7 is
       Priv_Sub  : Entity_Id;
 
       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
-      --  Copy to the private declaration the attributes of the full view
-      --  that need to be available for the partial view also.
+      --  Copy to the private declaration the attributes of the full view that
+      --  need to be available for the partial view also.
 
       function Type_In_Use (T : Entity_Id) return Boolean;
       --  Check whether type or base type appear in an active use_type clause
@@ -1951,8 +1945,8 @@ package body Sem_Ch7 is
          then
             if Priv_Is_Base_Type then
 
-               --  Ada 2005 (AI-345): The full view of a type implementing
-               --  an interface can be a task type.
+               --  Ada 2005 (AI-345): The full view of a type implementing an
+               --  interface can be a task type.
 
                --    type T is new I with private;
                --  private
@@ -1984,8 +1978,8 @@ package body Sem_Ch7 is
 
             if Is_Tagged_Type (Priv) then
 
-               --  If the type is tagged, the tag itself must be available
-               --  on the partial view, for expansion purposes.
+               --  If the type is tagged, the tag itself must be available on
+               --  the partial view, for expansion purposes.
 
                Set_First_Entity (Priv, First_Entity (Full));
 
@@ -2156,8 +2150,8 @@ package body Sem_Ch7 is
       end if;
 
       --  Make private entities invisible and exchange full and private
-      --  declarations for private types. Id is now the first private
-      --  entity in the package.
+      --  declarations for private types. Id is now the first private entity
+      --  in the package.
 
       while Present (Id) loop
          if Debug_Flag_E then
@@ -2178,10 +2172,10 @@ package body Sem_Ch7 is
          then
             Full := Full_View (Id);
 
-            --  If the partial view is not declared in the visible part
-            --  of the package (as is the case when it is a type derived
-            --  from some other private type in the private part of the
-            --  current package), no exchange takes place.
+            --  If the partial view is not declared in the visible part of the
+            --  package (as is the case when it is a type derived from some
+            --  other private type in the private part of the current package),
+            --  no exchange takes place.
 
             if No (Parent (Id))
               or else List_Containing (Parent (Id))
@@ -2192,10 +2186,10 @@ package body Sem_Ch7 is
 
             --  The entry in the private part points to the full declaration,
             --  which is currently visible. Exchange them so only the private
-            --  type declaration remains accessible, and link private and
-            --  full declaration in the opposite direction. Before the actual
-            --  exchange, we copy back attributes of the full view that
-            --  must be available to the partial view too.
+            --  type declaration remains accessible, and link private and full
+            --  declaration in the opposite direction. Before the actual
+            --  exchange, we copy back attributes of the full view that must
+            --  be available to the partial view too.
 
             Preserve_Full_Attributes (Id, Full);
 
@@ -2213,10 +2207,10 @@ package body Sem_Ch7 is
             --  Swap out the subtypes and derived types of Id that were
             --  compiled in this scope, or installed previously by
             --  Install_Private_Declarations.
-            --  Before we do the swap, we verify the presence of the
-            --  Full_View field which may be empty due to a swap by
-            --  a previous call to End_Package_Scope (e.g. from the
-            --  freezing mechanism).
+
+            --  Before we do the swap, we verify the presence of the Full_View
+            --  field which may be empty due to a swap by a previous call to
+            --  End_Package_Scope (e.g. from the freezing mechanism).
 
             while Present (Priv_Elmt) loop
                Priv_Sub := Node (Priv_Elmt);
@@ -2244,10 +2238,11 @@ package body Sem_Ch7 is
 
             Exchange_Declarations (Id);
 
-            --  If we have installed an underlying full view for a type
-            --  derived from a private type in a child unit, restore the
-            --  proper views of private and full view. See corresponding
-            --  code in Install_Private_Declarations.
+            --  If we have installed an underlying full view for a type derived
+            --  from a private type in a child unit, restore the proper views
+            --  of private and full view. See corresponding code in
+            --  Install_Private_Declarations.
+
             --  After the exchange, Full denotes the private type in the
             --  visible part of the package.
 
@@ -2264,9 +2259,8 @@ package body Sem_Ch7 is
            and then Comes_From_Source (Id)
            and then No (Full_View (Id))
          then
-
-            --  Mark Taft amendment types. Verify that there are no
-            --  primitive operations declared for the type (3.10.1 (9)).
+            --  Mark Taft amendment types. Verify that there are no primitive
+            --  operations declared for the type (3.10.1 (9)).
 
             Set_Has_Completion_In_Body (Id);
 
@@ -2278,10 +2272,25 @@ package body Sem_Ch7 is
                Elmt := First_Elmt (Private_Dependents (Id));
                while Present (Elmt) loop
                   Subp := Node (Elmt);
+
                   if Is_Overloadable (Subp) then
                      Error_Msg_NE
                        ("type& must be completed in the private part",
                          Parent (Subp), Id);
+
+                  --  The return type of an access_to_function cannot be a
+                  --  Taft-amendment type.
+
+                  elsif Ekind (Subp) = E_Subprogram_Type then
+                     if Etype (Subp) = Id
+                       or else
+                         (Is_Class_Wide_Type (Etype (Subp))
+                            and then Etype (Etype (Subp)) = Id)
+                     then
+                        Error_Msg_NE
+                          ("type& must be completed in the private part",
+                             Associated_Node_For_Itype (Subp), Id);
+                     end if;
                   end if;
 
                   Next_Elmt (Elmt);
@@ -2309,9 +2318,9 @@ package body Sem_Ch7 is
       E : Entity_Id;
 
    begin
-      --  Imported entity never requires body. Right now, only
-      --  subprograms can be imported, but perhaps in the future
-      --  we will allow import of packages.
+      --  Imported entity never requires body. Right now, only subprograms can
+      --  be imported, but perhaps in the future we will allow import of
+      --  packages.
 
       if Is_Imported (P) then
          return False;