diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada | 300 |
1 files changed, 300 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada new file mode 100644 index 000000000..52bf79ddc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada @@ -0,0 +1,300 @@ +-- CC3019B2M.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 INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G., +-- TO SUPPORT ITERATORS. THIS TEST SPECIFICALLY CHECKS THAT A +-- NESTING LEVEL OF 2 IS SUPPORTED FOR GENERICS. +-- +-- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE +-- *** SOURCE CODE IN FILES CC3019B0.ADA AND CC3019B1.ADA HAVE +-- *** BEEN COMPILED. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +WITH REPORT ; +WITH CC3019B1_STACK_CLASS ; + +PROCEDURE CC3019B2M IS + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + STORE_DATE : DATE ; + + TODAY : DATE := (MONTH => AUG, + DAY => 31, + YEAR => 1990) ; + + FIRST_DATE : DATE := (MONTH => JUN, + DAY => 4, + YEAR => 1967) ; + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN ; + + PACKAGE DATE_STACK IS + NEW CC3019B1_STACK_CLASS (ELEMENT => DATE, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_DATE_STACK : DATE_STACK.STACK ; + SECOND_DATE_STACK : DATE_STACK.STACK ; + THIRD_DATE_STACK : DATE_STACK.STACK ; + + FUNCTION "=" (LEFT : IN DATE_STACK.STACK ; + RIGHT : IN DATE_STACK.STACK) RETURN BOOLEAN + RENAMES DATE_STACK."=" ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) IS + + BEGIN -- ASSIGN + + TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + RETURN (LEFT.MONTH = RIGHT.MONTH) AND + (LEFT.DAY = RIGHT.DAY) AND + (LEFT.YEAR = RIGHT.YEAR) ; + + END IS_EQUAL ; + +BEGIN -- CC3019B2M + + REPORT.TEST ("CC3019B2M", + "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " & + "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " & + "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF " & + "2 IS SUPPORTED FOR GENERICS.") ; + + DATE_STACK.CLEAR (THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 1 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => FIRST_DATE, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => BIRTH_DATE, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 3 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ; + END IF ; + + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ; + END IF ; + + IF STORE_DATE /= BIRTH_DATE THEN + REPORT.FAILED ( + "IMPROPER VALUE REMOVED FROM STACK - 1") ; + END IF ; + + DATE_STACK.CLEAR (THIS_STACK => SECOND_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => SECOND_DATE_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ; + END IF ; + + DATE_STACK.COPY (THIS_STACK => FIRST_DATE_STACK, + TO_THIS_STACK => SECOND_DATE_STACK) ; + + IF FIRST_DATE_STACK /= SECOND_DATE_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH COPY OR TEST FOR EQUALITY") ; + END IF ; + + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => SECOND_DATE_STACK) ; + DATE_STACK.PUSH (THIS_ELEMENT => WALL_DATE, + ON_TO_THIS_STACK => SECOND_DATE_STACK) ; + IF FIRST_DATE_STACK = SECOND_DATE_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH POP OR TEST FOR EQUALITY") ; + END IF ; + + UNDERFLOW_EXCEPTION_TEST: + + BEGIN -- UNDERFLOW_EXCEPTION_TEST + + DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ; + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => THIRD_DATE_STACK) ; + REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN DATE_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "UNDERFLOW EXCEPTION TEST") ; + + END UNDERFLOW_EXCEPTION_TEST ; + + OVERFLOW_EXCEPTION_TEST: + + BEGIN -- OVERFLOW_EXCEPTION_TEST + + DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ; + FOR INDEX IN 1 .. 10 LOOP + DATE_STACK.PUSH ( THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => THIRD_DATE_STACK) ; + END LOOP ; + + DATE_STACK.PUSH (THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => THIRD_DATE_STACK) ; + REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN DATE_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "OVERFLOW EXCEPTION TEST") ; + + END OVERFLOW_EXCEPTION_TEST ; + + LOCAL_BLOCK: + + DECLARE + + TYPE DATE_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF DATE ; + + FIRST_DATE_TABLE : DATE_TABLE ; + + TABLE_INDEX : POSITIVE := 1 ; + + PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE STORE_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE SHOW_DATE_ITERATE IS NEW + DATE_STACK.ITERATE (PROCESS => SHOW_DATES) ; + + PROCEDURE STORE_DATE_ITERATE IS NEW + DATE_STACK.ITERATE (PROCESS => STORE_DATES) ; + + PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- SHOW_DATES + + REPORT.COMMENT ("THE MONTH IS " & + MONTH_TYPE'IMAGE (THIS_DATE.MONTH)) ; + REPORT.COMMENT ("THE DAY IS " & + DAY_TYPE'IMAGE (THIS_DATE.DAY)) ; + REPORT.COMMENT ("THE YEAR IS " & + YEAR_TYPE'IMAGE (THIS_DATE.YEAR)) ; + + CONTINUE := TRUE ; + + END SHOW_DATES ; + + PROCEDURE STORE_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- STORE_DATES + + FIRST_DATE_TABLE (TABLE_INDEX) := THIS_DATE ; + TABLE_INDEX := TABLE_INDEX + 1 ; + + CONTINUE := TRUE ; + + END STORE_DATES ; + + BEGIN -- LOCAL_BLOCK + + REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ; + SHOW_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ; + + REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ; + SHOW_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ; + + STORE_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ; + IF (FIRST_DATE_TABLE (1) /= TODAY) OR + (FIRST_DATE_TABLE (2) /= FIRST_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ; + END IF ; + + TABLE_INDEX := 1 ; + STORE_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ; + IF (FIRST_DATE_TABLE (1) /= TODAY) OR + (FIRST_DATE_TABLE (2) /= WALL_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + +END CC3019B2M ; |