gcc/testsuite/ada/acats/tests/c4/c47002c.ada

   1 -- C47002C.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 THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
  26 -- THE OPERANDS OF QUALIFIED EXPRESSIONS.
  27 -- THIS TEST IS FOR ARRAY, RECORD, AND ACCESS TYPES.
  28
  29 -- RJW 7/23/86
  30
  31 WITH REPORT; USE REPORT;
  32 PROCEDURE C47002C IS
  33
  34 BEGIN
  35
  36      TEST( "C47002C", "CHECK THAT VALUES HAVING ARRAY, RECORD, AND " &
  37                       "ACCESS TYPES CAN BE WRITTEN AS THE OPERANDS " &
  38                       "OF QUALIFIED EXPRESSIONS" );
  39
  40      DECLARE -- ARRAY TYPES.
  41
  42           TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
  43           SUBTYPE ARR1 IS ARR (1 .. 1);
  44           SUBTYPE ARR5 IS ARR (1 .. 5);
  45
  46           TYPE NARR IS NEW ARR;
  47           SUBTYPE NARR2 IS NARR (2 .. 2);
  48
  49           TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
  50                OF INTEGER;
  51           SUBTYPE TARR15 IS TARR (1 .. 1, 1 .. 5);
  52           SUBTYPE TARR51 IS TARR (1 .. 5, 1 .. 1);
  53
  54           TYPE NTARR IS NEW TARR;
  55           SUBTYPE NTARR26 IS NTARR (2 .. 6, 2 .. 6);
  56
  57           FUNCTION F (X : ARR) RETURN ARR IS
  58           BEGIN
  59                RETURN X;
  60           END;
  61
  62           FUNCTION F (X : NARR) RETURN NARR IS
  63           BEGIN
  64                RETURN X;
  65           END;
  66
  67           FUNCTION F (X : TARR) RETURN TARR IS
  68           BEGIN
  69                RETURN X;
  70           END;
  71
  72           FUNCTION F (X : NTARR) RETURN NTARR IS
  73           BEGIN
  74                RETURN X;
  75           END;
  76
  77      BEGIN
  78           IF F (ARR1'(OTHERS => 0))'LAST /= 1 THEN
  79                FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR1" );
  80           END IF;
  81
  82           IF F (ARR5'(OTHERS => 0))'LAST /= 5 THEN
  83                FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR5" );
  84           END IF;
  85
  86           IF F (NARR2'(OTHERS => 0))'FIRST /= 2 OR
  87              F (NARR2'(OTHERS => 0))'LAST /= 2 THEN
  88                FAILED ( "INCORRECT RESULTS FOR SUBTYPE NARR2" );
  89           END IF;
  90
  91           IF F (TARR15'(OTHERS => (OTHERS => 0)))'LAST /= 1 OR
  92              F (TARR15'(OTHERS => (OTHERS => 0)))'LAST (2) /= 5 THEN
  93                FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR15" );
  94           END IF;
  95
  96           IF F (TARR51'(OTHERS => (OTHERS => 0)))'LAST /= 5 OR
  97              F (TARR51'(OTHERS => (OTHERS => 0)))'LAST (2) /= 1 THEN
  98                FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR51" );
  99           END IF;
 100
 101           IF F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST /= 2 OR
 102              F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST /= 6 OR
 103              F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST (2) /= 2 OR
 104              F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST (2) /= 6 THEN
 105                FAILED ( "INCORRECT RESULTS FOR SUBTYPE NTARR26" );
 106           END IF;
 107
 108      END;
 109
 110      DECLARE -- RECORD TYPES.
 111
 112           TYPE GENDER IS (MALE, FEMALE, NEUTER);
 113
 114           TYPE MAN IS
 115                RECORD
 116                     AGE : POSITIVE;
 117                END RECORD;
 118
 119           TYPE WOMAN IS
 120                RECORD
 121                     AGE : POSITIVE;
 122                END RECORD;
 123
 124           TYPE ANDROID IS NEW MAN;
 125
 126           FUNCTION F (X: WOMAN) RETURN GENDER IS
 127           BEGIN
 128                RETURN FEMALE;
 129           END F;
 130
 131           FUNCTION F (X: MAN) RETURN GENDER IS
 132           BEGIN
 133                RETURN MALE;
 134           END F;
 135
 136           FUNCTION F (X : ANDROID) RETURN GENDER IS
 137           BEGIN
 138                RETURN NEUTER;
 139           END F;
 140
 141      BEGIN
 142           IF F (MAN'(AGE => 23)) /= MALE THEN
 143                FAILED ( "INCORRECT RESULTS FOR SUBTYPE MAN" );
 144           END IF;
 145
 146           IF F (WOMAN'(AGE => 38)) /= FEMALE THEN
 147                FAILED ( "INCORRECT RESULTS FOR SUBTYPE WOMAN" );
 148           END IF;
 149
 150           IF F (ANDROID'(AGE => 2001)) /= NEUTER THEN
 151                FAILED ( "INCORRECT RESULTS FOR TYPE ANDRIOD" );
 152           END IF;
 153      END;
 154
 155      DECLARE -- ACCESS TYPES.
 156
 157           TYPE CODE IS (OLD, BRANDNEW, WRECK);
 158
 159           TYPE CAR (D : CODE) IS
 160                RECORD
 161                     NULL;
 162                END RECORD;
 163
 164           TYPE KEY IS ACCESS CAR;
 165
 166           TYPE KEY_OLD IS ACCESS CAR (OLD);
 167           KO : KEY_OLD := NEW CAR'(D => OLD);
 168
 169           TYPE KEY_WRECK IS ACCESS CAR (WRECK);
 170
 171           TYPE KEY_CARD IS NEW KEY;
 172           KC : KEY_CARD := NEW CAR'(D => BRANDNEW);
 173
 174           FUNCTION F (X : KEY_OLD) RETURN CODE IS
 175           BEGIN
 176                RETURN OLD;
 177           END F;
 178
 179           FUNCTION F (X : KEY_WRECK) RETURN CODE IS
 180           BEGIN
 181                RETURN WRECK;
 182           END F;
 183
 184           FUNCTION F (X : KEY_CARD) RETURN CODE IS
 185           BEGIN
 186                RETURN BRANDNEW;
 187           END F;
 188      BEGIN
 189           IF KEY_OLD'(KO) /= KO THEN
 190                FAILED ( "INCORRECT RESULTS FOR TYPE KEY_OLD - 1" );
 191           END IF;
 192
 193           IF KEY_CARD'(KC) /= KC THEN
 194                FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 1" );
 195           END IF;
 196
 197
 198           IF F (KEY_OLD'(NULL)) /= OLD THEN
 199                FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_OLD - 2" );
 200           END IF;
 201
 202           IF F (KEY_WRECK'(NULL)) /= WRECK THEN
 203                FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_WRECK" );
 204           END IF;
 205
 206           IF F (KEY_CARD'(NULL)) /= BRANDNEW THEN
 207                FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 2" );
 208           END IF;
 209      END;
 210
 211      RESULT;
 212 END C47002C;