1-- C34006G.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27--     (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS AND
28--     WITH A LIMITED COMPONENT TYPE.
29
30-- HISTORY:
31--     JRK 08/24/87  CREATED ORIGINAL TEST.
32--     PWN 11/30/94  REMOVED 'BASE USE ILLEGAL IN ADA 9X.
33--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
34
35WITH SYSTEM; USE SYSTEM;
36WITH REPORT; USE REPORT;
37
38PROCEDURE C34006G IS
39
40     PACKAGE PKG_L IS
41
42          TYPE LP IS LIMITED PRIVATE;
43
44          FUNCTION CREATE (X : INTEGER) RETURN LP;
45
46          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
47
48          PROCEDURE ASSIGN (X : OUT LP; Y : LP);
49
50          C1 : CONSTANT LP;
51
52     PRIVATE
53
54          TYPE LP IS NEW INTEGER;
55
56          C1 : CONSTANT LP := 1;
57
58     END PKG_L;
59
60     USE PKG_L;
61
62     SUBTYPE COMPONENT IS LP;
63
64     PACKAGE PKG_P IS
65
66          TYPE PARENT IS
67               RECORD
68                    C : COMPONENT;
69                    B : BOOLEAN := TRUE;
70               END RECORD;
71
72          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
73
74          FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT;
75
76     END PKG_P;
77
78     USE PKG_P;
79
80     TYPE T IS NEW PARENT;
81
82     X : T;
83     W : PARENT;
84     B : BOOLEAN := FALSE;
85
86     PROCEDURE A (X : ADDRESS) IS
87     BEGIN
88          B := IDENT_BOOL (TRUE);
89     END A;
90
91     PACKAGE BODY PKG_L IS
92
93          FUNCTION CREATE (X : INTEGER) RETURN LP IS
94          BEGIN
95               RETURN LP (IDENT_INT (X));
96          END CREATE;
97
98          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
99          BEGIN
100               RETURN X = Y;
101          END EQUAL;
102
103          PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
104          BEGIN
105               X := Y;
106          END ASSIGN;
107
108     END PKG_L;
109
110     PACKAGE BODY PKG_P IS
111
112          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
113          BEGIN
114               RETURN EQUAL (X.C, Y.C) AND X.B = Y.B;
115          END EQUAL;
116
117          FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT IS
118               RESULT : PARENT;
119          BEGIN
120               ASSIGN (RESULT.C, C);
121               RESULT.B := B;
122               RETURN RESULT;
123          END AGGR;
124
125     END PKG_P;
126
127BEGIN
128     TEST ("C34006G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
129                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
130                      "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH A " &
131                      "LIMITED COMPONENT TYPE");
132
133     ASSIGN (X.C, CREATE (1));
134     X.B := IDENT_BOOL (TRUE);
135
136     ASSIGN (W.C, CREATE (1));
137     W.B := IDENT_BOOL (TRUE);
138
139     IF NOT EQUAL (T'(X), AGGR (C1, TRUE)) THEN
140          FAILED ("INCORRECT QUALIFICATION");
141     END IF;
142
143     IF NOT EQUAL (T (X), AGGR (C1, TRUE)) THEN
144          FAILED ("INCORRECT SELF CONVERSION");
145     END IF;
146
147     IF NOT EQUAL (T (W), AGGR (C1, TRUE)) THEN
148          FAILED ("INCORRECT CONVERSION FROM PARENT");
149     END IF;
150
151     IF NOT EQUAL (PARENT (X), AGGR (C1, TRUE)) THEN
152          FAILED ("INCORRECT CONVERSION TO PARENT");
153     END IF;
154
155     IF NOT EQUAL (X.C, C1) OR X.B /= TRUE THEN
156          FAILED ("INCORRECT SELECTION (VALUE)");
157     END IF;
158
159     X.B := IDENT_BOOL (FALSE);
160     IF NOT EQUAL (X, AGGR (C1, FALSE)) THEN
161          FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
162     END IF;
163
164     X.B := IDENT_BOOL (TRUE);
165     IF NOT (X IN T) THEN
166          FAILED ("INCORRECT ""IN""");
167     END IF;
168
169     IF X NOT IN T THEN
170          FAILED ("INCORRECT ""NOT IN""");
171     END IF;
172
173     B := FALSE;
174     A (X'ADDRESS);
175     IF NOT B THEN
176          FAILED ("INCORRECT 'ADDRESS");
177     END IF;
178
179     IF X.C'FIRST_BIT < 0 THEN
180          FAILED ("INCORRECT 'FIRST_BIT");
181     END IF;
182
183     IF X.C'LAST_BIT < 0 OR
184        X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
185          FAILED ("INCORRECT 'LAST_BIT");
186     END IF;
187
188     IF X.C'POSITION < 0 THEN
189          FAILED ("INCORRECT 'POSITION");
190     END IF;
191
192     IF X'SIZE   < T'SIZE OR
193        X.C'SIZE < COMPONENT'SIZE OR
194        X.B'SIZE < BOOLEAN'SIZE THEN
195          FAILED ("INCORRECT OBJECT'SIZE");
196     END IF;
197
198     RESULT;
199END C34006G;
200