1-- C34005I.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--     FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
27--     CHARACTER TYPE:
28--     CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29--     THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
30--     CONSTRAINED.
31--     CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32--     IMPOSED ON THE DERIVED SUBTYPE.
33
34-- HISTORY:
35--     JRK 9/15/86  CREATED ORIGINAL TEST.
36
37WITH REPORT; USE REPORT;
38
39PROCEDURE C34005I IS
40
41     TYPE COMPONENT IS NEW CHARACTER;
42
43     PACKAGE PKG IS
44
45          FIRST : CONSTANT := 0;
46          LAST  : CONSTANT := 100;
47
48          SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
49
50          TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
51
52          FUNCTION CREATE ( F, L  : INDEX;
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     SUBTYPE SUBPARENT IS PARENT (5 .. 7);
64
65     TYPE S IS NEW SUBPARENT;
66
67     X : T := (OTHERS => 'B');
68     Y : S := (OTHERS => 'B');
69
70     PACKAGE BODY PKG IS
71
72          FUNCTION CREATE
73             ( F, L  : INDEX;
74               C     : COMPONENT;
75               DUMMY : PARENT
76             ) RETURN PARENT
77          IS
78               A : PARENT (F .. L);
79               B : COMPONENT := C;
80          BEGIN
81               FOR I IN F .. L LOOP
82                    A (I) := B;
83                    B := COMPONENT'SUCC (B);
84               END LOOP;
85               RETURN A;
86          END CREATE;
87
88     END PKG;
89
90BEGIN
91     TEST ("C34005I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
92                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
93                      "WHEN THE DERIVED TYPE DEFINITION IS " &
94                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
95                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
96                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
97                      "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
98                      "TYPE IS A CHARACTER TYPE");
99
100     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
101
102     BEGIN
103          IF CREATE (2, 3, 'D', X) /= "DE" OR
104             CREATE (2, 3, 'D', Y) /= "DE" THEN
105               FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
106                       "SUBTYPE");
107          END IF;
108     EXCEPTION
109          WHEN CONSTRAINT_ERROR =>
110               FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
111          WHEN OTHERS =>
112               FAILED ("CALL TO CREATE RAISED EXCEPTION");
113     END;
114
115     IF X & "CD" /= "BBBCD" OR
116        Y & "CD" /= "BBBCD" THEN
117          FAILED ("INCORRECT &");
118     END IF;
119
120     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
121
122     IF T'FIRST /= 5 OR T'LAST /= 7 OR
123        S'FIRST /= 5 OR S'LAST /= 7 THEN
124          FAILED ("INCORRECT 'FIRST OR 'LAST");
125     END IF;
126
127     BEGIN
128          X := "ABC";
129          Y := "ABC";
130          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
131               FAILED ("INCORRECT CONVERSION TO PARENT");
132          END IF;
133     EXCEPTION
134          WHEN OTHERS =>
135               FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
136     END;
137
138     BEGIN
139          X := "AB";
140          FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := ""AB""");
141          IF X = "AB" THEN  -- USE X.
142               COMMENT ("X ALTERED -- X := ""AB""");
143          END IF;
144     EXCEPTION
145          WHEN CONSTRAINT_ERROR =>
146               NULL;
147          WHEN OTHERS =>
148               FAILED ("WRONG EXCEPTION RAISED -- X := ""AB""");
149     END;
150
151     BEGIN
152          X := "ABCD";
153          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
154                  "X := ""ABCD""");
155          IF X = "ABCD" THEN  -- USE X.
156               COMMENT ("X ALTERED -- X := ""ABCD""");
157          END IF;
158     EXCEPTION
159          WHEN CONSTRAINT_ERROR =>
160               NULL;
161          WHEN OTHERS =>
162               FAILED ("WRONG EXCEPTION RAISED -- " &
163                       "X := ""ABCD""");
164     END;
165
166     BEGIN
167          Y := "AB";
168          FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := ""AB""");
169          IF Y = "AB" THEN  -- USE Y.
170               COMMENT ("Y ALTERED -- Y := ""AB""");
171          END IF;
172     EXCEPTION
173          WHEN CONSTRAINT_ERROR =>
174               NULL;
175          WHEN OTHERS =>
176               FAILED ("WRONG EXCEPTION RAISED -- Y := ""AB""");
177     END;
178
179     BEGIN
180          Y := "ABCD";
181          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
182                  "Y := ""ABCD""");
183          IF Y = "ABCD" THEN  -- USE Y.
184               COMMENT ("Y ALTERED -- Y := ""ABCD""");
185          END IF;
186     EXCEPTION
187          WHEN CONSTRAINT_ERROR =>
188               NULL;
189          WHEN OTHERS =>
190               FAILED ("WRONG EXCEPTION RAISED -- " &
191                       "Y := ""ABCD""");
192     END;
193
194     RESULT;
195END C34005I;
196