Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/ada/acats/tests/c8/c85005c.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/c8/c85005c.ada Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,416 @@ +-- C85005C.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 ENTRY 'IN OUT' FORMAL +-- PARAMETER 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 C85005C 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 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; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + 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; + 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; + 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 ("C85005C", "CHECK THAT A VARIABLE CREATED BY AN ENTRY " & + "'IN OUT' FORMAL PARAMETER 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 + TASK MAIN_TASK IS + ENTRY START (TI1 : IN OUT INTEGER; TA1 : IN OUT ARRAY1; + TR1 : IN OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END MAIN_TASK; + + TASK BODY MAIN_TASK IS + BEGIN + ACCEPT START (TI1: IN OUT INTEGER; TA1: IN OUT ARRAY1; + TR1: IN OUT RECORD1; TP1: IN OUT POINTER1; + TV1: IN OUT PACK1.PRIVY; + TT1: IN OUT TASK1) DO + DECLARE + XTI1 : INTEGER RENAMES TI1; + XTA1 : ARRAY1 RENAMES TA1; + XTR1 : RECORD1 RENAMES TR1; + XTP1 : POINTER1 RENAMES TP1; + XTV1 : PACK1.PRIVY RENAMES TV1; + XTT1 : TASK1 RENAMES TT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TTI1 : OUT INTEGER; + TTA1 : OUT ARRAY1; + TTR1 : OUT RECORD1; + TTP1 : IN OUT POINTER1; + TTV1 : IN OUT PACK1.PRIVY; + TTT1 : IN OUT TASK1); + END TASK2; + + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PTI1 : IN OUT INTEGER; + PTA1 : IN OUT ARRAY1; + PTR1 : IN OUT RECORD1; + PTP1 : OUT POINTER1; + PTV1 : OUT PACK1.PRIVY; + PTT1 : IN OUT TASK1) IS + BEGIN + PTI1 := PTI1 + 1; + PTA1 := (PTA1(1)+1, PTA1(2)+1, PTA1(3)+1); + PTR1 := (D => 1, + FIELD1 => PTR1.FIELD1 + 1); + PTP1 := NEW INTEGER'(TP1.ALL + 1); + PTV1 := PACK1.NEXT(TV1); + PTT1.NEXT; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TTI1 : OUT INTEGER; + TTA1 : OUT ARRAY1; + TTR1 : OUT RECORD1; + TTP1 : IN OUT POINTER1; + TTV1 : IN OUT PACK1.PRIVY; + TTT1 : IN OUT TASK1) + DO + TTI1 := TI1 + 1; + TTA1 := (TA1(1)+1, + TA1(2)+1, TA1(3)+1); + TTR1 := (D => 1, + FIELD1 => TR1.FIELD1 + 1); + TTP1 := NEW INTEGER'(TTP1.ALL + 1); + TTV1 := PACK1.NEXT(TTV1); + TTT1.NEXT; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK1 IS NEW GENERIC1 + (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + BEGIN + IF XTI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XTI1 (1)"); + END IF; + + IF XTA1 /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (1)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (1)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XTP1 (1)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.ONE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (1)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (1)"); + END IF; + + PROC1(XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + + IF XTI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XTI1 (2)"); + END IF; + + IF XTA1 /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (2)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (2)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XTP1 (2)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.TWO)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (2)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM " & + "XTT1.VALU (2)"); + END IF; + + CHK_TASK.ENTRY1 + (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + + IF XTI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XTI1 (3)"); + END IF; + + IF XTA1 /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (3)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (3)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XTP1 (3)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.THREE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (3)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (3)"); + END IF; + + XTI1 := XTI1 + 1; + XTA1 := (XTA1(1)+1, XTA1(2)+1, XTA1(3)+1); + XTR1 := (D => 1, FIELD1 => XTR1.FIELD1 + 1); + XTP1 := NEW INTEGER'(XTP1.ALL + 1); + XTV1 := PACK1.NEXT(XTV1); + XTT1.NEXT; + + IF XTI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XTI1 (4)"); + END IF; + + IF XTA1 /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (4)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (4)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XTP1 (4)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FOUR)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (4)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (4)"); + END IF; + + TI1 := TI1 + 1; + TA1 := (TA1(1)+1, TA1(2)+1, TA1(3)+1); + TR1 := (D => 1, FIELD1 => TR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + + IF XTI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XTI1 (5)"); + END IF; + + IF XTA1 /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (5)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (5)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XTP1 (5)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FIVE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (5)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (5)"); + END IF; + END; + END START; + END MAIN_TASK; + + BEGIN + MAIN_TASK.START (DI1, DA1, DR1, DP1, DV1, DT1); + END; + + DT1.STOP; + + RESULT; +END C85005C;