1-- CC1207B.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 THAT AN UNCONSTRAINED FORMAL TYPE WITH DISCRIMINANTS IS
27--     ALLOWED AS THE TYPE OF A SUBPROGRAM OR AN ENTRY FORMAL
28--     PARAMETER, AND AS THE TYPE OF A GENERIC FORMAL OBJECT PARAMETER,
29--     AS A GENERIC ACTUAL PARAMETER, AND IN A MEMBERSHIP TEST, IN A
30--     SUBTYPE DECLARATION, IN AN ACCESS TYPE DEFINITION, AND IN A
31--     DERIVED TYPE DEFINITION.
32
33-- HISTORY:
34--     BCB 08/04/88  CREATED ORIGINAL TEST.
35
36WITH REPORT; USE REPORT;
37
38PROCEDURE CC1207B IS
39
40     GENERIC
41          TYPE X (L : INTEGER) IS PRIVATE;
42     PACKAGE PACK IS
43     END PACK;
44
45BEGIN
46     TEST ("CC1207B", "CHECK THAT AN UNCONSTRAINED FORMAL TYPE WITH " &
47                      "DISCRIMINANTS IS ALLOWED AS THE TYPE OF A " &
48                      "SUBPROGRAM OR AN ENTRY FORMAL PARAMETER, AND " &
49                      "AS THE TYPE OF A GENERIC FORMAL OBJECT " &
50                      "PARAMETER, AS A GENERIC ACTUAL PARAMETER, AND " &
51                      "IN A MEMBERSHIP TEST, IN A SUBTYPE " &
52                      "DECLARATION, IN AN ACCESS TYPE DEFINITION, " &
53                      "AND IN A DERIVED TYPE DEFINITION");
54
55     DECLARE
56          TYPE REC (D : INTEGER := 3) IS RECORD
57               NULL;
58          END RECORD;
59
60          GENERIC
61               TYPE R (D : INTEGER) IS PRIVATE;
62               OBJ : R;
63          PACKAGE P IS
64               PROCEDURE S (X : R);
65
66               TASK T IS
67                    ENTRY E (Y : R);
68               END T;
69
70               SUBTYPE SUB_R IS R;
71
72               TYPE ACC_R IS ACCESS R;
73
74               TYPE NEW_R IS NEW R;
75
76               BOOL : BOOLEAN := (OBJ IN R);
77
78               SUB_VAR : SUB_R(5);
79
80               ACC_VAR : ACC_R := NEW R(5);
81
82               NEW_VAR : NEW_R(5);
83
84               PACKAGE NEW_PACK IS NEW PACK (R);
85          END P;
86
87          REC_VAR : REC(5) := (D => 5);
88
89          PACKAGE BODY P IS
90               PROCEDURE S (X : R) IS
91               BEGIN
92                    IF NOT EQUAL(X.D,5) THEN
93                         FAILED ("WRONG DISCRIMINANT VALUE - S");
94                    END IF;
95               END S;
96
97               TASK BODY T IS
98               BEGIN
99                    ACCEPT E (Y : R) DO
100                         IF NOT EQUAL(Y.D,5) THEN
101                              FAILED ("WRONG DISCRIMINANT VALUE - T");
102                         END IF;
103                    END E;
104               END T;
105          BEGIN
106               IF NOT EQUAL(OBJ.D,5) THEN
107                    FAILED ("IMPROPER DISCRIMINANT VALUE");
108               END IF;
109
110               S (OBJ);
111
112               T.E (OBJ);
113
114               IF NOT EQUAL(SUB_VAR.D,5) THEN
115                    FAILED ("IMPROPER DISCRIMINANT VALUE - SUBTYPE");
116               END IF;
117
118               IF NOT EQUAL(ACC_VAR.D,5) THEN
119                    FAILED ("IMPROPER DISCRIMINANT VALUE - ACCESS");
120               END IF;
121
122               IF NOT EQUAL(NEW_VAR.D,5) THEN
123                    FAILED ("IMPROPER DISCRIMINANT VALUE - DERIVED");
124               END IF;
125
126               IF NOT BOOL THEN
127                    FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
128               END IF;
129          END P;
130
131          PACKAGE NEW_P IS NEW P (REC,REC_VAR);
132
133     BEGIN
134          NULL;
135     END;
136
137     RESULT;
138END CC1207B;
139