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/c8/c85005e.ada | 397 +++++++++++++++++++++++++++ 1 file changed, 397 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005e.ada (limited to 'gcc/testsuite/ada/acats/tests/c8/c85005e.ada') diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005e.ada b/gcc/testsuite/ada/acats/tests/c8/c85005e.ada new file mode 100644 index 000000000..1f6ffc37d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005e.ada @@ -0,0 +1,397 @@ +-- C85005E.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 THAT A VARIABLE CREATED BY AN ALLOCATOR CAN BE RENAMED AND +-- HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN +-- ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR +-- ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC +-- 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED +-- VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF +-- THE NEW NAME. + +-- HISTORY: +-- JET 03/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005E IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PACKACC IS ACCESS INTEGER; + AK1 : PACKACC := NEW INTEGER'(0); + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + GK1 : IN OUT INTEGER; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + GK1 := GK1 + 1; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85005E", "CHECK THAT A VARIABLE CREATED BY AN ALLOCATOR " & + "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " & + "THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT" & + " STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE " & + "IS REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TYPE ACCINT IS ACCESS INTEGER; + TYPE ACCARR IS ACCESS ARRAY1; + TYPE ACCREC IS ACCESS RECORD1; + TYPE ACCPTR IS ACCESS POINTER1; + TYPE ACCPVT IS ACCESS PACK1.PRIVY; + TYPE ACCTSK IS ACCESS TASK1; + + AI1 : ACCINT := NEW INTEGER'(0); + AA1 : ACCARR := NEW ARRAY1'(0, 0, 0); + AR1 : ACCREC := NEW RECORD1'(D => 1, FIELD1 => 0); + AP1 : ACCPTR := NEW POINTER1'(NEW INTEGER'(0)); + AV1 : ACCPVT := NEW PACK1.PRIVY'(PACK1.ZERO); + AT1 : ACCTSK := NEW TASK1; + + XAI1 : INTEGER RENAMES AI1.ALL; + XAA1 : ARRAY1 RENAMES AA1.ALL; + XAR1 : RECORD1 RENAMES AR1.ALL; + XAP1 : POINTER1 RENAMES AP1.ALL; + XAV1 : PACK1.PRIVY RENAMES AV1.ALL; + XAK1 : INTEGER RENAMES PACK1.AK1.ALL; + XAT1 : TASK1 RENAMES AT1.ALL; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1; TK1 : IN OUT INTEGER); + END TASK2; + + I : INTEGER; + A_CHK_TASK : TASK2; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1; + PK1 : OUT INTEGER) IS + + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(AP1.ALL.ALL + 1); + PV1 := PACK1.NEXT(AV1.ALL); + PT1.NEXT; + PK1 := PACK1.AK1.ALL + 1; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER) DO + TI1 := AI1.ALL + 1; + TA1 := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1); + TR1 := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + TK1 := TK1 + 1; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC1 (XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + BEGIN + IF XAI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1 (1)"); + END IF; + + IF XAA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (1)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (1)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1 (1)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (1)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (1)"); + END IF; + + IF XAK1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAK1 (1)"); + END IF; + + PROC1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + IF XAI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1 (2)"); + END IF; + + IF XAA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (2)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (2)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1 (2)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (2)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (2)"); + END IF; + + IF XAK1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAK1 (2)"); + END IF; + + A_CHK_TASK.ENTRY1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + IF XAI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1 (3)"); + END IF; + + IF XAA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (3)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (3)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1 (3)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (3)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (3)"); + END IF; + + IF XAK1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAK1 (3)"); + END IF; + + XAI1 := XAI1 + 1; + XAA1 := (XAA1(1)+1, XAA1(2)+1, XAA1(3)+1); + XAR1 := (D => 1, FIELD1 => XAR1.FIELD1 + 1); + XAP1 := NEW INTEGER'(XAP1.ALL + 1); + XAV1 := PACK1.NEXT(XAV1); + XAT1.NEXT; + XAK1 := XAK1 + 1; + + IF XAI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1 (4)"); + END IF; + + IF XAA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (4)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (4)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1 (4)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (4)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (4)"); + END IF; + + IF XAK1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAK1 (4)"); + END IF; + + AI1.ALL := AI1.ALL + 1; + AA1.ALL := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1); + AR1.ALL := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1); + AP1.ALL := NEW INTEGER'(AP1.ALL.ALL + 1); + AV1.ALL := PACK1.NEXT(AV1.ALL); + AT1.NEXT; + PACK1.AK1.ALL := PACK1.AK1.ALL + 1; + + IF XAI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1 (5)"); + END IF; + + IF XAA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (5)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (5)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1 (5)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (5)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (5)"); + END IF; + + IF XAK1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAK1 (5)"); + END IF; + + AT1.STOP; + END; + + RESULT; +END C85005E; -- cgit v1.2.3