[Bug ada/47880] New: Free in System.Pool_Local raises Storage_Error

[brian_linux at shapes dot demon.co.uk]

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=47880

           Summary: Free in System.Pool_Local raises Storage_Error
           Product: gcc
           Version: 4.5.0
            Status: UNCONFIRMED
          Severity: minor
          Priority: P3
         Component: ada
        AssignedTo: unassig...@gcc.gnu.org
        ReportedBy: brian_li...@shapes.demon.co.uk


Created attachment 23451
  --> http://gcc.gnu.org/bugzilla/attachment.cgi?id=23451
Short test to raise Storage_Error in local pool

The attached code should not raise Storage_Error.

NOTE - using System.Pool_Global.Unbounded_No_Reclaim_Pool 
(commented out) instead of the pool shown, works as expected.

Using Free on a local pool is atypical since the entire pool is
usually freed when the program leaves its scope. 
However it ought to be valid, since a Deallocate method is provided in
s-pooloc.ads/b and Free is not explicitly prohibited.

(Tested on GCC4.5.0 and Adacore Libre 2010, confirmed by Ludovic Brenta on
4.4.5, 4.5.2)

Discussion on comp.lang.ada (by Ludovic Brenta) reveals the following...

This looks like a genuine bug at s-pooloc.adb:114.  To trigger the bug,
two conditions must hold simultaneously:

* the pool contains exactly one allocated object.
* the user calls Unchecked_Deallocation on this object.

The buggy code is:

   procedure Deallocate
     (Pool         : in out Unbounded_Reclaim_Pool;
      Address      : System.Address;
      Storage_Size : SSE.Storage_Count;
      Alignment    : SSE.Storage_Count)
   is
      pragma Warnings (Off, Storage_Size);
      pragma Warnings (Off, Alignment);

      Allocated : constant System.Address := Address - Pointers_Size;

   begin
      if Prev (Allocated).all = Null_Address then
         Pool.First := Next (Allocated).all;
         Prev (Pool.First).all := Null_Address; ------- <- Storage_Error
      else
         Next (Prev (Allocated).all).all := Next (Allocated).all;
      end if;

      if Next (Allocated).all /= Null_Address then
         Prev (Next (Allocated).all).all := Prev (Allocated).all;
      end if;

      Memory.Free (Allocated);
   end Deallocate;