3 -- Grant of Unlimited Rights
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
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.
27 -- Check that Storage_Error is raised when storage for allocated objects
31 -- This test allocates a very large data structure.
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
37 -- The program attempts to allocate about 8,600,000 integers, or about
38 -- 32 Megabytes on a typical 32-bit machine.
40 -- If Storage_Error is raised, the data structure is deallocated.
41 -- (Otherwise, Report.Result may fail as memory is exhausted).
44 -- 30 Aug 85 JRK Ada 83 test created.
45 -- 14 Sep 99 RLB Created Ada 95 test.
49 with Ada
.Unchecked_Deallocation
;
52 type Data_Space
is array (Positive range <>) of Integer;
54 type Element
(Size
: Positive);
56 type Link
is access Element
;
58 type Element
(Size
: Positive) is
63 Data
: Data_Space
(1 .. Size
);
66 procedure Free
is new Ada
.Unchecked_Deallocation
(Element
, Link
);
68 Holder
: array (1 .. 430) of Link
;
69 Last_Allocated
: Natural := 0;
71 procedure Allocator
(Count
: in Positive) is
73 -- Allocate various sized objects similar to what a real application
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));
94 Holder
(Count
) := new Element
(Report
.Ident_Int
(32000));
96 Last_Allocated
:= Count
;
101 Report
.Test
("CB10002", "Check that Storage_Error is raised when " &
102 "storage for allocated objects is exceeded");
105 for I
in Holder
'range loop
108 Report
.Not_Applicable
("Unable to exhaust memory");
109 for I
in 1 .. Last_Allocated
loop
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
120 Report
.Comment
(Natural'Image(Last_Allocated
) & " items allocated");
123 Report
.Failed
("Wrong exception raised by heap overflow");