[multiple changes]

2017-04-25  Arnaud Charlet  <charlet@adacore.com>

	* a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract.

2017-04-25  Justin Squirek  <squirek@adacore.com>

	* sem_ch3.adb (Analyze_Declarations): Minor
	correction to comments, move out large conditional and scope
	traversal into a predicate.
	(Uses_Unseen_Lib_Unit_Priv): Predicate function made from extracted
	logic.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): Refine analysis
	of prefix whose type is a current instance of a synchronized
	type. If the prefix is an object this is an external call (or
	requeue) that can only access public operations of the object. The
	previous predicate was too restrictive, and did not allow public
	protected operations, only task entries.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch5.adb, fname.adb: Minor reformatting.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb (Is_Anonymous_Access_Type): New routine.
	* einfo.ads Update the placement of
	E_Anonymous_Access_Subprogram_Type along with all subtypes that
	mention the ekind.
	(Is_Anonymous_Access_Type): New routine.
	* exp_ch7.adb (Allows_Finalization_Master): Do not generate a
	master for an access type subject to pragma No_Heap_Finalization.
	* exp_util.adb (Build_Allocate_Deallocate_Proc): An object being
	allocated or deallocated does not finalization actions if the
	associated access type is subject to pragma No_Heap_Finalization.
	* opt.ads Add new global variable No_Heap_Finalization_Pragma.
	* par-prag.adb Pragma No_Heap_Finalization does not need special
	processing from the parser.
	* sem_ch6.adb (Check_Return_Subtype_Indication): Remove ancient
	??? comments. Use the new predicate Is_Anonymous_Access_Type.
	* sem_prag.adb Add an entry in table Sig_Flags for pragma
	No_Heap_Finalization.
	(Analyze_Pragma): Add processing for
	pragma No_Heap_Finalization. Update various error messages to
	use Duplication_Error.
	* sem_util.ads, sem_util.adb (No_Heap_Finalization): New routine.
	* snames.ads-tmpl: Add new predefined name No_Heap_Finalization
	and corresponding pragma id.

From-SVN: r247156

18 files changed, 418 insertions, 169 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a9de5f0..50e45b6 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,54 @@
+2017-04-25  Arnaud Charlet  <charlet@adacore.com>
+
+	* a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract.
+
+2017-04-25  Justin Squirek  <squirek@adacore.com>
+
+	* sem_ch3.adb (Analyze_Declarations): Minor
+	correction to comments, move out large conditional and scope
+	traversal into a predicate.
+	(Uses_Unseen_Lib_Unit_Priv): Predicate function made from extracted
+	logic.
+
+2017-04-25  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch4.adb (Analyze_Selected_Component): Refine analysis
+	of prefix whose type is a current instance of a synchronized
+	type. If the prefix is an object this is an external call (or
+	requeue) that can only access public operations of the object. The
+	previous predicate was too restrictive, and did not allow public
+	protected operations, only task entries.
+
+2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch5.adb, fname.adb: Minor reformatting.
+
+2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* einfo.adb (Is_Anonymous_Access_Type): New routine.
+	* einfo.ads Update the placement of
+	E_Anonymous_Access_Subprogram_Type along with all subtypes that
+	mention the ekind.
+	(Is_Anonymous_Access_Type): New routine.
+	* exp_ch7.adb (Allows_Finalization_Master): Do not generate a
+	master for an access type subject to pragma No_Heap_Finalization.
+	* exp_util.adb (Build_Allocate_Deallocate_Proc): An object being
+	allocated or deallocated does not finalization actions if the
+	associated access type is subject to pragma No_Heap_Finalization.
+	* opt.ads Add new global variable No_Heap_Finalization_Pragma.
+	* par-prag.adb Pragma No_Heap_Finalization does not need special
+	processing from the parser.
+	* sem_ch6.adb (Check_Return_Subtype_Indication): Remove ancient
+	??? comments. Use the new predicate Is_Anonymous_Access_Type.
+	* sem_prag.adb Add an entry in table Sig_Flags for pragma
+	No_Heap_Finalization.
+	(Analyze_Pragma): Add processing for
+	pragma No_Heap_Finalization. Update various error messages to
+	use Duplication_Error.
+	* sem_util.ads, sem_util.adb (No_Heap_Finalization): New routine.
+	* snames.ads-tmpl: Add new predefined name No_Heap_Finalization
+	and corresponding pragma id.
+
 2017-04-25  Bob Duff  <duff@adacore.com>
 
 	* freeze.adb (Freeze_Record_Type): Use the
diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/a-cfinve.ads
index e76ae8d..34abfbb 100644
--- a/gcc/ada/a-cfinve.ads
+++ b/gcc/ada/a-cfinve.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2014-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 2014-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -73,7 +73,8 @@ is
    type Vector (Capacity : Capacity_Range) is limited private with
      Default_Initial_Condition;
 
-   function Empty_Vector return Vector;
+   function Empty_Vector return Vector with
+     Global => null;
 
    function "=" (Left, Right : Vector) return Boolean with
      Global => null;
diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads
index e8a3c94..a97d2d8 100644
--- a/gcc/ada/a-cofove.ads
+++ b/gcc/ada/a-cofove.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -73,7 +73,8 @@ is
    --  unbounded case; you can't assign from one object to another if the
    --  Capacity is different.
 
-   function Empty_Vector return Vector;
+   function Empty_Vector return Vector with
+     Global => null;
 
    function "=" (Left, Right : Vector) return Boolean with
      Global => null;
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 9f9a0a6..441d309 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -3533,6 +3533,11 @@ package body Einfo is
       return Ekind (Id) in Aggregate_Kind;
    end Is_Aggregate_Type;
 
+   function Is_Anonymous_Access_Type            (Id : E) return B is
+   begin
+      return Ekind (Id) in Anonymous_Access_Kind;
+   end Is_Anonymous_Access_Type;
+
    function Is_Array_Type                       (Id : E) return B is
    begin
       return Ekind (Id) in Array_Kind;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index f0080d5..9a0530d 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -4845,12 +4845,6 @@ package Einfo is
       --  An access to subprogram type, created by an access to subprogram
       --  declaration.
 
-      E_Anonymous_Access_Subprogram_Type,
-      --  An anonymous access to subprogram type, created by an access to
-      --  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
       --  declaration. Values of such a type denote both a protected object
@@ -4861,6 +4855,12 @@ package Einfo is
       --  An anonymous access to protected subprogram type, created by an
       --  access to subprogram declaration.
 
+      E_Anonymous_Access_Subprogram_Type,
+      --  An anonymous access to subprogram type, created by an access to
+      --  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_Anonymous_Access_Type,
       --  An anonymous access type created by an access parameter or access
       --  discriminant.
@@ -5090,16 +5090,16 @@ package Einfo is
    --  E_Allocator_Type
    --  E_General_Access_Type
    --  E_Access_Subprogram_Type
-   --  E_Anonymous_Access_Subprogram_Type
    --  E_Access_Protected_Subprogram_Type
    --  E_Anonymous_Access_Protected_Subprogram_Type
+   --  E_Anonymous_Access_Subprogram_Type
        E_Anonymous_Access_Type;
 
    subtype Access_Subprogram_Kind      is Entity_Kind range
        E_Access_Subprogram_Type ..
-   --  E_Anonymous_Access_Subprogram_Type
    --  E_Access_Protected_Subprogram_Type
-       E_Anonymous_Access_Protected_Subprogram_Type;
+   --  E_Anonymous_Access_Protected_Subprogram_Type
+       E_Anonymous_Access_Subprogram_Type;
 
    subtype Access_Protected_Kind       is Entity_Kind range
       E_Access_Protected_Subprogram_Type ..
@@ -5114,6 +5114,11 @@ package Einfo is
    --  E_Record_Type
        E_Record_Subtype;
 
+   subtype Anonymous_Access_Kind       is Entity_Kind range
+       E_Anonymous_Access_Protected_Subprogram_Type ..
+   --  E_Anonymous_Subprogram_Type
+       E_Anonymous_Access_Type;
+
    subtype Array_Kind                  is Entity_Kind range
        E_Array_Type ..
    --  E_Array_Subtype
@@ -5209,8 +5214,8 @@ package Einfo is
    --  E_General_Access_Type
    --  E_Access_Subprogram_Type
    --  E_Access_Protected_Subprogram_Type
-   --  E_Anonymous_Access_Subprogram_Type
    --  E_Anonymous_Access_Protected_Subprogram_Type
+   --  E_Anonymous_Access_Subprogram_Type
        E_Anonymous_Access_Type;
 
    subtype Enumeration_Kind            is Entity_Kind range
@@ -5388,8 +5393,8 @@ package Einfo is
    --  E_General_Access_Type
    --  E_Access_Subprogram_Type,
    --  E_Access_Protected_Subprogram_Type
-   --  E_Anonymous_Access_Subprogram_Type
    --  E_Anonymous_Access_Protected_Subprogram_Type
+   --  E_Anonymous_Access_Subprogram_Type
    --  E_Anonymous_Access_Type
    --  E_Array_Type
    --  E_Array_Subtype
@@ -7359,6 +7364,7 @@ package Einfo is
    function Is_Access_Protected_Subprogram_Type (Id : E) return B;
    function Is_Access_Subprogram_Type           (Id : E) return B;
    function Is_Aggregate_Type                   (Id : E) return B;
+   function Is_Anonymous_Access_Type            (Id : E) return B;
    function Is_Array_Type                       (Id : E) return B;
    function Is_Assignable                       (Id : E) return B;
    function Is_Class_Wide_Type                  (Id : E) return B;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 5d98160..852ae44 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -486,34 +486,41 @@ package body Exp_Ch7 is
       then
          return False;
 
-      --  Do not consider types that return on the secondary stack
+      --  Do not consider an access type which return on the secondary stack
 
       elsif Present (Associated_Storage_Pool (Ptr_Typ))
         and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
       then
          return False;
 
-      --  Do not consider types which may never allocate an object
+      --  Do not consider an access type which may never allocate an object
 
       elsif No_Pool_Assigned (Ptr_Typ) then
          return False;
 
-      --  Do not consider access types coming from Ada.Unchecked_Deallocation
-      --  instances. Even though the designated type may be controlled, the
-      --  access type will never participate in allocation.
+      --  Do not consider an access type coming from an Unchecked_Deallocation
+      --  instance. Even though the designated type may be controlled, the
+      --  access type will never participate in any allocations.
 
       elsif In_Deallocation_Instance (Ptr_Typ) then
          return False;
 
-      --  Do not consider non-library access types when restriction
-      --  No_Nested_Finalization is in effect since masters are controlled
-      --  objects.
+      --  Do not consider a non-library access type when No_Nested_Finalization
+      --  is in effect since finalization masters are controlled objects and if
+      --  created will violate the restriction.
 
       elsif Restriction_Active (No_Nested_Finalization)
         and then not Is_Library_Level_Entity (Ptr_Typ)
       then
          return False;
 
+      --  Do not consider an access type subject to pragma No_Heap_Finalization
+      --  because objects allocated through such a type are not to be finalized
+      --  when the access type goes out of scope.
+
+      elsif No_Heap_Finalization (Ptr_Typ) then
+         return False;
+
       --  Do not create finalization masters in GNATprove mode because this
       --  causes unwanted extra expansion. A compilation in this mode must
       --  keep the tree as close as possible to the original sources.
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 4bfd8b9..034df56 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -481,12 +481,6 @@ package body Exp_Util is
      (N           : Node_Id;
       Is_Allocate : Boolean)
    is
-      Desig_Typ    : Entity_Id;
-      Expr         : Node_Id;
-      Pool_Id      : Entity_Id;
-      Proc_To_Call : Node_Id := Empty;
-      Ptr_Typ      : Entity_Id;
-
       function Find_Object (E : Node_Id) return Node_Id;
       --  Given an arbitrary expression of an allocator, try to find an object
       --  reference in it, otherwise return the original expression.
@@ -576,6 +570,15 @@ package body Exp_Util is
          return False;
       end Is_Allocate_Deallocate_Proc;
 
+      --  Local variables
+
+      Desig_Typ    : Entity_Id;
+      Expr         : Node_Id;
+      Needs_Fin    : Boolean;
+      Pool_Id      : Entity_Id;
+      Proc_To_Call : Node_Id := Empty;
+      Ptr_Typ      : Entity_Id;
+
    --  Start of processing for Build_Allocate_Deallocate_Proc
 
    begin
@@ -667,7 +670,15 @@ package body Exp_Util is
          return;
       end if;
 
-      if Needs_Finalization (Desig_Typ) then
+      --  Finalization actions are required when the object to be allocated or
+      --  deallocated needs these actions and the associated access type is not
+      --  subject to pragma No_Heap_Finalization.
+
+      Needs_Fin :=
+        Needs_Finalization (Desig_Typ)
+          and then not No_Heap_Finalization (Ptr_Typ);
+
+      if Needs_Fin then
 
          --  Certain run-time configurations and targets do not provide support
          --  for controlled types.
@@ -737,7 +748,7 @@ package body Exp_Util is
 
             --  c) Finalization master
 
-            if Needs_Finalization (Desig_Typ) then
+            if Needs_Fin then
                Fin_Mas_Id  := Finalization_Master (Ptr_Typ);
                Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
 
@@ -761,7 +772,7 @@ package body Exp_Util is
             --  Primitive Finalize_Address is never generated in CodePeer mode
             --  since it contains an Unchecked_Conversion.
 
-            if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
+            if Needs_Fin and then not CodePeer_Mode then
                Fin_Addr_Id := Finalize_Address (Desig_Typ);
                pragma Assert (Present (Fin_Addr_Id));
 
@@ -807,8 +818,8 @@ package body Exp_Util is
 
          --  h) Is_Controlled
 
-         if Needs_Finalization (Desig_Typ) then
-            declare
+         if Needs_Fin then
+            Is_Controlled : declare
                Flag_Id   : constant Entity_Id := Make_Temporary (Loc, 'F');
                Flag_Expr : Node_Id;
                Param     : Node_Id;
@@ -904,7 +915,7 @@ package body Exp_Util is
                     Expression          => Flag_Expr));
 
                Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
-            end;
+            end Is_Controlled;
 
          --  The object is not controlled
 
@@ -935,19 +946,19 @@ package body Exp_Util is
 
          Insert_Action (N,
            Make_Subprogram_Body (Loc,
-             Specification =>
+             Specification              =>
 
                --  procedure Pnn
 
                Make_Procedure_Specification (Loc,
-                 Defining_Unit_Name => Proc_Id,
+                 Defining_Unit_Name       => Proc_Id,
                  Parameter_Specifications => New_List (
 
                   --  P : Root_Storage_Pool
 
                    Make_Parameter_Specification (Loc,
                      Defining_Identifier => Make_Temporary (Loc, 'P'),
-                     Parameter_Type =>
+                     Parameter_Type      =>
                        New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
 
                   --  A : [out] Address
@@ -972,13 +983,14 @@ package body Exp_Util is
                      Parameter_Type      =>
                        New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
 
-             Declarations => No_List,
+             Declarations               => No_List,
 
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (
                    Make_Procedure_Call_Statement (Loc,
-                     Name => New_Occurrence_Of (Proc_To_Call, Loc),
+                     Name                   =>
+                       New_Occurrence_Of (Proc_To_Call, Loc),
                      Parameter_Associations => Actuals)))));
 
          --  The newly generated Allocate / Deallocate becomes the default
@@ -10252,7 +10264,8 @@ package body Exp_Util is
          --  Class-wide types are treated as controlled because derivations
          --  from the root type can introduce controlled components.
 
-         return Is_Class_Wide_Type (T)
+         return
+           Is_Class_Wide_Type (T)
              or else Is_Controlled (T)
              or else Has_Some_Controlled_Component (T)
              or else
diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb
index 6db8291..0024eec 100644
--- a/gcc/ada/fname.adb
+++ b/gcc/ada/fname.adb
@@ -230,8 +230,8 @@ package body Fname is
       Renamings_Included : Boolean := True) return Boolean
    is
       Result : constant Boolean :=
-        Is_Predefined_File_Name
-          (Get_Name_String (Fname), Renamings_Included);
+                 Is_Predefined_File_Name
+                   (Get_Name_String (Fname), Renamings_Included);
    begin
       return Result;
    end Is_Predefined_File_Name;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 9ef851d..94fdd8a 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -1115,6 +1115,11 @@ package Opt is
    --  in the spec of the extended main unit. Used to determine if we need to
    --  do special tests for violation of this aspect.
 
+   No_Heap_Finalization_Pragma : Node_Id := Empty;
+   --  GNAT
+   --  Set to point to a No_Heap_Finalization pragma defined in a configuration
+   --  file.
+
    No_Main_Subprogram : Boolean := False;
    --  GNATMAKE, GNATBIND
    --  Set to True if compilation/binding of a program without main
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 85cd899..02223c8 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1410,6 +1410,7 @@ begin
          | Pragma_Memory_Size
          | Pragma_No_Body
          | Pragma_No_Elaboration_Code_All
+         | Pragma_No_Heap_Finalization
          | Pragma_No_Inline
          | Pragma_No_Return
          | Pragma_No_Run_Time
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index cbae00f..6b8a453 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2195,6 +2195,10 @@ package body Sem_Ch3 is
       --  Utility to resolve the expressions of aspects at the end of a list of
       --  declarations.
 
+      function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean;
+      --  Check if an inner package has entities within it that rely on library
+      --  level private types where the full view has not been seen.
+
       -----------------
       -- Adjust_Decl --
       -----------------
@@ -2480,6 +2484,40 @@ package body Sem_Ch3 is
          end loop;
       end Resolve_Aspects;
 
+      -------------------------------
+      -- Uses_Unseen_Lib_Unit_Priv --
+      -------------------------------
+
+      function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is
+         Curr : Entity_Id;
+
+      begin
+         --  Avoid looking through scopes that do not meet the precondition of
+         --  Pkg not being within a library unit spec.
+
+         if not Is_Compilation_Unit (Pkg)
+           and then not Is_Generic_Instance (Pkg)
+           and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
+         then
+            --  Loop through all entities in the current scope to identify
+            --  an entity that depends on a private type.
+
+            Curr := First_Entity (Pkg);
+            loop
+               if Nkind (Curr) in N_Entity
+                 and then Depends_On_Private (Curr)
+               then
+                  return True;
+               end if;
+
+               exit when Last_Entity (Current_Scope) = Curr;
+               Curr := Next_Entity (Curr);
+            end loop;
+         end if;
+
+         return False;
+      end Uses_Unseen_Lib_Unit_Priv;
+
       --  Local variables
 
       Context     : Node_Id   := Empty;
@@ -2489,10 +2527,6 @@ package body Sem_Ch3 is
       Body_Seen : Boolean := False;
       --  Flag set when the first body [stub] is encountered
 
-      Ignore_Freezing : Boolean;
-      --  Flag set when deciding to freeze an expression function in the
-      --  current scope.
-
    --  Start of processing for Analyze_Declarations
 
    begin
@@ -2631,89 +2665,57 @@ package body Sem_Ch3 is
          --  care to attach the bodies at a proper place in the tree so as to
          --  not cause unwanted freezing at that point.
 
-         elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
-
-            --  Check for an edge case that may cause premature freezing of
-            --  a private type. If there is a type which depends on another
-            --  private type from an enclosing package that is in the same
-            --  scope as a non-completing expression function then we cannot
-            --  freeze here.
+         --  It is also necessary to check for a case where both an expression
+         --  function is used and the current scope depends on an unseen
+         --  private type from a library unit, otherwise premature freezing of
+         --  the private type will occur.
 
-            Ignore_Freezing := False;
-
-            if Nkind (Next_Decl) = N_Subprogram_Body
-              and then Was_Expression_Function (Next_Decl)
-              and then not Is_Compilation_Unit (Current_Scope)
-              and then not Is_Generic_Instance (Current_Scope)
-              and then not In_Package_Body
-                             (Enclosing_Lib_Unit_Entity (Current_Scope))
+         elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl)
+           and then ((Nkind (Next_Decl) /= N_Subprogram_Body
+                      or else not Was_Expression_Function (Next_Decl))
+                     or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope))
+         then
+            --  When a controlled type is frozen, the expander generates stream
+            --  and controlled-type support routines. If the freeze is caused
+            --  by the stand-alone body of Initialize, Adjust, or Finalize, the
+            --  expander will end up using the wrong version of these routines,
+            --  as the body has not been processed yet. To remedy this, detect
+            --  a late controlled primitive and create a proper spec for it.
+            --  This ensures that the primitive will override its inherited
+            --  counterpart before the freeze takes place.
+
+            --  If the declaration we just processed is a body, do not attempt
+            --  to examine Next_Decl as the late primitive idiom can only apply
+            --  to the first encountered body.
+
+            --  The spec of the late primitive is not generated in ASIS mode to
+            --  ensure a consistent list of primitives that indicates the true
+            --  semantic structure of the program (which is not relevant when
+            --  generating executable code).
+
+            --  ??? A cleaner approach may be possible and/or this solution
+            --  could be extended to general-purpose late primitives, TBD.
+
+            if not ASIS_Mode
+              and then not Body_Seen
+              and then not Is_Body (Decl)
             then
-               --  Loop through all entities in the current scope to identify
-               --  an instance of the edge case outlined above and ignore
-               --  freezing if it is detected.
-
-               declare
-                  Curr : Entity_Id := First_Entity (Current_Scope);
-               begin
-                  loop
-                     if Nkind (Curr) in N_Entity
-                       and then Depends_On_Private (Curr)
-                     then
-                        Ignore_Freezing := True;
-                        exit;
-                     end if;
-
-                     exit when Last_Entity (Current_Scope) = Curr;
-                     Curr := Next_Entity (Curr);
-                  end loop;
-               end;
-            end if;
-
-            if not Ignore_Freezing then
-
-               --  When a controlled type is frozen, the expander generates
-               --  stream and controlled-type support routines. If the freeze
-               --  is caused by the stand-alone body of Initialize, Adjust, or
-               --  Finalize, the expander will end up using the wrong version
-               --  of these routines, as the body has not been processed yet.
-               --  To remedy this, detect a late controlled primitive and
-               --  create a proper spec for it. This ensures that the primitive
-               --  will override its inherited counterpart before the freeze
-               --  takes place.
-
-               --  If the declaration we just processed is a body, do not
-               --  attempt to examine Next_Decl as the late primitive idiom can
-               --  only apply to the first encountered body.
-
-               --  The spec of the late primitive is not generated in ASIS mode
-               --  to ensure a consistent list of primitives that indicates the
-               --  true semantic structure of the program (which is not
-               --  relevant when generating executable code).
-
-               --  ??? A cleaner approach may be possible and/or this solution
-               --  could be extended to general-purpose late primitives, TBD.
-
-               if not ASIS_Mode
-                 and then not Body_Seen
-                 and then not Is_Body (Decl)
-               then
-                  Body_Seen := True;
+               Body_Seen := True;
 
-                  if Nkind (Next_Decl) = N_Subprogram_Body then
-                     Handle_Late_Controlled_Primitive (Next_Decl);
-                  end if;
+               if Nkind (Next_Decl) = N_Subprogram_Body then
+                  Handle_Late_Controlled_Primitive (Next_Decl);
                end if;
+            end if;
 
-               Adjust_Decl;
+            Adjust_Decl;
 
-               --  The generated body of an expression function does not
-               --  freeze, unless it is a completion, in which case only the
-               --  expression itself freezes. This is handled when the body
-               --  itself is analyzed (see Freeze_Expr_Types, sem_ch6.adb).
+            --  The generated body of an expression function does not freeze,
+            --  unless it is a completion, in which case only the expression
+            --  itself freezes. This is handled when the body itself is
+            --  analyzed (see Freeze_Expr_Types, sem_ch6.adb).
 
-               Freeze_All (Freeze_From, Decl);
-               Freeze_From := Last_Entity (Current_Scope);
-            end if;
+            Freeze_All (Freeze_From, Decl);
+            Freeze_From := Last_Entity (Current_Scope);
          end if;
 
          Decl := Next_Decl;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 1cdb7a0..ddb7038 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -4295,6 +4295,7 @@ package body Sem_Ch4 is
       Comp          : Entity_Id;
       Has_Candidate : Boolean := False;
       In_Scope      : Boolean;
+      Is_Private_Op : Boolean;
       Parent_N      : Node_Id;
       Pent          : Entity_Id := Empty;
       Prefix_Type   : Entity_Id;
@@ -4825,7 +4826,7 @@ package body Sem_Ch4 is
 
          --  Find visible operation with given name. For a protected type,
          --  the possible candidates are discriminants, entries or protected
-         --  procedures. For a task type, the set can only include entries or
+         --  subprograms. For a task type, the set can only include entries or
          --  discriminants if the task type is not an enclosing scope. If it
          --  is an enclosing scope (e.g. in an inner task) then all entities
          --  are visible, but the prefix must denote the enclosing scope, i.e.
@@ -4833,6 +4834,7 @@ package body Sem_Ch4 is
 
          Set_Etype (Sel, Any_Type);
          In_Scope := In_Open_Scopes (Prefix_Type);
+         Is_Private_Op := False;
 
          while Present (Comp) loop
 
@@ -4845,6 +4847,9 @@ package body Sem_Ch4 is
                             or else Comp /= First_Private_Entity (Type_To_Use))
                then
                   Add_One_Interp (Sel, Comp, Etype (Comp));
+                  if Comp = First_Private_Entity (Type_To_Use) then
+                     Is_Private_Op := True;
+                  end if;
 
                   --  If the prefix is tagged, the correct interpretation may
                   --  lie in the primitive or class-wide operations of the
@@ -4924,6 +4929,12 @@ package body Sem_Ch4 is
             then
                null;
 
+            elsif Is_Protected_Type (Prefix_Type)
+              and then Is_Overloadable (Entity (Sel))
+              and then not Is_Private_Op
+            then
+               null;
+
             else
                Error_Msg_NE
                  ("invalid reference to internal operation of some object of "
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index fd630af..33282a0 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -3857,8 +3857,7 @@ package body Sem_Ch5 is
                         Set_Etype (R_Copy, It.Typ);
 
                      else
-                        Error_Msg_N
-                          ("ambiguous domain of iteration", R_Copy);
+                        Error_Msg_N ("ambiguous domain of iteration", R_Copy);
                      end if;
                   end if;
                end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index b8eb6ad..41f1e53 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -734,21 +734,6 @@ package body Sem_Ch6 is
          Subtype_Ind : constant Node_Id :=
                          Object_Definition (Original_Node (Obj_Decl));
 
-         R_Type_Is_Anon_Access : constant Boolean :=
-             Ekind_In (R_Type,
-                       E_Anonymous_Access_Subprogram_Type,
-                       E_Anonymous_Access_Protected_Subprogram_Type,
-                       E_Anonymous_Access_Type);
-         --  True if return type of the function is an anonymous access type
-         --  Can't we make Is_Anonymous_Access_Type in einfo ???
-
-         R_Stm_Type_Is_Anon_Access : constant Boolean :=
-             Ekind_In (R_Stm_Type,
-                       E_Anonymous_Access_Subprogram_Type,
-                       E_Anonymous_Access_Protected_Subprogram_Type,
-                       E_Anonymous_Access_Type);
-         --  True if type of the return object is an anonymous access type
-
          procedure Error_No_Match (N : Node_Id);
          --  Output error messages for case where types do not statically
          --  match. N is the location for the messages.
@@ -783,10 +768,9 @@ package body Sem_Ch6 is
          --  "access T", and that the subtypes statically match:
          --   if this is an access to subprogram the signatures must match.
 
-         if R_Type_Is_Anon_Access then
-            if R_Stm_Type_Is_Anon_Access then
-               if
-                 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
+         if Is_Anonymous_Access_Type (R_Type) then
+            if Is_Anonymous_Access_Type (R_Stm_Type) then
+               if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
                then
                   if Base_Type (Designated_Type (R_Stm_Type)) /=
                      Base_Type (Designated_Type (R_Type))
@@ -796,11 +780,11 @@ package body Sem_Ch6 is
                   end if;
 
                else
-                  --  For two anonymous access to subprogram types, the
-                  --  types themselves must be type conformant.
+                  --  For two anonymous access to subprogram types, the types
+                  --  themselves must be type conformant.
 
                   if not Conforming_Types
-                    (R_Stm_Type, R_Type, Fully_Conformant)
+                           (R_Stm_Type, R_Type, Fully_Conformant)
                   then
                      Error_No_Match (Subtype_Ind);
                   end if;
@@ -813,10 +797,11 @@ package body Sem_Ch6 is
          --  If the return object is of an anonymous access type, then report
          --  an error if the function's result type is not also anonymous.
 
-         elsif R_Stm_Type_Is_Anon_Access then
-            pragma Assert (not R_Type_Is_Anon_Access);
-            Error_Msg_N ("anonymous access not allowed for function with "
-                         & "named access result", Subtype_Ind);
+         elsif Is_Anonymous_Access_Type (R_Stm_Type) then
+            pragma Assert (not Is_Anonymous_Access_Type (R_Type));
+            Error_Msg_N
+              ("anonymous access not allowed for function with named access "
+               & "result", Subtype_Ind);
 
          --  Subtype indication case: check that the return object's type is
          --  covered by the result type, and that the subtypes statically match
@@ -838,18 +823,16 @@ package body Sem_Ch6 is
 
             if Is_Access_Type (R_Type)
               and then
-               (Can_Never_Be_Null (R_Type)
-                 or else Null_Exclusion_Present (Parent (Scope_Id))) /=
-                                              Can_Never_Be_Null (R_Stm_Type)
+                (Can_Never_Be_Null (R_Type)
+                  or else Null_Exclusion_Present (Parent (Scope_Id))) /=
+                            Can_Never_Be_Null (R_Stm_Type)
             then
                Error_No_Match (Subtype_Ind);
             end if;
 
             --  AI05-103: for elementary types, subtypes must statically match
 
-            if Is_Constrained (R_Type)
-              or else Is_Access_Type (R_Type)
-            then
+            if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then
                if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
                   Error_No_Match (Subtype_Ind);
                end if;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2638b37..0029c6a 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -13815,9 +13815,10 @@ package body Sem_Prag is
 
                if Nkind (Stmt) = N_Pragma then
                   if Pragma_Name (Stmt) = Pname then
-                     Error_Msg_Name_1 := Pname;
-                     Error_Msg_Sloc   := Sloc (Stmt);
-                     Error_Msg_N ("pragma % duplicates pragma declared#", N);
+                     Duplication_Error
+                       (Prag => N,
+                        Prev => Stmt);
+                     raise Pragma_Exit;
                   end if;
 
                --  Skip internally generated code. Note that derived type
@@ -15321,9 +15322,10 @@ package body Sem_Prag is
 
                if Nkind (Stmt) = N_Pragma then
                   if Pragma_Name (Stmt) = Pname then
-                     Error_Msg_Name_1 := Pname;
-                     Error_Msg_Sloc   := Sloc (Stmt);
-                     Error_Msg_N ("pragma % duplicates pragma declared#", N);
+                     Duplication_Error
+                       (Prag => N,
+                        Prev => Stmt);
+                     raise Pragma_Exit;
                   end if;
 
                --  Task unit declared without a definition cannot be subject to
@@ -17828,6 +17830,134 @@ package body Sem_Prag is
                Opt.No_Elab_Code_All_Pragma := N;
             end if;
 
+         --------------------------
+         -- No_Heap_Finalization --
+         --------------------------
+
+         --  pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
+
+         when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
+            Context : constant Node_Id := Parent (N);
+            Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
+            Prev    : Node_Id;
+            Typ     : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_No_Identifiers;
+
+            --  The pragma appears in a configuration file
+
+            if No (Context) then
+               Check_Arg_Count (0);
+               Check_Valid_Configuration_Pragma;
+
+               --  Detect a duplicate pragma
+
+               if Present (No_Heap_Finalization_Pragma) then
+                  Duplication_Error
+                    (Prag => N,
+                     Prev => No_Heap_Finalization_Pragma);
+                  raise Pragma_Exit;
+               end if;
+
+               No_Heap_Finalization_Pragma := N;
+
+            --  Otherwise the pragma should be associated with a library-level
+            --  named access-to-object type.
+
+            else
+               Check_Arg_Count (1);
+               Check_Arg_Is_Local_Name (Arg1);
+
+               Find_Type (Typ_Arg);
+               Typ := Entity (Typ_Arg);
+
+               --  The type being subjected to the pragma is erroneous
+
+               if Typ = Any_Type then
+                  Error_Pragma ("cannot find type referenced by pragma %");
+
+               --  The pragma is applied to an incomplete or generic formal
+               --  type way too early.
+
+               elsif Rep_Item_Too_Early (Typ, N) then
+                  return;
+
+               else
+                  Typ := Underlying_Type (Typ);
+               end if;
+
+               --  The pragma must apply to an access-to-object type
+
+               if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
+                  null;
+
+               --  Give a detailed error message on all other access type kinds
+
+               elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
+                  Error_Pragma
+                    ("pragma % cannot apply to access protected subprogram "
+                     & "type");
+
+               elsif Ekind (Typ) = E_Access_Subprogram_Type then
+                  Error_Pragma
+                    ("pragma % cannot apply to access subprogram type");
+
+               elsif Is_Anonymous_Access_Type (Typ) then
+                  Error_Pragma
+                    ("pragma % cannot apply to anonymous access type");
+
+               --  Give a general error message in case the pragma applies to a
+               --  non-access type.
+
+               else
+                  Error_Pragma
+                    ("pragma % must apply to library level access type");
+               end if;
+
+               --  At this point the argument denotes an access-to-object type.
+               --  Ensure that the type is declared at the library level.
+
+               if Is_Library_Level_Entity (Typ) then
+                  null;
+
+               --  Qietly ignore an access-to-object type originally declared
+               --  at the library level within a generic, but instantiated at
+               --  a non-library level. As a result the access-to-object type
+               --  "loses" its No_Heap_Finalization property.
+
+               elsif In_Instance then
+                  raise Pragma_Exit;
+
+               else
+                  Error_Pragma
+                    ("pragma % must apply to library level access type");
+               end if;
+
+               --  Detect a duplicate pragma
+
+               if Present (No_Heap_Finalization_Pragma) then
+                  Duplication_Error
+                    (Prag => N,
+                     Prev => No_Heap_Finalization_Pragma);
+                  raise Pragma_Exit;
+
+               else
+                  Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
+
+                  if Present (Prev) then
+                     Duplication_Error
+                       (Prag => N,
+                        Prev => Prev);
+                     raise Pragma_Exit;
+                  end if;
+               end if;
+
+               Record_Rep_Item (Typ, N);
+            end if;
+         end No_Heap_Finalization;
+
          ---------------
          -- No_Inline --
          ---------------
@@ -21402,8 +21532,9 @@ package body Sem_Prag is
                Check_Valid_Configuration_Pragma;
 
                if Present (SPARK_Mode_Pragma) then
-                  Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
-                  Error_Msg_N ("pragma% duplicates pragma declared#", N);
+                  Duplication_Error
+                    (Prag => N,
+                     Prev => SPARK_Mode_Pragma);
                   raise Pragma_Exit;
                end if;
 
@@ -21433,9 +21564,9 @@ package body Sem_Prag is
 
                   if Nkind (Stmt) = N_Pragma then
                      if Pragma_Name (Stmt) = Pname then
-                        Error_Msg_Name_1 := Pname;
-                        Error_Msg_Sloc   := Sloc (Stmt);
-                        Error_Msg_N ("pragma% duplicates pragma declared#", N);
+                        Duplication_Error
+                          (Prag => N,
+                           Prev => Stmt);
                         raise Pragma_Exit;
                      end if;
 
@@ -28867,6 +28998,7 @@ package body Sem_Prag is
       Pragma_No_Return                      =>  0,
       Pragma_No_Body                        =>  0,
       Pragma_No_Elaboration_Code_All        =>  0,
+      Pragma_No_Heap_Finalization           =>  0,
       Pragma_No_Inline                      =>  0,
       Pragma_No_Run_Time                    => -1,
       Pragma_No_Strict_Aliasing             => -1,
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 144fd7d..8b78008 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12846,6 +12846,7 @@ package body Sem_Util is
       S : constant Ureal := Small_Value (T);
       M : Urealp.Save_Mark;
       R : Boolean;
+
    begin
       M := Urealp.Mark;
       R := (U = UR_Trunc (U / S) * S);
@@ -17491,6 +17492,32 @@ package body Sem_Util is
       end if;
    end New_Requires_Transient_Scope;
 
+   --------------------------
+   -- No_Heap_Finalization --
+   --------------------------
+
+   function No_Heap_Finalization (Typ : Entity_Id) return Boolean is
+   begin
+      if Ekind_In (Typ, E_Access_Type, E_General_Access_Type)
+        and then Is_Library_Level_Entity (Typ)
+      then
+         --  A global No_Heap_Finalization pragma applies to all library-level
+         --  named access-to-object types.
+
+         if Present (No_Heap_Finalization_Pragma) then
+            return True;
+
+         --  The library-level named access-to-object type itself is subject to
+         --  pragma No_Heap_Finalization.
+
+         elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then
+            return True;
+         end if;
+      end if;
+
+      return False;
+   end No_Heap_Finalization;
+
    -----------------------
    -- Normalize_Actuals --
    -----------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 06be2f8..7c0affc 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1983,6 +1983,9 @@ package Sem_Util is
    --  Note that the result produced is always an expression, not a parameter
    --  association node, even if named notation was used.
 
+   function No_Heap_Finalization (Typ : Entity_Id) return Boolean;
+   --  Determine whether type Typ is subject to pragma No_Heap_Finalization
+
    procedure Normalize_Actuals
      (N       : Node_Id;
       S       : Entity_Id;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 5941beb..33ba6a5 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -433,6 +433,7 @@ package Snames is
    Name_License                        : constant Name_Id := N + $; -- GNAT
    Name_Locking_Policy                 : constant Name_Id := N + $;
    Name_Loop_Optimize                  : constant Name_Id := N + $; -- GNAT
+   Name_No_Heap_Finalization           : constant Name_Id := N + $; -- GNAT
    Name_No_Run_Time                    : constant Name_Id := N + $; -- GNAT
    Name_No_Strict_Aliasing             : constant Name_Id := N + $; -- GNAT
    Name_No_Tagged_Streams              : constant Name_Id := N + $; -- GNAT
@@ -1797,6 +1798,7 @@ package Snames is
       Pragma_License,
       Pragma_Locking_Policy,
       Pragma_Loop_Optimize,
+      Pragma_No_Heap_Finalization,
       Pragma_No_Run_Time,
       Pragma_No_Strict_Aliasing,
       Pragma_No_Tagged_Streams,