From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/c4/c48009d.ada | 128 +++++++++++++++++++++++++++ 1 file changed, 128 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009d.ada (limited to 'gcc/testsuite/ada/acats/tests/c4/c48009d.ada') diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009d.ada b/gcc/testsuite/ada/acats/tests/c4/c48009d.ada new file mode 100644 index 000000000..0c5d3d647 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009d.ada @@ -0,0 +1,128 @@ +-- C48009D.ADA + +-- 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. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S) +-- S, +-- 1) X HAS TOO MANY VALUES FOR S; +-- 2) A NAMED NON-NULL BOUND OF X LIES OUTSIDE S'S RANGE; +-- 3) THE BOUND'S OF X ARE NOT EQUAL TO BOUNDS SPECIFIED FOR THE +-- ALLOCATOR'S DESIGNATED BASE TYPE. (THEY ARE EQUAL TO THE BOUNDS +-- SPECIFIED FOR T). + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- JBG 03/03/83 +-- EG 07/05/84 +-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. +-- KAS 11/14/95 FOR SLIDING ASSIGNMENT, CHANGED FAIL TO COMMENT ON LANGUAGE +-- KAS 12/02/95 INCLUDED SECOND CASE +-- PWN 05/03/96 Enforced Ada 95 sliding rules + +WITH REPORT; + +PROCEDURE C48009D IS + + USE REPORT ; + +BEGIN + + TEST("C48009D","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ARRAY TYPES"); + DECLARE + + SUBTYPE TWO IS INTEGER RANGE 1 .. 2; + SUBTYPE TWON IS INTEGER RANGE IDENT_INT(1) .. IDENT_INT(2); + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE TD IS ARRAY(TWO RANGE <>) OF INTEGER RANGE 1 .. 7; + TYPE TDN IS ARRAY(TWON RANGE <>) OF INTEGER RANGE 1 .. 7; + TYPE ATD IS ACCESS TD; + TYPE ATDN IS ACCESS TDN; + TYPE A_UA IS ACCESS UA; + TYPE A_CA IS ACCESS UA(3 .. 4); + TYPE A_CAN IS ACCESS UA(4 .. 3); + VD : ATD; + VDN : ATDN; + V_A_CA : A_CA; + V_A_CAN : A_CAN; + + BEGIN + + BEGIN + VD := NEW TD'(3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1A"); + END; + + BEGIN + VDN := NEW TDN'(3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1B"); + END; + + BEGIN + VD := NEW TD'(IDENT_INT(0) .. 2 => 6); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2"); + END; + + BEGIN + V_A_CA := NEW UA'(2 .. 3 => 3); + COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + END; + + BEGIN + V_A_CAN := NEW UA'(IDENT_INT(3) .. IDENT_INT(2) => 3); + COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + END; + + END; + + RESULT; + +END C48009D; -- cgit v1.2.3