1-- C34007V.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 A
28--     ONE-DIMENSIONAL ARRAY TYPE.  THIS TEST IS PART 2 OF 2 TESTS
29--     WHICH COVER THE OBJECTIVE.  THE FIRST PART IS IN TEST C34007D.
30
31-- HISTORY:
32--     BCB 04/12/90  CREATED ORIGINAL TEST FROM SPLIT OF C34007D.ADA.
33--     THS 09/18/90  REMOVED DECLARATION OF B, DELETED PROCEDURE A,
34--                   AND REMOVED ALL REFERENCES TO B.
35
36WITH SYSTEM; USE SYSTEM;
37WITH REPORT; USE REPORT;
38
39PROCEDURE C34007V IS
40
41     SUBTYPE COMPONENT IS INTEGER;
42
43     TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT;
44
45     SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) ..
46                                          IDENT_INT (7));
47
48     PACKAGE PKG IS
49
50          TYPE PARENT IS ACCESS DESIGNATED;
51
52          FUNCTION CREATE ( F, L  : NATURAL;
53                            C     : COMPONENT;
54                            DUMMY : PARENT   -- TO RESOLVE OVERLOADING.
55                          ) RETURN PARENT;
56
57     END PKG;
58
59     USE PKG;
60
61     TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
62
63     X : T         := NEW SUBDESIGNATED'(OTHERS => 2);
64     K : INTEGER   := X'SIZE;
65     Y : T         := NEW SUBDESIGNATED'(1, 2, 3);
66     W : PARENT    := NEW SUBDESIGNATED'(OTHERS => 2);
67     C : COMPONENT := 1;
68     N : CONSTANT  := 1;
69
70     FUNCTION V RETURN T IS
71     BEGIN
72          RETURN NEW SUBDESIGNATED'(OTHERS => C);
73     END V;
74
75     PACKAGE BODY PKG IS
76
77          FUNCTION CREATE
78             ( F, L  : NATURAL;
79               C     : COMPONENT;
80               DUMMY : PARENT
81             ) RETURN PARENT
82          IS
83               A : PARENT    := NEW DESIGNATED (F .. L);
84               B : COMPONENT := C;
85          BEGIN
86               FOR I IN F .. L LOOP
87                    A (I) := B;
88                    B := B + 1;
89               END LOOP;
90               RETURN A;
91          END CREATE;
92
93     END PKG;
94
95     FUNCTION IDENT (X : T) RETURN T IS
96     BEGIN
97          IF X = NULL OR ELSE
98             EQUAL (X'LENGTH, X'LENGTH) THEN
99               RETURN X;                          -- ALWAYS EXECUTED.
100          END IF;
101          RETURN NEW SUBDESIGNATED;
102     END IDENT;
103
104BEGIN
105     TEST ("C34007V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
106                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
107                      "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
108                      "ONE-DIMENSIONAL ARRAY TYPE.  THIS TEST IS " &
109                      "PART 2 OF 2 TESTS WHICH COVER THE OBJECTIVE.  " &
110                      "THE FIRST PART IS IN TEST C34007V");
111
112     W := PARENT (CREATE (2, 3, 4, X));
113     IF W = NULL OR ELSE W.ALL /= (4, 5) THEN
114          FAILED ("INCORRECT CONVERSION TO PARENT - 2");
115     END IF;
116
117     X := IDENT (Y);
118     IF X.ALL /= (1, 2, 3) OR CREATE (2, 3, 4, X) . ALL /= (4, 5) THEN
119          FAILED ("INCORRECT .ALL (VALUE)");
120     END IF;
121
122     X.ALL := (10, 11, 12);
123     IF X /= Y OR Y.ALL /= (10, 11, 12) THEN
124          FAILED ("INCORRECT .ALL (ASSIGNMENT)");
125     END IF;
126
127     Y.ALL := (1, 2, 3);
128     BEGIN
129          CREATE (2, 3, 4, X) . ALL := (10, 11);
130     EXCEPTION
131          WHEN OTHERS =>
132               FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
133     END;
134
135
136     X := IDENT (Y);
137     IF X (IDENT_INT (5)) /= 1 OR
138        CREATE (2, 3, 4, X) (3) /= 5 THEN
139          FAILED ("INCORRECT INDEX (VALUE)");
140     END IF;
141
142     Y.ALL := (1, 2, 3);
143     X := IDENT (Y);
144     BEGIN
145          CREATE (2, 3, 4, X) (2) := 10;
146     EXCEPTION
147          WHEN OTHERS =>
148               FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)");
149     END;
150
151     IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR
152        CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN
153          FAILED ("INCORRECT SLICE (VALUE)");
154     END IF;
155
156     Y.ALL := (1, 2, 3);
157     X := IDENT (Y);
158     BEGIN
159          CREATE (1, 4, 4, X) (2 .. 4) := (10, 11, 12);
160     EXCEPTION
161          WHEN OTHERS =>
162               FAILED ("EXCEPTION FOR SLICE (ASSIGNMENT)");
163     END;
164
165     IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
166        X = CREATE (2, 3, 4, X) THEN
167          FAILED ("INCORRECT =");
168     END IF;
169
170     IF X /= Y OR NOT (X /= NULL) OR NOT (X /= CREATE (2, 3, 4, X)) THEN
171          FAILED ("INCORRECT /=");
172     END IF;
173
174     IF NOT (X IN T) OR CREATE (2, 3, 4, X) IN T THEN
175          FAILED ("INCORRECT ""IN""");
176     END IF;
177
178     IF X NOT IN T OR NOT (CREATE (2, 3, 4, X) NOT IN T) THEN
179          FAILED ("INCORRECT ""NOT IN""");
180     END IF;
181
182     RESULT;
183END C34007V;
184