Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/ada/acats/tests/c3/c37213l.ada @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/ada/acats/tests/c3/c37213l.ada Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,329 @@ +-- C37213L.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. +--* +-- OBJECTIVE: +-- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN +-- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE +-- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE A +-- DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS +-- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: +-- 1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND +-- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT +-- IN THE SUBTYPE. + +-- HISTORY: +-- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J. +-- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY +-- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL +-- PARAMETERS TO THE GENERIC UNITS AND THE +-- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE +-- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE +-- ARE TOGETHER; REWROTE ONE OF THE GENERIC +-- PACKAGES AS A GENERIC PROCEDURE TO BROADEN +-- COVERAGE OF TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37213L IS +BEGIN + TEST ("C37213L", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE A DERIVED OR AN " & + "ACCESS TYPE"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE DER_CHK IS END DER_CHK; + + PACKAGE BODY DER_CHK IS + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + + FUNCTION VALUE RETURN DREC IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE DREC - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE DREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE DREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF DREC - " & TAG); + END; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + + FUNCTION VALUE RETURN CONS IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X.ALL; + ELSE + RETURN X.ALL; + END IF; + END VALUE; + BEGIN + X := NEW CONS; + + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING ALLOCATION " & + "OF OBJECT OF TYPE CONS - " & + TAG); + ELSIF X.ALL /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT " & + "CHECKED DURING " & + "ALLOCATION OF OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF X - " & TAG); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF ACC_CONS - " & TAG); + END ACC_CHK; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW DER_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW ACC_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW DER_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW ACC_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW DER_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW ACC_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW DER_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW ACC_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE, TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW DER_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW ACC_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW DER_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW ACC_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW DER_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW ACC_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW DER_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW ACC_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "DECLARATION / INSTANTIATION ELABORATION - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; +END C37213L;