diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a | 128 |
1 files changed, 128 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a new file mode 100644 index 000000000..f3099d4a2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cb/cb10002.a @@ -0,0 +1,128 @@ +-- CB10002.A + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that Storage_Error is raised when storage for allocated objects +-- is exceeded. +-- +-- TEST DESCRIPTION: +-- This test allocates a very large data structure. +-- +-- In order to avoid running forever on virtual memory targets, the +-- data structure is bounded in size, and elements are larger the longer +-- the program runs. +-- +-- The program attempts to allocate about 8,600,000 integers, or about +-- 32 Megabytes on a typical 32-bit machine. +-- +-- If Storage_Error is raised, the data structure is deallocated. +-- (Otherwise, Report.Result may fail as memory is exhausted). + +-- CHANGE HISTORY: +-- 30 Aug 85 JRK Ada 83 test created. +-- 14 Sep 99 RLB Created Ada 95 test. + + +with Report; +with Ada.Unchecked_Deallocation; +procedure CB10002 is + + type Data_Space is array (Positive range <>) of Integer; + + type Element (Size : Positive); + + type Link is access Element; + + type Element (Size : Positive) is + record + Parent : Link; + Child : Link; + Sibling: Link; + Data : Data_Space (1 .. Size); + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Element, Link); + + Holder : array (1 .. 430) of Link; + Last_Allocated : Natural := 0; + + procedure Allocator (Count : in Positive) is + begin + -- Allocate various sized objects similar to what a real application + -- would do. + if Count in 1 .. 20 then + Holder(Count) := new Element (Report.Ident_Int(10)); + elsif Count in 21 .. 40 then + Holder(Count) := new Element (Report.Ident_Int(79)); + elsif Count in 41 .. 60 then + Holder(Count) := new Element (Report.Ident_Int(250)); + elsif Count in 61 .. 80 then + Holder(Count) := new Element (Report.Ident_Int(520)); + elsif Count in 81 .. 100 then + Holder(Count) := new Element (Report.Ident_Int(1000)); + elsif Count in 101 .. 120 then + Holder(Count) := new Element (Report.Ident_Int(2048)); + elsif Count in 121 .. 140 then + Holder(Count) := new Element (Report.Ident_Int(4200)); + elsif Count in 141 .. 160 then + Holder(Count) := new Element (Report.Ident_Int(7999)); + elsif Count in 161 .. 180 then + Holder(Count) := new Element (Report.Ident_Int(15000)); + else -- 181..430 + Holder(Count) := new Element (Report.Ident_Int(32000)); + end if; + Last_Allocated := Count; + end Allocator; + + +begin + Report.Test ("CB10002", "Check that Storage_Error is raised when " & + "storage for allocated objects is exceeded"); + + begin + for I in Holder'range loop + Allocator (I); + end loop; + Report.Not_Applicable ("Unable to exhaust memory"); + for I in 1 .. Last_Allocated loop + Free (Holder(I)); + end loop; + exception + when Storage_Error => + if Last_Allocated = 0 then + Report.Failed ("Unable to allocate anything"); + else -- Clean up, so we have enough memory to report on the result. + for I in 1 .. Last_Allocated loop + Free (Holder(I)); + end loop; + Report.Comment (Natural'Image(Last_Allocated) & " items allocated"); + end if; + when others => + Report.Failed ("Wrong exception raised by heap overflow"); + end; + + Report.Result; + +end CB10002; |