gcc/testsuite/ada/acats/tests/c3/c37006a.ada

   1 -- C37006A.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 -- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A
  26 -- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN
  27 -- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE
  28 -- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE.
  29
  30 -- R.WILLIAMS 8/28/86
  31
  32 WITH REPORT; USE REPORT;
  33 PROCEDURE C37006A IS
  34
  35      SUBTYPE INT IS INTEGER RANGE 0 .. 100;
  36
  37      TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
  38
  39      TYPE REC1 (D1, D2 : INT) IS
  40           RECORD
  41                A : ARR (D1 .. D2);
  42           END RECORD;
  43
  44      TYPE REC1_NAME IS ACCESS REC1;
  45
  46      PROCEDURE CHECK (AR : ARR; STR : STRING) IS
  47      BEGIN
  48           IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN
  49                FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " &
  50                         "OF " & STR & " TYPE");
  51           ELSIF AR /= (3, 4) THEN
  52                FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " &
  53                          STR & " TYPE FAILED" );
  54           END IF;
  55      END CHECK;
  56
  57      PACKAGE PACK IS
  58           TYPE PRIV (D1, D2 : INT) IS PRIVATE;
  59           TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE;
  60           FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV;
  61           PROCEDURE PRIV_CHECK (R : PRIV);
  62           PROCEDURE LIM_CHECK (R : LIM);
  63
  64      PRIVATE
  65           TYPE PRIV (D1, D2 : INT) IS
  66                RECORD
  67                     A : ARR (D1 .. D2);
  68                END RECORD;
  69
  70           TYPE LIM (D1, D2 : INT) IS
  71                RECORD
  72                     A : ARR (D1 .. D2);
  73                END RECORD;
  74      END PACK;
  75
  76      PACKAGE BODY PACK IS
  77
  78           FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS
  79           BEGIN
  80                RETURN (IDENT_INT (1), IDENT_INT (2),
  81                        ARR'(1 => 3, 2 => 4));
  82           END PRIV_FUN;
  83
  84           PROCEDURE PRIV_CHECK (R : PRIV) IS
  85           BEGIN
  86                CHECK (R.A, "PRIVATE TYPE" );
  87           END PRIV_CHECK;
  88
  89           PROCEDURE LIM_CHECK (R : LIM) IS
  90           BEGIN
  91                IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN
  92                     FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " &
  93                              "COMPONENT OF LIMITED PRIVATE TYPE");
  94                END IF;
  95           END LIM_CHECK;
  96      END PACK;
  97
  98      USE PACK;
  99
 100 BEGIN
 101
 102      TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " &
 103                        "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " &
 104                        "COMPONENT, CHECK THAT A NON-STATIC " &
 105                        "EXPRESSION CAN BE USED IN A DISCRIMINANT " &
 106                        "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " &
 107                        "COMPONENTS) IN SPECIFYING A DEFAULT " &
 108                        "INITIAL VALUE" );
 109
 110      BEGIN
 111           DECLARE
 112
 113                TYPE REC2 IS
 114                     RECORD
 115                          COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) :=
 116                                 (IDENT_INT (1), IDENT_INT (2),
 117                                  ARR'(1 => 3, 2 => 4));
 118                     END RECORD;
 119
 120           R : REC2;
 121
 122           BEGIN
 123                IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
 124                     CHECK (R.COMP.A, "RECORD");
 125                ELSE
 126                     FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
 127                              "OF RECORD TYPE COMPONENT" );
 128                END IF;
 129
 130           EXCEPTION
 131                WHEN CONSTRAINT_ERROR =>
 132                     FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
 133                              "SEQUENCE FOLLOWING DECLARATION OF " &
 134                              "RECORD TYPE COMPONENT" );
 135                WHEN OTHERS =>
 136                     FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
 137                              "SEQUENCE FOLLOWING DECLARATION OF " &
 138                              "RECORD TYPE COMPONENT" );
 139           END;
 140
 141      EXCEPTION
 142           WHEN CONSTRAINT_ERROR =>
 143                FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
 144                         "OF RECORD TYPE COMPONENT" );
 145           WHEN OTHERS =>
 146                FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
 147                         "OF RECORD TYPE COMPONENT" );
 148      END;
 149
 150      BEGIN
 151           DECLARE
 152
 153                TYPE REC2 IS
 154                     RECORD
 155                          COMP : REC1_NAME (IDENT_INT (1),
 156                                            IDENT_INT (2)) :=
 157                                 NEW REC1'(IDENT_INT (1),
 158                                           IDENT_INT (2),
 159                                           ARR'(1 => 3, 2 => 4));
 160                     END RECORD;
 161
 162           R : REC2;
 163
 164           BEGIN
 165                IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
 166                     CHECK (R.COMP.A, "ACCESS");
 167                ELSE
 168                     FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
 169                              "OF ACCESS TYPE COMPONENT" );
 170                END IF;
 171
 172           EXCEPTION
 173                WHEN CONSTRAINT_ERROR =>
 174                     FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
 175                              "SEQUENCE FOLLOWING DECLARATION OF " &
 176                              "ACCESS TYPE COMPONENT" );
 177                WHEN OTHERS =>
 178                     FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
 179                              "SEQUENCE FOLLOWING DECLARATION OF " &
 180                              "ACCESS TYPE COMPONENT" );
 181           END;
 182
 183      EXCEPTION
 184           WHEN CONSTRAINT_ERROR =>
 185                FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
 186                         "OF ACCESS TYPE COMPONENT" );
 187           WHEN OTHERS =>
 188                FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
 189                         "OF ACCESS TYPE COMPONENT" );
 190      END;
 191
 192      BEGIN
 193           DECLARE
 194
 195                TYPE REC2 IS
 196                     RECORD
 197                          COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) :=
 198                                 PRIV_FUN (IDENT_INT (1),
 199                                           IDENT_INT (2));
 200                     END RECORD;
 201
 202           R : REC2;
 203
 204           BEGIN
 205                IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
 206                     PRIV_CHECK (R.COMP);
 207                ELSE
 208                     FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
 209                              "OF PRIVATE TYPE COMPONENT" );
 210                END IF;
 211
 212           EXCEPTION
 213                WHEN CONSTRAINT_ERROR =>
 214                     FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
 215                              "SEQUENCE FOLLOWING DECLARATION OF " &
 216                              "PRIVATE TYPE COMPONENT" );
 217                WHEN OTHERS =>
 218                     FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
 219                              "SEQUENCE FOLLOWING DECLARATION OF " &
 220                              "PRIVATE TYPE COMPONENT" );
 221           END;
 222
 223      EXCEPTION
 224           WHEN CONSTRAINT_ERROR =>
 225                FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
 226                         "OF PRIVATE TYPE COMPONENT" );
 227           WHEN OTHERS =>
 228                FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
 229                         "OF PRIVATE TYPE COMPONENT" );
 230      END;
 231
 232      BEGIN
 233           DECLARE
 234
 235                TYPE REC2 IS
 236                     RECORD
 237                          COMP : LIM (IDENT_INT (1), IDENT_INT (2));
 238                     END RECORD;
 239
 240           R : REC2;
 241
 242           BEGIN
 243                IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
 244                     LIM_CHECK (R.COMP);
 245                ELSE
 246                     FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
 247                              "OF LIM PRIV TYPE COMPONENT" );
 248                END IF;
 249
 250           EXCEPTION
 251                WHEN CONSTRAINT_ERROR =>
 252                     FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
 253                              "SEQUENCE FOLLOWING DECLARATION OF " &
 254                              " LIM PRIV TYPE COMPONENT" );
 255                WHEN OTHERS =>
 256                     FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
 257                              "SEQUENCE FOLLOWING DECLARATION OF " &
 258                              " LIM PRIV TYPE COMPONENT" );
 259           END;
 260
 261      EXCEPTION
 262           WHEN CONSTRAINT_ERROR =>
 263                FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
 264                         "OF  LIM PRIV TYPE COMPONENT" );
 265           WHEN OTHERS =>
 266                FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
 267                         "OF  LIM PRIV TYPE COMPONENT" );
 268      END;
 269
 270      RESULT;
 271
 272 END C37006A;