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

   1 -- C48004C.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 THE FORM "NEW T" IS PERMITTED IF T IS AN UNCONSTRAINED
  26 -- RECORD, PRIVATE, OR LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT
  27 -- VALUES.
  28
  29 -- EG  08/03/84
  30
  31 WITH REPORT;
  32
  33 PROCEDURE C48004C IS
  34
  35      USE REPORT;
  36
  37 BEGIN
  38
  39      TEST("C48004C","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF "   &
  40                     "T IS AN UNCONSTRAINED RECORD, PRIVATE, OR "     &
  41                     "LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT " &
  42                     "VALUES");
  43
  44      DECLARE
  45
  46           TYPE  UR(A : INTEGER := 1; B : INTEGER := 2)  IS
  47                RECORD
  48                     C : INTEGER := 7;
  49                END RECORD;
  50
  51           PACKAGE  P  IS
  52
  53                TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS PRIVATE;
  54                TYPE UL(A, B : INTEGER := 1) IS LIMITED PRIVATE;
  55
  56           PRIVATE
  57
  58                TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS
  59                     RECORD
  60                          Q : INTEGER;
  61                     END RECORD;
  62                TYPE UL(A, B : INTEGER := 1) IS
  63                     RECORD
  64                          Q : INTEGER;
  65                     END RECORD;
  66
  67           END P;
  68
  69           USE P;
  70
  71           TYPE A_UR IS ACCESS UR;
  72           TYPE A_UP IS ACCESS UP;
  73           TYPE A_UL IS ACCESS UL;
  74
  75           V_UR : A_UR;
  76           V_UP : A_UP;
  77           V_UL : A_UL;
  78
  79      BEGIN
  80
  81           V_UR := NEW UR;
  82           IF ( V_UR.A /= IDENT_INT(1) OR V_UR.B /= 2 OR
  83                V_UR.C /= 7 ) THEN
  84                FAILED("WRONG VALUES - UR");
  85           END IF;
  86
  87           V_UP := NEW UP;
  88           IF ( V_UP.A /= IDENT_INT(12) OR V_UP.B /= 13 ) THEN
  89                FAILED("WRONG VALUES - UP");
  90           END IF;
  91
  92           V_UL := NEW UL;
  93           IF ( V_UL.A /= IDENT_INT(1) OR V_UL.B /= 1 ) THEN
  94                FAILED("WRONG VALUES - UL");
  95           END IF;
  96
  97      END;
  98
  99      RESULT;
 100
 101 END C48004C;