[Ada] Violation of No_Standard_Allocators_After_Elaboration not detected

[Ada] Violation of No_Standard_Allocators_After_Elaboration not detected

[Pierre-Marie de Rodat]

[-- Attachment #1: Type: text/plain, Size: 2979 bytes --]

The compiler fails to generate a call to detect allocators executed after
elaboration in cases where the allocator is associated with Global_Pool_Object.
The fix is to test for this associated storage pool as part of the condition
for generating a call to System.Elaboration_Allocators.Check_Standard_Alloctor.
Also, the exception Storage_Error is now generated instead of Program_Error
for such a run-time violation, as required by the Ada RM in D.7.

The following test must compile and execute quietly:

-- Put the pragma in gnat.adc:
pragma Restrictions (No_Standard_Allocators_After_Elaboration);

package Pkg_With_Allocators is

   type Priv is private;

   procedure Allocate
     (Use_Global_Allocator : Boolean;
      During_Elaboration   : Boolean);

private

   type Rec is record
      Int : Integer;
   end record;

   type Priv is access Rec;

end Pkg_With_Allocators;

package body Pkg_With_Allocators is

   Ptr : Priv;

   procedure Allocate
     (Use_Global_Allocator : Boolean;
      During_Elaboration   : Boolean)
   is
      type Local_Acc is access Rec;

      Local_Ptr : Local_Acc;

   begin
      if Use_Global_Allocator then
         Ptr := new Rec;  -- Raise Storage_Error if after elaboration
         Ptr.Int := 1;
      else
         Local_Ptr := new Rec;  -- Raise Storage_Error if after elaboration
         Local_Ptr.Int := 1;
      end if;

      if not During_Elaboration then
         raise Program_Error;  -- No earlier exception: FAIL
      end if;

   exception
      when Storage_Error =>
         if During_Elaboration then
            raise Program_Error;  -- No exception expected: FAIL
         else
            null;                 -- Expected Storage_Error: PASS
         end if;
      when others =>
         raise Program_Error;  -- Unexpected exception: FAIL
   end Allocate;

begin
   Allocate (Use_Global_Allocator => True, During_Elaboration => True);

   Allocate (Use_Global_Allocator => False, During_Elaboration => True);
end Pkg_With_Allocators;

with Pkg_With_Allocators;

procedure Alloc_Restriction_Main is
begin
   Pkg_With_Allocators.Allocate
     (Use_Global_Allocator => True,
      During_Elaboration   => False);

   Pkg_With_Allocators.Allocate
     (Use_Global_Allocator => False,
      During_Elaboration   => False);
end Alloc_Restriction_Main;

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

2018-07-16  Gary Dismukes  <dismukes@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Allocator): Test for Storage_Pool being RTE in
	addition to the existing test for no Storage_Pool as a condition
	enabling generation of the call to Check_Standard_Allocator when the
	restriction No_Standard_Allocators_After_Elaboration is active.
	* libgnat/s-elaall.ads (Check_Standard_Allocator): Correct comment to
	say that Storage_Error will be raised (rather than Program_Error).
	* libgnat/s-elaall.adb (Check_Standard_Allocator): Raise Storage_Error
	rather than Program_Error when Elaboration_In_Progress is False.

[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 1855 bytes --]

--- gcc/ada/exp_ch4.adb
+++ gcc/ada/exp_ch4.adb
@@ -4561,12 +4561,14 @@ package body Exp_Ch4 is
          end if;
       end if;
 
-      --  If no storage pool has been specified and we have the restriction
+      --  If no storage pool has been specified, or the storage pool
+      --  is System.Pool_Global.Global_Pool_Object, and the restriction
       --  No_Standard_Allocators_After_Elaboration is present, then generate
       --  a call to Elaboration_Allocators.Check_Standard_Allocator.
 
       if Nkind (N) = N_Allocator
-        and then No (Storage_Pool (N))
+        and then (No (Storage_Pool (N))
+                   or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
         and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
       then
          Insert_Action (N,

--- gcc/ada/libgnat/s-elaall.adb
+++ gcc/ada/libgnat/s-elaall.adb
@@ -45,7 +45,7 @@ package body System.Elaboration_Allocators is
    procedure Check_Standard_Allocator is
    begin
       if not Elaboration_In_Progress then
-         raise Program_Error with
+         raise Storage_Error with
            "standard allocator after elaboration is complete is not allowed "
            & "(No_Standard_Allocators_After_Elaboration restriction active)";
       end if;

--- gcc/ada/libgnat/s-elaall.ads
+++ gcc/ada/libgnat/s-elaall.ads
@@ -51,7 +51,7 @@ package System.Elaboration_Allocators is
    procedure Check_Standard_Allocator;
    --  Called as part of every allocator in a program for which the restriction
    --  No_Standard_Allocators_After_Elaboration is active. This will raise an
-   --  exception (Program_Error with an appropriate message) if it is called
+   --  exception (Storage_Error with an appropriate message) if it is called
    --  after the call to Mark_End_Of_Elaboration.
 
 end System.Elaboration_Allocators;