[Ada] New pragma No_Heap_Finalization

This patch introduces support for pragma No_Heap_Finalization which has the
following syntax and semantics:

   pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];

Pragma `No_Heap_Finalization` may be used as a configuration pragma or as a
type-specific pragma.

In its configuration form, the pragma must appear within a configuration file
such as gnat.adc, without an argument. The pragma suppresses the call to
`Finalize` for heap-allocated objects created through library-level named
access-to-object types in case the designated type requires finalization
actions.

In its type-specific form, the argument of the pragma must denote a library-
level named access-to-object. The pragma suppresses the call to `Finalize` for
heap-allocated objects created through the specific access type in case the
designated type requires finalization actions.

It is still possible to finalize such heap-allocated objects by explicitly
deallocating them.

A library-level named access-to-object type declared within a generic unit will
lose its `No_Heap_Finalization` pragma when the instance unit does not appear
at the library level.

------------
-- Source --
------------

--  gen.ads

generic
   type Desig is private;

package Gen is
   type Ptr is access all Desig;
   pragma No_Heap_Finalization (Ptr);

   Obj : constant Ptr := new Desig;
end Gen;

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   type Location_Kind is
     (None,
      Library_In_Spec,
      Library_In_Body,
      Instance_Library,
      Instance_Nested,
      Nested);

   type Ctrl is new Controlled with record
      Id  : Natural := 0;
      Loc : Location_Kind := None;
   end record;

   procedure Finalize (Obj : in out Ctrl);
   procedure Initialize (Obj : in out Ctrl);

   function New_Id return Natural;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   Id_Gen : Natural := 0;

   procedure Finalize (Obj : in out Ctrl) is
   begin
      if Obj.Id = 0 then
         Put_Line ("ERROR: finalizing a finalized object");
      else
         Put_Line ("  fin:" & Obj.Id'Img);
         Put_Line ("  loc: " & Obj.Loc'Img);
         Obj.Id := 0;
      end if;
   end Finalize;

   procedure Initialize (Obj : in out Ctrl) is
   begin
      Obj.Id := New_Id;
   end Initialize;

   function New_Id return Natural is
   begin
      Id_Gen := Id_Gen + 100;
      return Id_Gen;
   end New_Id;
end Types;

--  pack.ads

with Ada.Finalization; use Ada.Finalization;
with Gen;
with Types;            use Types;

package Pack is
   type Ptr is access all Ctrl;
   pragma No_Heap_Finalization (Ptr);

   Obj_1 : Ptr := new Ctrl'(Controlled with
                             Id  => New_Id,
                             Loc => Library_In_Spec);

   Obj_2 : Ptr := new Ctrl'(Controlled with
                             Id  => New_Id,
                             Loc => Library_In_Spec);

   package Inst_1 is new Gen (Ctrl);

   procedure Proc;
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;

package body Pack is
   Obj_3 : Ptr := new Ctrl'(Controlled with
                             Id  => New_Id,
                             Loc => Library_In_Body);

   Obj_4 : Ptr := new Ctrl'(Controlled with
                             Id  => New_Id,
                             Loc => Library_In_Body);

   procedure Proc is
      procedure Free is new Ada.Unchecked_Deallocation (Ctrl, Ptr);
      package Inst_2 is new Gen (Ctrl);

      Obj_5 : Ptr;
      Obj_6 : Ptr;

   begin
      Put_Line ("Proc start");

      Inst_1.Obj.Loc := Instance_Library;
      Inst_2.Obj.Loc := Instance_Nested;

      Obj_5 := new Ctrl'(Controlled with Id => New_Id, Loc => Nested);
      Obj_6 := new Ctrl'(Controlled with Id => New_Id, Loc => Nested);

      Free (Obj_1);
      Free (Obj_3);
      Free (Obj_5);

      Put_Line ("Proc end");
   end Proc;
end Pack;

--  main.adb

with Pack; use Pack;

procedure Main is
begin
   Proc;
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q main.adb
$ ./main
Proc start
  fin: 100
  loc: LIBRARY_IN_SPEC
  fin: 400
  loc: LIBRARY_IN_BODY
  fin: 700
  loc: NESTED
Proc end
  fin: 600
  loc: INSTANCE_NESTED

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

[Ada] New pragma No_Heap_Finalization

Commit Message

Patch