An address clause that overlays an object with a controlled object of a
component of a controlled object is erroneous, and the compiler replaces the
address clause with the corresponding raise statement. However, the analysis
of the address clause must not terminate prematurely, so that the back-end 
can complete code generation.

Compiling and executing main,adb must yield:

   main.adb:4:03: warning: in instantiation at erase_on_finalize.adb:22
   main.adb:4:03: warning: cannot use overlays with controlled objects
   main.adb:4:03: warning: Program_Error will be raised at run time

   raised PROGRAM_ERROR : main.adb:2 finalize/adjust raised exception

---
with Erase_On_Finalize;
procedure Main is

  package Sensitive_Integer is new Erase_On_Finalize (Integer);

  I1: Sensitive_Integer.Object := (Sensitive_Integer.Root with 1);
  I2: Sensitive_Integer.Object := (Sensitive_Integer.Root with 2);
  I3: Sensitive_Integer.Object := (Sensitive_Integer.Root with 3);

begin
  null;
end Main;
---
with Ada.Finalization;

generic
   type Data_Type is limited private;
package Erase_On_Finalize is

   subtype Root is Ada.Finalization.Limited_Controlled;

   type Object is new Root with
      record
         Contents : Data_Type;
      end record;

   overriding procedure Finalize (Obj: in out Object);

   -- Disallow dynamic memory allocation.
   type Object_Ref is access Object with Storage_Size => 0;

end Erase_On_Finalize;
---
with System;
with Interfaces;
with GNAT.Memory_Dump;
package body Erase_On_Finalize is

   subtype Byte_Type is Interfaces.Unsigned_8;
   use type Byte_Type;

   Erase_Pattern : constant Byte_Type := 0;

   procedure Erase_Bytes (Addr: System.Address; Bytes: Natural) is
      type Byte_View_Type is array (1 .. Bytes) of Byte_Type;
      Byte_View : Byte_View_Type with Address => Addr, Volatile;
   begin
      GNAT.Memory_Dump.Dump (Addr, Bytes);
      Byte_View := (others => Erase_Pattern);
   end Erase_Bytes;

   overriding procedure Finalize (Obj: in out Object) is
      type Byte_View_Type is array (1 .. (Obj.Contents'Size + 7) / 8)
        of Byte_Type;
      Byte_View : Byte_View_Type  with address => Obj.Contents'address,
           Volatile;
   begin
      GNAT.Memory_Dump.Dump (Byte_View'Address, Byte_View'Length);
      Byte_View := (others => Erase_Pattern);
   end Finalize;
end Erase_On_Finalize;

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

2015-10-20  Ed Schonberg  <schonb...@adacore.com>

        * sem_ch13.adb: nalyze_Attribute_Definition_Clause, case
        'Address):  If either object is controlled the overlay is
        erroneous, but analysis must be completed so that back-end sees
        address clause and completes code generation.  Improve text
        of warning.

Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb        (revision 229071)
+++ sem_ch13.adb        (working copy)
@@ -4711,20 +4711,22 @@
 
                   Find_Overlaid_Entity (N, O_Ent, Off);
 
-                  --  Overlaying controlled objects is erroneous
+                  --  Overlaying controlled objects is erroneous.
+                  --  Emit warning but continue analysis because program is
+                  --  itself legal, and back-end must see address clause.
 
                   if Present (O_Ent)
                     and then (Has_Controlled_Component (Etype (O_Ent))
                                or else Is_Controlled (Etype (O_Ent)))
+                    and then not Inside_A_Generic
                   then
                      Error_Msg_N
-                       ("??cannot overlay with controlled object", Expr);
+                       ("??cannot use overlays with controlled objects", Expr);
                      Error_Msg_N
                        ("\??Program_Error will be raised at run time", Expr);
                      Insert_Action (Declaration_Node (U_Ent),
                        Make_Raise_Program_Error (Loc,
                          Reason => PE_Overlaid_Controlled_Object));
-                     return;
 
                   elsif Present (O_Ent)
                     and then Ekind (U_Ent) = E_Constant

Reply via email to