old-autovect-branch/gcc/testsuite/ada/acats/tests/cb/cb10002.a

   1 -- CB10002.A
   2
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that Storage_Error is raised when storage for allocated objects
  28 --      is exceeded.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      This test allocates a very large data structure.
  32 --
  33 --      In order to avoid running forever on virtual memory targets, the
  34 --      data structure is bounded in size, and elements are larger the longer
  35 --      the program runs.
  36 --
  37 --      The program attempts to allocate about 8,600,000 integers, or about
  38 --      32 Megabytes on a typical 32-bit machine.
  39 --
  40 --      If Storage_Error is raised, the data structure is deallocated.
  41 --      (Otherwise, Report.Result may fail as memory is exhausted).
  42
  43 -- CHANGE HISTORY:
  44 --      30 Aug 85   JRK     Ada 83 test created.
  45 --      14 Sep 99   RLB     Created Ada 95 test.
  46
  47
  48 with Report;
  49 with Ada.Unchecked_Deallocation;
  50 procedure CB10002 is
  51
  52    type Data_Space is array (Positive range <>) of Integer;
  53
  54    type Element (Size : Positive);
  55
  56    type Link is access Element;
  57
  58    type Element (Size : Positive) is
  59       record
  60          Parent : Link;
  61          Child  : Link;
  62          Sibling: Link;
  63          Data   : Data_Space (1 .. Size);
  64       end record;
  65
  66     procedure Free is new Ada.Unchecked_Deallocation (Element, Link);
  67
  68     Holder : array (1 .. 430) of Link;
  69     Last_Allocated : Natural := 0;
  70
  71     procedure Allocator (Count : in Positive) is
  72     begin
  73         -- Allocate various sized objects similar to what a real application
  74         -- would do.
  75         if Count in 1 .. 20 then
  76             Holder(Count) := new Element (Report.Ident_Int(10));
  77         elsif Count in 21 .. 40 then
  78             Holder(Count) := new Element (Report.Ident_Int(79));
  79         elsif Count in 41 .. 60 then
  80             Holder(Count) := new Element (Report.Ident_Int(250));
  81         elsif Count in 61 .. 80 then
  82             Holder(Count) := new Element (Report.Ident_Int(520));
  83         elsif Count in 81 .. 100 then
  84             Holder(Count) := new Element (Report.Ident_Int(1000));
  85         elsif Count in 101 .. 120 then
  86             Holder(Count) := new Element (Report.Ident_Int(2048));
  87         elsif Count in 121 .. 140 then
  88             Holder(Count) := new Element (Report.Ident_Int(4200));
  89         elsif Count in 141 .. 160 then
  90             Holder(Count) := new Element (Report.Ident_Int(7999));
  91         elsif Count in 161 .. 180 then
  92             Holder(Count) := new Element (Report.Ident_Int(15000));
  93         else -- 181..430
  94             Holder(Count) := new Element (Report.Ident_Int(32000));
  95         end if;
  96         Last_Allocated := Count;
  97     end Allocator;
  98
  99
 100 begin
 101    Report.Test ("CB10002", "Check that Storage_Error is raised when " &
 102                            "storage for allocated objects is exceeded");
 103
 104    begin
 105       for I in Holder'range loop
 106          Allocator (I);
 107       end loop;
 108       Report.Not_Applicable ("Unable to exhaust memory");
 109       for I in 1 .. Last_Allocated loop
 110          Free (Holder(I));
 111       end loop;
 112    exception
 113       when Storage_Error =>
 114          if Last_Allocated = 0 then
 115             Report.Failed ("Unable to allocate anything");
 116          else -- Clean up, so we have enough memory to report on the result.
 117             for I in 1 .. Last_Allocated loop
 118                Free (Holder(I));
 119             end loop;
 120             Report.Comment (Natural'Image(Last_Allocated) & " items allocated");
 121          end if;
 122       when others =>
 123          Report.Failed ("Wrong exception raised by heap overflow");
 124    end;
 125
 126    Report.Result;
 127
 128 end CB10002;