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

   1 -- C48004D.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 A RECORD, PRIVATE,
  26 -- OR LIMITED TYPE WITHOUT DISCRIMINANTS.
  27
  28 -- RM  01/12/80
  29 -- JBG 03/03/83
  30 -- EG  07/05/84
  31
  32 WITH REPORT;
  33
  34 PROCEDURE C48004D IS
  35
  36      USE REPORT;
  37
  38 BEGIN
  39
  40      TEST("C48004D","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " &
  41                     "IS A RECORD, PRIVATE, OR LIMITED TYPE WITHOUT " &
  42                     "DISCRIMINANTS");
  43
  44      DECLARE
  45
  46           TYPE  TC  IS
  47                RECORD
  48                     C : INTEGER := 18;
  49                END RECORD;
  50           TYPE ATC IS ACCESS TC;
  51           VC : ATC;
  52
  53           PACKAGE  P  IS
  54                TYPE   PRIV  IS PRIVATE;
  55                TYPE  LPRIV  IS LIMITED PRIVATE;
  56                TYPE A_PRIV  IS  ACCESS PRIV;
  57                TYPE A_LPRIV  IS  ACCESS LPRIV;
  58                PROCEDURE   CHECK( X: A_PRIV  );
  59                PROCEDURE  LCHECK( X: A_LPRIV );
  60                PROCEDURE LRCHECK( X: LPRIV );
  61           PRIVATE
  62                TYPE   PRIV  IS
  63                     RECORD
  64                          Q : INTEGER := 19;
  65                     END RECORD;
  66                TYPE  LPRIV  IS
  67                     RECORD
  68                          Q : INTEGER := 20;
  69                     END RECORD;
  70           END P;
  71
  72
  73           VP  :  P.A_PRIV;
  74           VLP : P.A_LPRIV;
  75
  76           TYPE LCR IS
  77                RECORD
  78                     C : P.LPRIV;
  79                END RECORD;
  80           TYPE A_LCR IS ACCESS LCR;
  81           VLCR : A_LCR;
  82
  83           PACKAGE BODY  P  IS
  84
  85                PROCEDURE  CHECK( X: A_PRIV )  IS
  86                BEGIN
  87                     IF  X.Q /= 19  THEN  FAILED( "WRONG VALUES - C2" );
  88                     END IF;
  89                END CHECK;
  90
  91                PROCEDURE  LCHECK( X: A_LPRIV )  IS
  92                BEGIN
  93                     IF  X.Q /= 20  THEN  FAILED( "WRONG VALUES - C3" );
  94                     END IF;
  95                END LCHECK;
  96
  97                PROCEDURE LRCHECK (X : LPRIV) IS
  98                BEGIN
  99                     IF X.Q /= 20 THEN
 100                          FAILED ("WRONG VALUES - C4");
 101                     END IF;
 102                END LRCHECK;
 103
 104           END P;
 105
 106      BEGIN
 107
 108           VC  :=  NEW TC;
 109           IF  VC.C /= 18  THEN FAILED( "WRONG VALUES  -  C1" );
 110           END IF;
 111
 112           VP  :=  NEW P.PRIV;
 113           P.CHECK( VP );
 114           VLP :=  NEW P.LPRIV;
 115           P.LCHECK( VLP );
 116
 117           VLCR := NEW LCR;
 118           P.LRCHECK( VLCR.ALL.C );
 119
 120      END;
 121
 122      RESULT;
 123
 124 END C48004D;