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/c3/c37405a.ada | 161 +++++++++++++++++++++++++++ 1 file changed, 161 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37405a.ada (limited to 'gcc/testsuite/ada/acats/tests/c3/c37405a.ada') diff --git a/gcc/testsuite/ada/acats/tests/c3/c37405a.ada b/gcc/testsuite/ada/acats/tests/c3/c37405a.ada new file mode 100644 index 000000000..187033773 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37405a.ada @@ -0,0 +1,161 @@ +-- C37405A.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 WHEN ASSIGNING TO A CONSTRAINED OR UNCONSTRAINED +-- OBJECT OR FORMAL PARAMETER OF A TYPE DECLARED WITH DEFAULT +-- DISCRIMINANTS, THE ASSIGNMENT DOES NOT CHANGE THE 'CONSTRAINED +-- ATTRIBUTE VALUE ASSOCIATED WITH THE OBJECT OR PARAMETER. + +-- ASL 7/21/81 +-- TBN 1/20/86 RENAMED FROM C37209A.ADA AND REVISED THE ASSIGNMENTS +-- OF CONSTRAINED AND UNCONSTRAINED OBJECTS TO ARRAY AND +-- RECORD COMPONENTS. + +WITH REPORT; USE REPORT; +PROCEDURE C37405A IS + + TYPE REC(DISC : INTEGER := 25) IS + RECORD + COMP : INTEGER; + END RECORD; + + SUBTYPE CONSTR IS REC(10); + SUBTYPE UNCONSTR IS REC; + + TYPE REC_C IS + RECORD + COMP: CONSTR; + END RECORD; + + TYPE REC_U IS + RECORD + COMP: UNCONSTR; + END RECORD; + + C1,C2 : CONSTR; + U1,U2 : UNCONSTR; +-- C2 AND U2 ARE NOT PASSED TO EITHER PROC1 OR PROC2. + + ARR_C : ARRAY (1..5) OF CONSTR; + ARR_U : ARRAY (1..5) OF UNCONSTR; + + REC_COMP_C : REC_C; + REC_COMP_U : REC_U; + + PROCEDURE PROC11(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + PARM := C2; + IF IDENT_BOOL(B) /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 1"); + END IF; + END PROC11; + + PROCEDURE PROC12(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + PARM := U2; + IF B /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 2"); + END IF; + END PROC12; + + PROCEDURE PROC1(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + IF B /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "PASSING PARAMETER"); + END IF; + + PROC11(PARM, B); + + PROC12(PARM, B); + + END PROC1; + + PROCEDURE PROC2(PARM : IN OUT CONSTR) IS + BEGIN + COMMENT ("CALLING PROC1 FROM PROC2"); -- IN CASE TEST FAILS. + PROC1(PARM,TRUE); + PARM := U2; + IF NOT PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 3"); + END IF; + END PROC2; +BEGIN + TEST("C37405A", "'CONSTRAINED ATTRIBUTE OF OBJECTS, FORMAL " & + "PARAMETERS CANNOT BE CHANGED BY ASSIGNMENT"); + + C2 := (DISC => IDENT_INT(10), COMP => 3); + U2 := (DISC => IDENT_INT(10), COMP => 4); + + ARR_C := (1..5 => U2); + ARR_U := (1..5 => C2); + + REC_COMP_C := (COMP => U2); + REC_COMP_U := (COMP => C2); + + C1 := U2; + U1 := C2; + + IF U1'CONSTRAINED OR NOT C1'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 4"); + END IF; + + IF ARR_U(3)'CONSTRAINED OR NOT ARR_C(4)'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 5"); + END IF; + + IF REC_COMP_U.COMP'CONSTRAINED + OR NOT REC_COMP_C.COMP'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 6"); + END IF; + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(C1,TRUE); + PROC2(C1); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(U1,FALSE); + PROC2(U1); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(ARR_C(4), TRUE); + PROC2(ARR_C(5)); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(ARR_U(2), FALSE); + PROC2(ARR_U(3)); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(REC_COMP_C.COMP, TRUE); + PROC2(REC_COMP_C.COMP); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(REC_COMP_U.COMP, FALSE); + PROC2(REC_COMP_U.COMP); + + RESULT; +END C37405A; -- cgit v1.2.3