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

   1 -- CC1226B.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, FOR A FORMAL NONLIMITED PRIVATE TYPE, THAT ALL ALLOWABLE
  27 --     OPERATIONS ARE IMPLICITLY DECLARED.
  28
  29 -- HISTORY:
  30 --     BCB 04/04/88  CREATED ORIGINAL TEST.
  31 --     RJW 03/28/90  INITIALIZED PREVIOUSLY UNINITIALIZED VARIABLES.
  32 --     LDC 09/19/90  INITALIZED NLPVAR & NLPVAR2 TO DIFFERENT VALUES,
  33 --                   REMOVED USE CLAUSE.
  34 --     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  35
  36 WITH REPORT; USE REPORT;
  37 WITH SYSTEM; USE SYSTEM;
  38
  39 PROCEDURE CC1226B IS
  40
  41      TYPE DISCREC(DISC1 : INTEGER := 1;
  42                   DISC2 : BOOLEAN := FALSE) IS RECORD
  43           NULL;
  44      END RECORD;
  45
  46      GENERIC
  47           TYPE NLP IS PRIVATE;
  48           TYPE NLPDISC(DISC1 : INTEGER;
  49                        DISC2 : BOOLEAN) IS PRIVATE;
  50           WITH PROCEDURE INITIALIZE (N : OUT NLPDISC);
  51           WITH FUNCTION INITIALIZE RETURN NLP;
  52           WITH FUNCTION INITIALIZE_2 RETURN NLP;
  53      PACKAGE P IS
  54           FUNCTION IDENT(X : NLP) RETURN NLP;
  55           FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS;
  56      END P;
  57
  58      PACKAGE BODY P IS
  59           TYPE DER_NLP IS NEW NLP;
  60           NLPVAR : NLP := INITIALIZE_2;
  61           NLPVAR2, NLPVAR3 : NLP := INITIALIZE;
  62           DERNLP : DER_NLP := DER_NLP (INITIALIZE);
  63           NDVAR : NLPDISC(DISC1 => 5, DISC2 => TRUE);
  64           NLPVARADDRESS : ADDRESS;
  65           NLPSIZE : INTEGER;
  66           NLPBASESIZE : INTEGER;
  67
  68           FUNCTION IDENT(X : NLP) RETURN NLP IS
  69                Z : NLP := INITIALIZE;
  70           BEGIN
  71                IF EQUAL(3,3) THEN
  72                     RETURN X;
  73                END IF;
  74                RETURN Z;
  75           END IDENT;
  76
  77           FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS
  78                I : INTEGER;
  79                Z : ADDRESS := I'ADDRESS;
  80           BEGIN
  81                IF EQUAL(3,3) THEN
  82                     RETURN Y;
  83                END IF;
  84                RETURN Z;
  85           END IDENT_ADR;
  86
  87      BEGIN
  88           TEST ("CC1226B", "CHECK, FOR A FORMAL NONLIMITED PRIVATE " &
  89                            "TYPE THAT ALL ALLOWABLE OPERATIONS ARE " &
  90                            "IMPLICITLY DECLARED");
  91
  92           INITIALIZE (NDVAR);
  93
  94           NLPVAR := NLPVAR2;
  95
  96           IF NLPVAR /= NLPVAR2 THEN
  97                FAILED ("IMPROPER VALUE FROM ASSIGNMENT");
  98           END IF;
  99
 100           IF NLPVAR NOT IN NLP THEN
 101                FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
 102           END IF;
 103
 104           NLPVAR := NLP'(NLPVAR2);
 105
 106           IF NLPVAR /= NLPVAR2 THEN
 107                FAILED ("IMPROPER RESULT FROM QUALIFICATION");
 108           END IF;
 109
 110           NLPVAR := NLP(DERNLP);
 111
 112           IF NLPVAR /= IDENT(NLP(DERNLP)) THEN
 113                FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION");
 114           END IF;
 115
 116           NLPSIZE := IDENT_INT(NLP'SIZE);
 117
 118           IF NLPSIZE /= INTEGER(NLP'SIZE) THEN
 119                FAILED ("IMPROPER VALUE FOR NLP'SIZE");
 120           END IF;
 121
 122           NLPVARADDRESS := NLPVAR'ADDRESS;
 123
 124           IF NLPVAR'ADDRESS /= IDENT_ADR(NLPVARADDRESS) THEN
 125                FAILED ("IMPROPER VALUE FOR NLPVAR'ADDRESS");
 126           END IF;
 127
 128           IF NDVAR.DISC1 /= IDENT_INT(5) THEN
 129                FAILED ("IMPROPER DISCRIMINANT VALUE - 1");
 130           END IF;
 131
 132           IF NOT NDVAR.DISC2 THEN
 133                FAILED ("IMPROPER DISCRIMINANT VALUE - 2");
 134           END IF;
 135
 136           IF NOT NDVAR'CONSTRAINED THEN
 137                FAILED ("IMPROPER VALUE FOR NDVAR'CONSTRAINED");
 138           END IF;
 139
 140           NLPVAR := NLPVAR3;
 141
 142           IF NOT (NLPVAR = IDENT(NLPVAR3)) THEN
 143                FAILED ("IMPROPER VALUE FROM EQUALITY OPERATION");
 144           END IF;
 145
 146           IF NLPVAR /= IDENT(NLPVAR3) THEN
 147                FAILED ("IMPROPER VALUE FROM INEQUALITY OPERATION");
 148           END IF;
 149
 150           RESULT;
 151      END P;
 152
 153      PROCEDURE INITIALIZE (I : OUT DISCREC) IS
 154      BEGIN
 155           I := (5, TRUE);
 156      END INITIALIZE;
 157
 158      FUNCTION INITIALIZE RETURN INTEGER IS
 159      BEGIN
 160           RETURN 5;
 161      END INITIALIZE;
 162
 163      FUNCTION INITIALIZE_OTHER RETURN INTEGER IS
 164      BEGIN
 165           RETURN 3;
 166      END INITIALIZE_OTHER;
 167
 168      PACKAGE PACK IS NEW P(INTEGER,
 169                            DISCREC,
 170                            INITIALIZE,
 171                            INITIALIZE,
 172                            INITIALIZE_OTHER);
 173
 174 BEGIN
 175      NULL;
 176 END CC1226B;