gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada

   1 -- CC3019B2M.ADA
   2
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --  CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G.,
  26 --  TO SUPPORT ITERATORS. THIS TEST SPECIFICALLY CHECKS THAT A
  27 --  NESTING LEVEL OF 2 IS SUPPORTED FOR GENERICS.
  28 --
  29 --  *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE
  30 --  *** SOURCE CODE IN FILES CC3019B0.ADA AND CC3019B1.ADA HAVE
  31 --  *** BEEN COMPILED.
  32 --
  33 -- HISTORY:
  34 --         EDWARD V. BERARD, 31 AUGUST 1990
  35
  36 WITH REPORT ;
  37 WITH CC3019B1_STACK_CLASS ;
  38
  39 PROCEDURE CC3019B2M IS
  40
  41      TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
  42                          SEP, OCT, NOV, DEC) ;
  43      TYPE DAY_TYPE IS RANGE 1 .. 31 ;
  44      TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
  45      TYPE DATE IS RECORD
  46           MONTH : MONTH_TYPE ;
  47           DAY   : DAY_TYPE ;
  48           YEAR  : YEAR_TYPE ;
  49      END RECORD ;
  50
  51      STORE_DATE     : DATE ;
  52
  53      TODAY        : DATE := (MONTH => AUG,
  54                              DAY   => 31,
  55                              YEAR  => 1990) ;
  56
  57      FIRST_DATE   : DATE := (MONTH => JUN,
  58                              DAY   => 4,
  59                              YEAR  => 1967) ;
  60
  61      BIRTH_DATE   : DATE := (MONTH => OCT,
  62                              DAY   => 3,
  63                              YEAR  => 1949) ;
  64
  65      WALL_DATE    : DATE := (MONTH => NOV,
  66                              DAY   => 9,
  67                              YEAR  => 1989) ;
  68
  69      PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE    : IN OUT DATE ;
  70                        TO_THIS_DATE              : IN OUT DATE) ;
  71
  72      FUNCTION IS_EQUAL (LEFT  : IN DATE ;
  73                         RIGHT : IN DATE) RETURN BOOLEAN ;
  74
  75      PACKAGE DATE_STACK IS
  76           NEW CC3019B1_STACK_CLASS (ELEMENT => DATE,
  77                                     ASSIGN  => ASSIGN,
  78                                     "="     => IS_EQUAL) ;
  79
  80      FIRST_DATE_STACK    : DATE_STACK.STACK ;
  81      SECOND_DATE_STACK   : DATE_STACK.STACK ;
  82      THIRD_DATE_STACK    : DATE_STACK.STACK ;
  83
  84      FUNCTION "=" (LEFT  : IN DATE_STACK.STACK ;
  85                    RIGHT : IN DATE_STACK.STACK) RETURN BOOLEAN
  86                    RENAMES DATE_STACK."=" ;
  87
  88      PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE    : IN OUT DATE ;
  89                        TO_THIS_DATE              : IN OUT DATE) IS
  90
  91      BEGIN -- ASSIGN
  92
  93           TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ;
  94
  95      END ASSIGN ;
  96
  97      FUNCTION IS_EQUAL (LEFT  : IN DATE ;
  98                         RIGHT : IN DATE) RETURN BOOLEAN IS
  99
 100      BEGIN -- IS_EQUAL
 101
 102           RETURN (LEFT.MONTH = RIGHT.MONTH) AND
 103                  (LEFT.DAY = RIGHT.DAY) AND
 104                  (LEFT.YEAR = RIGHT.YEAR) ;
 105
 106      END IS_EQUAL ;
 107
 108 BEGIN  -- CC3019B2M
 109
 110      REPORT.TEST ("CC3019B2M",
 111                   "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " &
 112                   "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " &
 113                   "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF " &
 114                   "2 IS SUPPORTED FOR GENERICS.") ;
 115
 116      DATE_STACK.CLEAR (THIS_STACK => FIRST_DATE_STACK) ;
 117      IF DATE_STACK.NUMBER_OF_ELEMENTS
 118         (ON_THIS_STACK => FIRST_DATE_STACK) /= 0 THEN
 119           REPORT.FAILED (
 120                "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ;
 121      END IF ;
 122
 123      DATE_STACK.PUSH (THIS_ELEMENT     => TODAY,
 124                       ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
 125      IF DATE_STACK.NUMBER_OF_ELEMENTS
 126         (ON_THIS_STACK => FIRST_DATE_STACK) /= 1 THEN
 127           REPORT.FAILED (
 128                "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ;
 129      END IF ;
 130
 131      DATE_STACK.PUSH (THIS_ELEMENT     => FIRST_DATE,
 132                       ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
 133      IF DATE_STACK.NUMBER_OF_ELEMENTS
 134         (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN
 135           REPORT.FAILED (
 136                "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ;
 137      END IF ;
 138
 139      DATE_STACK.PUSH (THIS_ELEMENT     => BIRTH_DATE,
 140                       ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
 141      IF DATE_STACK.NUMBER_OF_ELEMENTS
 142         (ON_THIS_STACK => FIRST_DATE_STACK) /= 3 THEN
 143           REPORT.FAILED (
 144                "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ;
 145      END IF ;
 146
 147      DATE_STACK.POP (THIS_ELEMENT   => STORE_DATE,
 148                            OFF_THIS_STACK => FIRST_DATE_STACK) ;
 149      IF DATE_STACK.NUMBER_OF_ELEMENTS
 150         (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN
 151           REPORT.FAILED (
 152                "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ;
 153      END IF ;
 154
 155      IF STORE_DATE /= BIRTH_DATE THEN
 156           REPORT.FAILED (
 157                "IMPROPER VALUE REMOVED FROM STACK - 1") ;
 158      END IF ;
 159
 160      DATE_STACK.CLEAR (THIS_STACK => SECOND_DATE_STACK) ;
 161      IF DATE_STACK.NUMBER_OF_ELEMENTS
 162         (ON_THIS_STACK => SECOND_DATE_STACK) /= 0 THEN
 163           REPORT.FAILED (
 164                "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ;
 165      END IF ;
 166
 167      DATE_STACK.COPY (THIS_STACK    => FIRST_DATE_STACK,
 168                       TO_THIS_STACK => SECOND_DATE_STACK) ;
 169
 170      IF FIRST_DATE_STACK /= SECOND_DATE_STACK THEN
 171           REPORT.FAILED (
 172                "PROBLEMS WITH COPY OR TEST FOR EQUALITY") ;
 173      END IF ;
 174
 175      DATE_STACK.POP (THIS_ELEMENT   => STORE_DATE,
 176                      OFF_THIS_STACK => SECOND_DATE_STACK) ;
 177      DATE_STACK.PUSH (THIS_ELEMENT     => WALL_DATE,
 178                       ON_TO_THIS_STACK => SECOND_DATE_STACK) ;
 179      IF FIRST_DATE_STACK = SECOND_DATE_STACK THEN
 180           REPORT.FAILED (
 181                "PROBLEMS WITH POP OR TEST FOR EQUALITY") ;
 182      END IF ;
 183
 184      UNDERFLOW_EXCEPTION_TEST:
 185
 186      BEGIN  -- UNDERFLOW_EXCEPTION_TEST
 187
 188           DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ;
 189           DATE_STACK.POP (THIS_ELEMENT      => STORE_DATE,
 190                           OFF_THIS_STACK    => THIRD_DATE_STACK) ;
 191           REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ;
 192
 193      EXCEPTION
 194
 195           WHEN DATE_STACK.UNDERFLOW => NULL ;  -- CORRECT EXCEPTION
 196                                                -- RAISED
 197           WHEN OTHERS =>
 198                REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
 199                               "UNDERFLOW EXCEPTION TEST") ;
 200
 201      END UNDERFLOW_EXCEPTION_TEST ;
 202
 203      OVERFLOW_EXCEPTION_TEST:
 204
 205      BEGIN  -- OVERFLOW_EXCEPTION_TEST
 206
 207           DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ;
 208           FOR INDEX IN 1 .. 10 LOOP
 209                DATE_STACK.PUSH ( THIS_ELEMENT     => TODAY,
 210                                  ON_TO_THIS_STACK => THIRD_DATE_STACK) ;
 211           END LOOP ;
 212
 213           DATE_STACK.PUSH (THIS_ELEMENT     => TODAY,
 214                            ON_TO_THIS_STACK => THIRD_DATE_STACK) ;
 215           REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ;
 216
 217      EXCEPTION
 218
 219           WHEN DATE_STACK.OVERFLOW => NULL ;  -- CORRECT EXCEPTION
 220                                               -- RAISED
 221           WHEN OTHERS =>
 222                REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
 223                               "OVERFLOW EXCEPTION TEST") ;
 224
 225      END OVERFLOW_EXCEPTION_TEST ;
 226
 227      LOCAL_BLOCK:
 228
 229      DECLARE
 230
 231           TYPE DATE_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF DATE ;
 232
 233           FIRST_DATE_TABLE : DATE_TABLE ;
 234
 235           TABLE_INDEX : POSITIVE := 1 ;
 236
 237           PROCEDURE SHOW_DATES (THIS_DATE : IN  DATE ;
 238                                 CONTINUE  : OUT BOOLEAN) ;
 239
 240           PROCEDURE STORE_DATES (THIS_DATE : IN DATE ;
 241                                  CONTINUE  : OUT BOOLEAN) ;
 242
 243           PROCEDURE SHOW_DATE_ITERATE IS NEW
 244                DATE_STACK.ITERATE (PROCESS => SHOW_DATES) ;
 245
 246           PROCEDURE STORE_DATE_ITERATE IS NEW
 247                DATE_STACK.ITERATE (PROCESS => STORE_DATES) ;
 248
 249           PROCEDURE SHOW_DATES (THIS_DATE : IN  DATE ;
 250                                 CONTINUE  : OUT BOOLEAN) IS
 251           BEGIN  -- SHOW_DATES
 252
 253                 REPORT.COMMENT ("THE MONTH IS " &
 254                            MONTH_TYPE'IMAGE (THIS_DATE.MONTH)) ;
 255                 REPORT.COMMENT ("THE DAY IS " &
 256                            DAY_TYPE'IMAGE (THIS_DATE.DAY)) ;
 257                 REPORT.COMMENT ("THE YEAR IS " &
 258                            YEAR_TYPE'IMAGE (THIS_DATE.YEAR)) ;
 259
 260                 CONTINUE := TRUE ;
 261
 262           END SHOW_DATES ;
 263
 264           PROCEDURE STORE_DATES (THIS_DATE : IN  DATE ;
 265                                        CONTINUE  : OUT BOOLEAN) IS
 266           BEGIN  -- STORE_DATES
 267
 268                 FIRST_DATE_TABLE (TABLE_INDEX) := THIS_DATE ;
 269                 TABLE_INDEX := TABLE_INDEX + 1 ;
 270
 271                 CONTINUE := TRUE ;
 272
 273           END STORE_DATES ;
 274
 275      BEGIN  -- LOCAL_BLOCK
 276
 277           REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ;
 278           SHOW_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ;
 279
 280           REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ;
 281           SHOW_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ;
 282
 283           STORE_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ;
 284           IF (FIRST_DATE_TABLE (1) /= TODAY) OR
 285                (FIRST_DATE_TABLE (2) /= FIRST_DATE) THEN
 286                      REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ;
 287           END IF ;
 288
 289           TABLE_INDEX := 1 ;
 290           STORE_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ;
 291           IF (FIRST_DATE_TABLE (1) /= TODAY) OR
 292                (FIRST_DATE_TABLE (2) /= WALL_DATE) THEN
 293                      REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ;
 294           END IF ;
 295
 296      END LOCAL_BLOCK ;
 297
 298      REPORT.RESULT ;
 299
 300 END CC3019B2M ;