path: root/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada

-- CC3019C2M.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 3 IS SUPPORTED FOR GENERICS:
--       INSTANTIATE CC3019C1_NESTED_GENERICS IN THE MAIN
--       PROCEDURE, THE INSTANTIATION OF CC3019C0_LIST_CLASS
--       IN GENERIC PACKAGE CC3019C1_NESTED_GENERICS, AND
--       THE INSTANTIATION OF NEW_LIST_CLASS.ITERATE IN
--       PROCEDURE ITERATE IN PACKAGE BODY STACK_CLASS.
--
--  *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE
--  *** SOURCE CODE IN FILES CC3019C0.ADA AND CC3019C1.ADA HAVE
--  *** BEEN COMPILED.
--
-- HISTORY:
--         EDWARD V. BERARD, 31 AUGUST 1990

WITH REPORT ;
WITH CC3019C1_NESTED_GENERICS ;

PROCEDURE CC3019C2M 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) ;

     TYPE SEX IS (MALE, FEMALE) ;

     TYPE PERSON IS RECORD
          BIRTH_DATE : DATE ;
          GENDER     : SEX ;
          NAME       : STRING (1 .. 10) ;
     END RECORD ;

     FIRST_PERSON  : PERSON ;
     SECOND_PERSON : PERSON ;

     MYSELF      : PERSON := (BIRTH_DATE => BIRTH_DATE,
                              GENDER     => MALE,
                              NAME        => "ED        ") ;

     FRIEND      : PERSON := (BIRTH_DATE => DATE'(DEC, 27, 1949),
                              GENDER     => MALE,
                              NAME        => "DENNIS    ") ;

     FATHER      : PERSON := (BIRTH_DATE => DATE'(JUL, 5, 1925),
                              GENDER     => MALE,
                              NAME        => "EDWARD    ") ;

     DAUGHTER    : PERSON := (BIRTH_DATE => DATE'(DEC, 10, 1980),
                              GENDER     => FEMALE,
                              NAME       => "CHRISSY   ") ;

     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 ;

     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON  : IN OUT PERSON ;
                       TO_THIS_PERSON            : IN OUT PERSON) ;

     FUNCTION IS_EQUAL (LEFT  : IN PERSON ;
                        RIGHT : IN PERSON) RETURN BOOLEAN ;

--  INSTANTIATE OUTER GENERIC PACKAGE

     PACKAGE NEW_NESTED_GENERICS IS NEW
          CC3019C1_NESTED_GENERICS (ELEMENT => DATE,
                                    ASSIGN  => ASSIGN,
                                    "="     => IS_EQUAL) ;

     FIRST_NNG  : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
     SECOND_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;

     FUNCTION "=" (LEFT  : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
                   RIGHT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE)
                   RETURN BOOLEAN RENAMES NEW_NESTED_GENERICS."=" ;

--  INSTANTIATE NESTED TASK PACKAGE

     PACKAGE NEW_GENERIC_TASK IS NEW
          NEW_NESTED_GENERICS.GENERIC_TASK (ELEMENT => PERSON,
                                            ASSIGN  => ASSIGN) ;

     FIRST_GENERIC_TASK  : NEW_GENERIC_TASK.PROTECTED_AREA ;
     SECOND_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ;

--  INSTANTIATE NESTED STACK PACKAGE

     PACKAGE PERSON_STACK IS NEW
          NEW_NESTED_GENERICS.STACK_CLASS (ELEMENT => PERSON,
                                           ASSIGN  => ASSIGN,
                                           "="     => IS_EQUAL) ;

     FIRST_PERSON_STACK  : PERSON_STACK.STACK ;
     SECOND_PERSON_STACK : PERSON_STACK.STACK ;
     THIRD_PERSON_STACK  : PERSON_STACK.STACK ;

     FUNCTION "=" (LEFT  : IN PERSON_STACK.STACK ;
                   RIGHT : IN PERSON_STACK.STACK) RETURN BOOLEAN
              RENAMES PERSON_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

          IF (LEFT.MONTH = RIGHT.MONTH) AND (LEFT.DAY = RIGHT.DAY)
             AND (LEFT.YEAR = RIGHT.YEAR) THEN
               RETURN TRUE ;
          ELSE
               RETURN FALSE ;
          END IF ;

     END IS_EQUAL ;

     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON  : IN OUT PERSON ;
                       TO_THIS_PERSON            : IN OUT PERSON) IS

     BEGIN -- ASSIGN

          TO_THIS_PERSON := THE_VALUE_OF_THIS_PERSON ;

     END ASSIGN ;

     FUNCTION IS_EQUAL (LEFT  : IN PERSON ;
                        RIGHT : IN PERSON) RETURN BOOLEAN IS

     BEGIN -- IS_EQUAL

          IF (LEFT.BIRTH_DATE = RIGHT.BIRTH_DATE) AND
             (LEFT.GENDER = RIGHT.GENDER) AND
             (LEFT.NAME = RIGHT.NAME) THEN
               RETURN TRUE ;
          ELSE
               RETURN FALSE ;
          END IF ;

     END IS_EQUAL ;

BEGIN  -- CC3019C2M

     REPORT.TEST ("CC3019C2M",
                  "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " &
                  "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " &
                  "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF 3 " &
                  "IS SUPPORTED FOR GENERICS.") ;

-- CHECK THE OUTERMOST GENERIC (NEW_NESTED_GENERICS)

     NEW_NESTED_GENERICS.SET_ELEMENT (
          FOR_THIS_NGT_OBJECT => FIRST_NNG,
          TO_THIS_ELEMENT     => TODAY) ;
     NEW_NESTED_GENERICS.SET_NUMBER (
          FOR_THIS_NGT_OBJECT => FIRST_NNG,
          TO_THIS_NUMBER      => 1) ;

     NEW_NESTED_GENERICS.SET_ELEMENT (
          FOR_THIS_NGT_OBJECT => SECOND_NNG,
          TO_THIS_ELEMENT     => FIRST_DATE) ;
     NEW_NESTED_GENERICS.SET_NUMBER  (
          FOR_THIS_NGT_OBJECT => SECOND_NNG,
          TO_THIS_NUMBER      => 2) ;

     IF FIRST_NNG = SECOND_NNG THEN
          REPORT.FAILED ("PROBLEMS WITH TESTING EQUALITY FOR " &
                         "OUTERMOST GENERIC") ;
     END IF ;

     IF (NEW_NESTED_GENERICS.ELEMENT_OF (THIS_NGT_OBJECT => FIRST_NNG)
             /= TODAY) OR
        (NEW_NESTED_GENERICS.ELEMENT_OF (
                THIS_NGT_OBJECT => SECOND_NNG)
             /= FIRST_DATE) THEN
             REPORT.FAILED ("PROBLEMS WITH EXTRACTING ELEMENTS IN " &
                            "OUTERMOST GENERIC") ;
     END IF ;

     IF (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => FIRST_NNG)
             /= 1) OR
        (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => SECOND_NNG)
             /= 2) THEN
             REPORT.FAILED ("PROBLEMS WITH EXTRACTING NUMBERS IN " &
                             "OUTERMOST GENERIC") ;
     END IF ;

     NEW_NESTED_GENERICS.COPY (SOURCE        => FIRST_NNG,
                               DESTINATION    => SECOND_NNG) ;

     IF FIRST_NNG /= SECOND_NNG THEN
          REPORT.FAILED ("PROBLEMS WITH COPYING OR TESTING EQUALITY " &
                         "IN OUTERMOST GENERIC") ;
     END IF ;

-- CHECK THE FIRST NESTED GENERIC (GENERIC_TASK)

     FIRST_GENERIC_TASK.STORE  (ITEM => MYSELF) ;
     SECOND_GENERIC_TASK.STORE (ITEM => FRIEND) ;

     FIRST_GENERIC_TASK.GET  (ITEM => FIRST_PERSON) ;
     SECOND_GENERIC_TASK.GET (ITEM => SECOND_PERSON) ;

     IF (FIRST_PERSON /= MYSELF) OR (SECOND_PERSON /= FRIEND) THEN
          REPORT.FAILED ("PROBLEMS WITH NESTED TASK GENERIC") ;
     END IF ;

-- CHECK THE SECOND NESTED GENERIC (STACK_CLASS)

     PERSON_STACK.CLEAR (THIS_STACK => FIRST_PERSON_STACK) ;
     IF PERSON_STACK.NUMBER_OF_ELEMENTS
        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 0 THEN
          REPORT.FAILED (
               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ;
     END IF ;

     PERSON_STACK.PUSH (THIS_ELEMENT     => MYSELF,
                            ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
     IF PERSON_STACK.NUMBER_OF_ELEMENTS
        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 1 THEN
          REPORT.FAILED (
               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ;
     END IF ;

     PERSON_STACK.PUSH (THIS_ELEMENT     => FRIEND,
                            ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
     IF PERSON_STACK.NUMBER_OF_ELEMENTS
        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN
          REPORT.FAILED (
               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ;
     END IF ;

     PERSON_STACK.PUSH (THIS_ELEMENT     => FATHER,
                            ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
     IF PERSON_STACK.NUMBER_OF_ELEMENTS
        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 3 THEN
          REPORT.FAILED (
               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ;
     END IF ;

     PERSON_STACK.POP (THIS_ELEMENT   => FIRST_PERSON,
                           OFF_THIS_STACK => FIRST_PERSON_STACK) ;
     IF PERSON_STACK.NUMBER_OF_ELEMENTS
        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN
          REPORT.FAILED (
               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ;
     END IF ;

     IF FIRST_PERSON /= FATHER THEN
          REPORT.FAILED (
               "IMPROPER VALUE REMOVED FROM STACK - 1") ;
     END IF ;

     PERSON_STACK.CLEAR (THIS_STACK => SECOND_PERSON_STACK) ;
     IF PERSON_STACK.NUMBER_OF_ELEMENTS
        (ON_THIS_STACK => SECOND_PERSON_STACK) /= 0 THEN
          REPORT.FAILED (
               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ;
     END IF ;

     PERSON_STACK.COPY (THIS_STACK    => FIRST_PERSON_STACK,
                            TO_THIS_STACK => SECOND_PERSON_STACK) ;

     IF FIRST_PERSON_STACK /= SECOND_PERSON_STACK THEN
          REPORT.FAILED (
               "PROBLEMS WITH COPY OR TEST FOR EQUALITY (STACK)") ;
     END IF ;

     PERSON_STACK.POP (THIS_ELEMENT   => FIRST_PERSON,
                       OFF_THIS_STACK => SECOND_PERSON_STACK) ;
     PERSON_STACK.PUSH (THIS_ELEMENT     => DAUGHTER,
                        ON_TO_THIS_STACK => SECOND_PERSON_STACK) ;
     IF FIRST_PERSON_STACK = SECOND_PERSON_STACK THEN
          REPORT.FAILED (
               "PROBLEMS WITH POP OR TEST FOR EQUALITY (STACK)") ;
     END IF ;

     UNDERFLOW_EXCEPTION_TEST:

     BEGIN  -- UNDERFLOW_EXCEPTION_TEST

          PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ;
          PERSON_STACK.POP (THIS_ELEMENT    => FIRST_PERSON,
                            OFF_THIS_STACK  => THIRD_PERSON_STACK) ;
          REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ;

     EXCEPTION

          WHEN PERSON_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

          PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ;
          FOR INDEX IN 1 .. 10 LOOP
               PERSON_STACK.PUSH (
                    THIS_ELEMENT     => MYSELF,
                    ON_TO_THIS_STACK => THIRD_PERSON_STACK) ;
          END LOOP ;

          PERSON_STACK.PUSH (THIS_ELEMENT     => MYSELF,
                             ON_TO_THIS_STACK => THIRD_PERSON_STACK) ;
          REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ;

     EXCEPTION

          WHEN PERSON_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 PERSON_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF PERSON;

          FIRST_PERSON_TABLE : PERSON_TABLE ;

          TABLE_INDEX : POSITIVE := 1 ;

          PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN  PERSON ;
                                   CONTINUE    : OUT BOOLEAN) ;

          PROCEDURE SHOW_PEOPLE (THIS_PERSON  : IN  PERSON ;
                                 CONTINUE     : OUT BOOLEAN) ;

          PROCEDURE GATHER_PERSON_ITERATE IS NEW
               PERSON_STACK.ITERATE (PROCESS => GATHER_PEOPLE) ;

          PROCEDURE SHOW_PERSON_ITERATE IS NEW
               PERSON_STACK.ITERATE (PROCESS => SHOW_PEOPLE) ;

          PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN  PERSON ;
                                   CONTINUE    : OUT BOOLEAN) IS
          BEGIN  -- GATHER_PEOPLE

               FIRST_PERSON_TABLE (TABLE_INDEX) := THIS_PERSON ;
               TABLE_INDEX := TABLE_INDEX + 1 ;

               CONTINUE := TRUE ;

          END GATHER_PEOPLE ;

          PROCEDURE SHOW_PEOPLE (THIS_PERSON  : IN  PERSON ;
                                 CONTINUE     : OUT BOOLEAN) IS

          BEGIN  -- SHOW_PEOPLE

               REPORT.COMMENT ("THE BIRTH MONTH IS " &
                    MONTH_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.MONTH)) ;
               REPORT.COMMENT ("THE BIRTH DAY IS " &
                    DAY_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.DAY)) ;
               REPORT.COMMENT ("THE BIRTH YEAR IS " &
                    YEAR_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.YEAR)) ;
               REPORT.COMMENT ("THE GENDER IS " &
                    SEX'IMAGE (THIS_PERSON.GENDER)) ;
               REPORT.COMMENT ("THE NAME IS " & THIS_PERSON.NAME) ;

               CONTINUE := TRUE ;

          END SHOW_PEOPLE ;

     BEGIN  -- LOCAL_BLOCK

          REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ;
          SHOW_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK) ;

          REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ;
          SHOW_PERSON_ITERATE (OVER_THIS_STACK => SECOND_PERSON_STACK) ;

          GATHER_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK);
          IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR
             (FIRST_PERSON_TABLE (2) /= FRIEND) THEN
               REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ;
          END IF ;

          TABLE_INDEX := 1 ;
          GATHER_PERSON_ITERATE(OVER_THIS_STACK => SECOND_PERSON_STACK);
          IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR
             (FIRST_PERSON_TABLE (2) /= DAUGHTER) THEN
               REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ;
          END IF ;

     END LOCAL_BLOCK ;

     REPORT.RESULT ;

END CC3019C2M ;