1-- C41401A.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-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE PREFIX OF THE FOLLOWING
26-- ATTRIBUTES HAS THE VALUE NULL:
27--     A) 'CALLABLE AND 'TERMINATED FOR A TASK TYPE.
28--     B) 'FIRST, 'FIRST(N), 'LAST, 'LAST(N), 'LENGTH, 'LENGTH(N),
29--        'RANGE, AND 'RANGE(N) FOR AN ARRAY TYPE.
30
31-- TBN  10/2/86
32-- EDS  07/14/98    AVOID OPTIMIZATION
33
34WITH REPORT; USE REPORT;
35PROCEDURE C41401A IS
36
37     SUBTYPE INT IS INTEGER RANGE 1 .. 10;
38
39     TASK TYPE TT IS
40          ENTRY E;
41     END TT;
42
43     TYPE ACC_TT IS ACCESS TT;
44
45     TYPE NULL_ARR1 IS ARRAY (2 .. 1) OF INTEGER;
46     TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER;
47     TYPE NULL_ARR2 IS ARRAY (3 .. 1, 2 .. 1) OF INTEGER;
48     TYPE ARRAY2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER;
49     TYPE ACC_NULL1 IS ACCESS NULL_ARR1;
50     TYPE ACC_ARR1 IS ACCESS ARRAY1;
51     TYPE ACC_NULL2 IS ACCESS NULL_ARR2;
52     TYPE ACC_ARR2 IS ACCESS ARRAY2;
53
54     PTR_TT : ACC_TT;
55     PTR_ARA1: ACC_NULL1;
56     PTR_ARA2 : ACC_ARR1 (1 .. 4);
57     PTR_ARA3 : ACC_NULL2;
58     PTR_ARA4 : ACC_ARR2 (1 .. 2, 2 .. 4);
59     BOOL_VAR : BOOLEAN := FALSE;
60     INT_VAR : INTEGER := 1;
61
62     TASK BODY TT IS
63     BEGIN
64          ACCEPT E;
65     END TT;
66
67BEGIN
68     TEST ("C41401A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE " &
69                      "PREFIX HAS A VALUE OF NULL FOR THE FOLLOWING " &
70                      "ATTRIBUTES: 'CALLABLE, 'TERMINATED, 'FIRST, " &
71                      "'LAST, 'LENGTH, AND 'RANGE");
72
73     BEGIN
74          IF EQUAL (3, 2) THEN
75               PTR_TT := NEW TT;
76          END IF;
77          BOOL_VAR := IDENT_BOOL(PTR_TT'CALLABLE);
78          FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & BOOLEAN'IMAGE(BOOL_VAR));
79     EXCEPTION
80          WHEN CONSTRAINT_ERROR =>
81               NULL;
82          WHEN OTHERS =>
83               FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
84     END;
85
86     BEGIN
87          IF EQUAL (1, 3) THEN
88               PTR_TT := NEW TT;
89          END IF;
90          BOOL_VAR := IDENT_BOOL(PTR_TT'TERMINATED);
91          FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " & BOOLEAN'IMAGE(BOOL_VAR));
92     EXCEPTION
93          WHEN CONSTRAINT_ERROR =>
94               NULL;
95          WHEN OTHERS =>
96               FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
97     END;
98
99     BEGIN
100          INT_VAR := IDENT_INT(PTR_ARA1'FIRST);
101          FAILED ("CONSTRAINT_ERROR NOT RAISED - 5 " & INTEGER'IMAGE(INT_VAR));
102     EXCEPTION
103          WHEN CONSTRAINT_ERROR =>
104               NULL;
105          WHEN OTHERS =>
106               FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
107     END;
108
109     BEGIN
110          INT_VAR := IDENT_INT(PTR_ARA2'LAST);
111          FAILED ("CONSTRAINT_ERROR NOT RAISED - 7 " & INTEGER'IMAGE(INT_VAR));
112     EXCEPTION
113          WHEN CONSTRAINT_ERROR =>
114               NULL;
115          WHEN OTHERS =>
116               FAILED ("UNEXPECTED EXCEPTION RAISED - 8");
117     END;
118
119     BEGIN
120          INT_VAR := IDENT_INT(PTR_ARA1'LENGTH);
121          FAILED ("CONSTRAINT_ERROR NOT RAISED - 9 " & INTEGER'IMAGE(INT_VAR));
122     EXCEPTION
123          WHEN CONSTRAINT_ERROR =>
124               NULL;
125          WHEN OTHERS =>
126               FAILED ("UNEXPECTED EXCEPTION RAISED - 10");
127     END;
128
129     BEGIN
130          DECLARE
131               A : ARRAY1 (PTR_ARA2'RANGE);
132          BEGIN
133               A (1) := IDENT_INT(1);
134               FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 " &
135                       INTEGER'IMAGE(A(1)));
136          EXCEPTION
137               WHEN OTHERS =>
138                    FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 ");
139          END;
140     EXCEPTION
141          WHEN CONSTRAINT_ERROR =>
142               NULL;
143          WHEN OTHERS =>
144               FAILED ("UNEXPECTED EXCEPTION RAISED - 12");
145     END;
146
147     BEGIN
148          INT_VAR := IDENT_INT(PTR_ARA3'FIRST(2));
149          FAILED ("CONSTRAINT_ERROR NOT RAISED - 13 " & INTEGER'IMAGE(INT_VAR));
150     EXCEPTION
151          WHEN CONSTRAINT_ERROR =>
152               NULL;
153          WHEN OTHERS =>
154               FAILED ("UNEXPECTED EXCEPTION RAISED - 14");
155     END;
156
157     BEGIN
158          INT_VAR := IDENT_INT(PTR_ARA4'LAST(2));
159          FAILED ("CONSTRAINT_ERROR NOT RAISED - 15 " & INTEGER'IMAGE(INT_VAR));
160     EXCEPTION
161          WHEN CONSTRAINT_ERROR =>
162               NULL;
163          WHEN OTHERS =>
164               FAILED ("UNEXPECTED EXCEPTION RAISED - 16");
165     END;
166
167     BEGIN
168          INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(2));
169          FAILED ("CONSTRAINT_ERROR NOT RAISED - 17 " & INTEGER'IMAGE(INT_VAR));
170     EXCEPTION
171          WHEN CONSTRAINT_ERROR =>
172               NULL;
173          WHEN OTHERS =>
174               FAILED ("UNEXPECTED EXCEPTION RAISED - 18");
175     END;
176
177     BEGIN
178          DECLARE
179               A : ARRAY1 (PTR_ARA4'RANGE(2));
180          BEGIN
181               A (1) := IDENT_INT(1);
182               FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 " &
183                       INTEGER'IMAGE(A(1)));
184          EXCEPTION
185               WHEN OTHERS =>
186                    FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 ");
187          END;
188     EXCEPTION
189          WHEN CONSTRAINT_ERROR =>
190               NULL;
191          WHEN OTHERS =>
192               FAILED ("UNEXPECTED EXCEPTION RAISED - 20");
193     END;
194
195     BEGIN
196          INT_VAR := IDENT_INT(PTR_ARA4'LAST(1));
197          FAILED ("CONSTRAINT_ERROR NOT RAISED - 21 " & INTEGER'IMAGE(INT_VAR));
198     EXCEPTION
199          WHEN CONSTRAINT_ERROR =>
200               NULL;
201          WHEN OTHERS =>
202               FAILED ("UNEXPECTED EXCEPTION RAISED - 22");
203     END;
204
205     BEGIN
206          INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(1));
207          FAILED ("CONSTRAINT_ERROR NOT RAISED - 23 " & INTEGER'IMAGE(INT_VAR));
208     EXCEPTION
209          WHEN CONSTRAINT_ERROR =>
210               NULL;
211          WHEN OTHERS =>
212               FAILED ("UNEXPECTED EXCEPTION RAISED - 24");
213     END;
214
215     RESULT;
216END C41401A;
217