diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c5/c58005h.ada')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c5/c58005h.ada | 172 |
1 files changed, 172 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c5/c58005h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c5/c58005h.ada new file mode 100644 index 000000000..276d34d69 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c5/c58005h.ada @@ -0,0 +1,172 @@ +-- C58005H.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. +--* +-- CHECK THAT CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE +-- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER. + +-- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH +-- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES. + +-- SPS 3/10/83 +-- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations. +-- The objects must be used, and must be tied somehow to the +-- calls to Failed. + +WITH REPORT; +USE REPORT; +PROCEDURE C58005H IS + + PACKAGE PACK IS + TYPE PV (D : NATURAL) IS PRIVATE; + TYPE LP (D : NATURAL) IS LIMITED PRIVATE; + PRIVATE + TYPE PV (D : NATURAL) IS RECORD + NULL; + END RECORD; + TYPE LP (D : NATURAL) IS RECORD + NULL; + END RECORD; + END PACK; + + USE PACK; + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL; + TYPE REC (D : NATURAL) IS RECORD + NULL; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS ARR; + TYPE ACC_PV IS ACCESS PV; + TYPE ACC_LP IS ACCESS LP; + + SUBTYPE ACC_REC1 IS ACC_REC (D => 1); + SUBTYPE ACC_REC2 IS ACC_REC (D => 2); + + SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10); + SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5); + + SUBTYPE ACC_PV1 IS ACC_PV (D => 1); + SUBTYPE ACC_PV2 IS ACC_PV (D => 2); + + SUBTYPE ACC_LP1 IS ACC_LP (D => 1); + SUBTYPE ACC_LP2 IS ACC_LP (D => 2); + + VAR1 : ACC_REC1 := NEW REC(1); + VAR2 : ACC_REC2 := NEW REC(2); + VAA1 : ACC_ARR1 := NEW ARR(1 .. 10); + VAA2 : ACC_ARR2 := NEW ARR(2 .. 5); + VAP1 : ACC_PV1 := NEW PV(1); + VAP2 : ACC_PV2 := NEW PV(2); + VAL1 : ACC_LP1 := NEW LP(1); + VAL2 : ACC_LP2 := NEW LP(2); + + FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS + BEGIN + RETURN X; + END FREC; + + FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS + BEGIN + RETURN X; + END FARR; + + FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS + BEGIN + RETURN X; + END FPV; + + FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS + BEGIN + RETURN X; + END FLP; + + PACKAGE BODY PACK IS + FUNCTION LF (X : LP) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(3); + END LF; + BEGIN + NULL; + END PACK; + +BEGIN + + TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " & + "OF FUNCTIONS"); + + BEGIN + VAR2 := FREC (VAR1); + IF VAR2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REC"); + END; + + BEGIN + VAA2 := FARR (VAA1); + IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ARR"); + END; + + BEGIN + VAP2 := FPV (VAP1); + IF VAP2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PV"); + END; + + BEGIN + VAL2 := FLP (VAL1); + IF VAL2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - LP"); + END; + + RESULT; +END C58005H; |