1-- C34007A.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 ACCESS TYPES WHOSE DESIGNATED TYPE IS
28--     NOT AN ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A TYPE WITH
29--     DISCRIMINANTS.
30
31-- HISTORY:
32--     JRK 09/24/86  CREATED ORIGINAL TEST.
33--     BCB 10/21/87  CHANGED HEADER TO STANDARD FORMAT.  REVISED TEST SO
34--                   T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
35--     BCB 09/26/88  REMOVED COMPARISON INVOLVING OBJECT SIZE.
36--     BCB 03/07/90  PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
37--     THS 09/18/90  REMOVED DECLARATION OF B, MADE THE BODY OF
38--                   PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
39--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
40
41WITH SYSTEM; USE SYSTEM;
42WITH REPORT; USE REPORT;
43
44PROCEDURE C34007A IS
45
46     TYPE DESIGNATED IS RANGE -100 .. 100;
47
48     SUBTYPE SUBDESIGNATED IS DESIGNATED RANGE
49               DESIGNATED'VAL (IDENT_INT (-50)) ..
50               DESIGNATED'VAL (IDENT_INT ( 50));
51
52     TYPE PARENT IS ACCESS SUBDESIGNATED RANGE
53               DESIGNATED'VAL (IDENT_INT (-30)) ..
54               DESIGNATED'VAL (IDENT_INT ( 30));
55
56     TYPE T IS NEW PARENT;
57
58     X : T       := NEW DESIGNATED'(-30);
59     K : INTEGER := X'SIZE;
60     Y : T       := NEW DESIGNATED'( 30);
61     W : PARENT  := NEW DESIGNATED'( 30);
62
63     PROCEDURE A (X : ADDRESS) IS
64     BEGIN
65          NULL;
66     END A;
67
68     FUNCTION IDENT (X : T) RETURN T IS
69     BEGIN
70          IF X = NULL OR ELSE
71             EQUAL (DESIGNATED'POS (X.ALL), DESIGNATED'POS (X.ALL)) THEN
72               RETURN X;                          -- ALWAYS EXECUTED.
73          END IF;
74          RETURN NEW DESIGNATED;
75     END IDENT;
76
77BEGIN
78     TEST ("C34007A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
79                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
80                      "ACCESS TYPES WHOSE DESIGNATED TYPE IS NOT AN " &
81                      "ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A " &
82                      "TYPE WITH DISCRIMINANTS");
83
84     IF Y = NULL OR ELSE Y.ALL /= 30 THEN
85          FAILED ("INCORRECT INITIALIZATION");
86     END IF;
87
88     X := IDENT (Y);
89     IF X /= Y THEN
90          FAILED ("INCORRECT :=");
91     END IF;
92
93     IF T'(X) /= Y THEN
94          FAILED ("INCORRECT QUALIFICATION");
95     END IF;
96
97     IF T (X) /= Y THEN
98          FAILED ("INCORRECT SELF CONVERSION");
99     END IF;
100
101     IF EQUAL (3, 3) THEN
102          W := NEW DESIGNATED'(-30);
103     END IF;
104     X := T (W);
105     IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= -30 THEN
106          FAILED ("INCORRECT CONVERSION FROM PARENT");
107     END IF;
108
109     X := IDENT (Y);
110     W := PARENT (X);
111     IF W = NULL OR ELSE W.ALL /= 30 OR ELSE T (W) /= Y THEN
112          FAILED ("INCORRECT CONVERSION TO PARENT");
113     END IF;
114
115     IF IDENT (NULL) /= NULL OR X = NULL THEN
116          FAILED ("INCORRECT NULL");
117     END IF;
118
119     X := IDENT (NEW DESIGNATED'(30));
120     IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= 30 THEN
121          FAILED ("INCORRECT ALLOCATOR");
122     END IF;
123
124     X := IDENT (Y);
125     IF X.ALL /= 30 THEN
126          FAILED ("INCORRECT .ALL (VALUE)");
127     END IF;
128
129     X.ALL := DESIGNATED'VAL (IDENT_INT (10));
130     IF X /= Y OR Y.ALL /= 10 THEN
131          FAILED ("INCORRECT .ALL (ASSIGNMENT)");
132     END IF;
133
134     Y.ALL := 30;
135     X := IDENT (NULL);
136     BEGIN
137          IF X.ALL = 0 THEN
138               FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
139          ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
140          END IF;
141     EXCEPTION
142          WHEN CONSTRAINT_ERROR =>
143               NULL;
144          WHEN OTHERS =>
145               FAILED ("WRONG EXCEPTION FOR NULL.ALL");
146     END;
147
148     X := IDENT (Y);
149     IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN
150          FAILED ("INCORRECT =");
151     END IF;
152
153     IF X /= Y OR NOT (X /= NULL) THEN
154          FAILED ("INCORRECT /=");
155     END IF;
156
157     IF NOT (X IN T) THEN
158          FAILED ("INCORRECT ""IN""");
159     END IF;
160
161     IF X NOT IN T THEN
162          FAILED ("INCORRECT ""NOT IN""");
163     END IF;
164
165     A (X'ADDRESS);
166
167     BEGIN
168          IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
169               FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
170                       "EQUAL OF COLLECTION SIZE OF PARENT TYPE");
171          END IF;
172     EXCEPTION
173          WHEN PROGRAM_ERROR =>
174               COMMENT ("PROGRAM_ERROR RAISED FOR " &
175                        "UNDEFINED STORAGE_SIZE (AI-00608)");
176          WHEN OTHERS =>
177               FAILED ("UNEXPECTED EXCEPTION RAISED");
178     END;
179
180     RESULT;
181END C34007A;
182