Bug 66242

Created attachment 35587 [details]
Demonstrators

First detected in GCC 4.9.1 built for arm-eabi on
x86_64-apple-darwin13 (Mac OS X Mavericks) with these pragmas on
System:

   pragma Profile (Ravenscar);
   pragma Restrictions (No_Enumeration_Maps);
   pragma Restrictions (No_Exception_Propagation);
   pragma Restrictions (No_Recursion);

Also observed with GCC 5.1.0, same build.

The demonstrators use

   pragma Restrictions (No_Exception_Propagation);
   with Ada.Finalization;
   package Fin is
      type F is new Ada.Finalization.Controlled with null record;
   end Fin;

and show the problem with the hosted compiler. There are two, because
only the first such error is detected.

(1) Unchecked deallocation

   with Ada.Finalization;
   with Ada.Unchecked_Deallocation;
   with Fin; use Fin;
   procedure Fin_Deallocation is

      type F_P is access F;
      procedure Delete
        is new Ada.Unchecked_Deallocation (F, F_P);

      procedure Check_Heap_1 is
         An_F_P : F_P :=
           new F'(Ada.Finalization.Controlled with null record);
      begin
         Delete (An_F_P);
      end Check_Heap_1;

   begin
      Check_Heap_1;
   end Fin_Deallocation;

results in

    17.    procedure Check_Heap_1 is
    18.       An_F_P : F_P :=
    19.         new F'(Ada.Finalization.Controlled with null record);
    20.    begin
    21.       Delete (An_F_P);
              |
        >>> "" is undefined

    22.    end Check_Heap_1;

The end of the -gnatdg output for Check_Heap_1 is

   begin
      if an_f_p /= null then
         B22b : begin
            system__soft_links__abort_defer.all;
            B23b : begin
               [constraint_error when
                 an_f_p = null
                 "access check failed"]
               [type T24b is procedure (object : in out fin__TfC)]
               [subtype T25b is access T24b]
               T25b!(fin__fH!(fin__TfC!(an_f_p.all)._tag).all (2)).all
                 (fin__TfC!(an_f_p.all));
            exception
               when others =>
                  any id := true;                        <<<<<<<<<<<<<<<
            end B23b;
         at end
            system__standard_library__abort_undefer_direct;
         end B22b;
         free an_f_p;
         an_f_p := null;
         if  then
            [program_error "finalize raised exception"]  <<<<<<<<<<<<<<<
         end if;
      end if;
   end check_heap_1;

which I take to mean that the compiler has tried to generate an
exception handler which is incompatible with pragma Restrictions
(No_Exception_Propagation).

I've traced this to exp_intr.adb, and written a patch which resolves
this problem.

(2) Returning a controlled type

I see also that in exp_ch7.adb all the cases where an exception
handler like this one might be generated are protected by a check for
No_Exception_Propagation, except for one at line 4751 in
Process_Transient_Objects. To demonstrate this,

   with Ada.Finalization;
   with Fin; use Fin;
   procedure Fin_Return_Controlled is
      type R is record
         A, B : F;
      end record;
      function Get_F return R is
      begin
         return (A => F'(Ada.Finalization.Controlled with null record),
                 B => F'(Ada.Finalization.Controlled with null record));
      end Get_F;
      An_F : R;
   begin
      An_F := Get_F;
   end Fin_Return_Controlled;

fails as

     8. with Ada.Finalization;
     9. with Fin; use Fin;
    10. procedure Fin_Return_Controlled is
    11.    type R is record
    12.       A, B : F;
    13.    end record;
    14.    function Get_F return R is
    15.    begin
    16.       return (A => F'(Ada.Finalization.Controlled with null record),
    17.               B => F'(Ada.Finalization.Controlled with null record));
    18.    end Get_F;
    19.    An_F : R;
    20. begin
    21.    An_F := Get_F;
                   |
        >>> "" is undefined

    22. end Fin_Return_Controlled;

and the corresponding part of the -gnatdg output is

      B26b : declare
      begin
         B27b : begin
            T25b := null;
            fin_return_controlled__rDF (R18b.all, f => true);
         exception
            when others =>
               any id := true;
         end B27b;
         if  then
            [program_error "finalize raised exception"]
         end if;
      end B26b;

with the same symptoms.

I have a patch for this too.

The patches apply (with considerable offsets) to GCC 5.1.0, but I
haven't tested them yet (indeed, I've only tested in the arm-eabi
build).