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

   1 -- CC3234A.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 -- OBJECTIVE:
  26 --      CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
  27 --      ACTUAL PARAMETER AN ARRAY TYPE, AND OPERATIONS OF THE FORMAL
  28 --      TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL
  29 --      TYPE.
  30
  31 -- HISTORY:
  32 --      TBN 09/15/88  CREATED ORIGINAL TEST.
  33
  34 WITH REPORT; USE REPORT;
  35 PROCEDURE CC3234A IS
  36
  37      GENERIC
  38           TYPE T IS PRIVATE;
  39      PACKAGE P IS
  40           SUBTYPE SUB_T IS T;
  41           PAC_VAR : T;
  42      END P;
  43
  44      GENERIC
  45           TYPE T IS LIMITED PRIVATE;
  46      PACKAGE LP IS
  47           SUBTYPE SUB_T IS T;
  48           PAC_VAR : T;
  49      END LP;
  50
  51 BEGIN
  52      TEST ("CC3234A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
  53                       "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " &
  54                       "ARRAY TYPE, AND OPERATIONS OF THE " &
  55                       "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
  56                       "OPERATIONS OF THE ACTUAL TYPE");
  57
  58      DECLARE  -- PRIVATE TYPE.
  59           TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER;
  60
  61           OBJ_ARR : ARRAY_TYPE := (OTHERS => 1);
  62
  63           PACKAGE P1 IS NEW P (ARRAY_TYPE);
  64           USE P1;
  65
  66           TYPE NEW_T IS NEW SUB_T;
  67           OBJ_NEWT : NEW_T;
  68      BEGIN
  69           PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
  70           IF PAC_VAR /= OBJ_ARR THEN
  71                FAILED ("INCORRECT RESULTS - 1");
  72           END IF;
  73           OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1);
  74           IF OBJ_ARR(1) <= PAC_VAR(1) THEN
  75                FAILED ("INCORRECT RESULTS - 2");
  76           END IF;
  77           PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3);
  78           IF PAC_VAR NOT IN ARRAY_TYPE THEN
  79                FAILED ("INCORRECT RESULTS - 3");
  80           END IF;
  81           IF OBJ_ARR NOT IN SUB_T THEN
  82                FAILED ("INCORRECT RESULTS - 4");
  83           END IF;
  84           IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN
  85                FAILED ("INCORRECT RESULTS - 5");
  86           END IF;
  87           OBJ_ARR(1..5) := PAC_VAR(6..10);
  88           IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN
  89                FAILED ("INCORRECT RESULTS - 6");
  90           END IF;
  91           PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2);
  92           OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
  93           OBJ_NEWT := NEW_T(PAC_VAR);
  94           IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN
  95                FAILED ("INCORRECT RESULTS - 7");
  96           END IF;
  97           IF OBJ_NEWT NOT IN NEW_T THEN
  98                FAILED ("INCORRECT RESULTS - 8");
  99           END IF;
 100      END;
 101
 102      DECLARE  -- LIMITED PRIVATE TYPE.
 103           TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER;
 104
 105           OBJ_ARR : ARRAY_TYPE := (OTHERS => 1);
 106
 107           PACKAGE P1 IS NEW LP (ARRAY_TYPE);
 108           USE P1;
 109
 110           TYPE NEW_T IS NEW SUB_T;
 111           OBJ_NEWT : NEW_T;
 112      BEGIN
 113           PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
 114           IF PAC_VAR /= OBJ_ARR THEN
 115                FAILED ("INCORRECT RESULTS - 9");
 116           END IF;
 117           OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1);
 118           IF OBJ_ARR(1) <= PAC_VAR(1) THEN
 119                FAILED ("INCORRECT RESULTS - 10");
 120           END IF;
 121           PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3);
 122           IF PAC_VAR NOT IN ARRAY_TYPE THEN
 123                FAILED ("INCORRECT RESULTS - 11");
 124           END IF;
 125           IF OBJ_ARR NOT IN SUB_T THEN
 126                FAILED ("INCORRECT RESULTS - 12");
 127           END IF;
 128           IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN
 129                FAILED ("INCORRECT RESULTS - 13");
 130           END IF;
 131           OBJ_ARR(1..5) := PAC_VAR(6..10);
 132           IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN
 133                FAILED ("INCORRECT RESULTS - 14");
 134           END IF;
 135           PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2);
 136           OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
 137           OBJ_NEWT := NEW_T(PAC_VAR);
 138           IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN
 139                FAILED ("INCORRECT RESULTS - 15");
 140           END IF;
 141           IF OBJ_NEWT NOT IN NEW_T THEN
 142                FAILED ("INCORRECT RESULTS - 16");
 143           END IF;
 144      END;
 145
 146      RESULT;
 147 END CC3234A;