[Ada] Deallocation of a single allocated object (PR ada/47880)

[Ada] Deallocation of a single allocated object (PR ada/47880)

[Arnaud Charlet]

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

This change fixes a seg fault when a local storage pool has a single allocated
object, and Unchecked_Deallocation is used to deallocate that object.

The following test case must compile and execute quietly:

$ gnatmake -q pooltest
$ ./pooltest

with System.Pool_Local;
with Ada.Unchecked_Deallocation;
procedure pooltest is

   type Node;
   type Treenode is access Node;
   type Node is record
      Left  : Treenode := null;
      Right : Treenode := null;
      Item  : Integer  := 0; 
   end record;

   P : System.Pool_Local.Unbounded_Reclaim_Pool;    
   for Treenode'Storage_Pool use P;

   procedure Free is new Ada.Unchecked_Deallocation(Node, Treenode);
   TestNode : Treenode;
begin
   Testnode := new Node'(null, null, 1);
   Free(Testnode);   
end pooltest;

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

2011-08-04  Thomas Quinot  <quinot@adacore.com>

	PR ada/47880
	* s-pooloc.adb (Deallocate): Fix the case of deallocating the only
	allocated object.

[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 1199 bytes --]

Index: s-pooloc.adb
===================================================================
--- s-pooloc.adb	(revision 177274)
+++ s-pooloc.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -111,7 +111,10 @@
    begin
       if Prev (Allocated).all = Null_Address then
          Pool.First := Next (Allocated).all;
-         Prev (Pool.First).all := Null_Address;
+
+         if Pool.First /= Null_Address then
+            Prev (Pool.First).all := Null_Address;
+         end if;
       else
          Next (Prev (Allocated).all).all := Next (Allocated).all;
       end if;