1-- C45112A.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 THE BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION
26-- ARE THE BOUNDS OF THE LEFT OPERAND.
27
28-- RJW 2/3/86
29
30WITH REPORT; USE REPORT;
31
32PROCEDURE C45112A IS
33
34     TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN;
35     A1 : ARR(IDENT_INT(3) .. IDENT_INT(4)) := (TRUE, FALSE);
36     A2 : ARR(IDENT_INT(1) .. IDENT_INT(2)) := (TRUE, FALSE);
37     SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST));
38
39     PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS
40     BEGIN
41          IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN
42               FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 );
43          END IF;
44     END CHECK;
45
46BEGIN
47
48     TEST ( "C45112A", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " &
49                       "ARRAY OPERATIONS" );
50
51     BEGIN
52          DECLARE
53               AAND : CONSTANT ARR := A1 AND A2;
54               AOR  : CONSTANT ARR := A1 OR A2;
55               AXOR : CONSTANT ARR := A1 XOR A2;
56          BEGIN
57               CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ",
58                            "'AND'" );
59
60               CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ",
61                            "'OR'" );
62
63               CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ",
64                            "'XOR'" );
65          END;
66     EXCEPTION
67          WHEN CONSTRAINT_ERROR =>
68               FAILED ( "CONSTRAINT_ERROR RAISED DURING " &
69                        "INTIALIZATIONS" );
70          WHEN OTHERS =>
71               FAILED ( "OTHER EXCEPTION RAISED DURING " &
72                        "INITIALIZATIONS" );
73     END;
74
75     DECLARE
76          PROCEDURE PROC (A : ARR; STR : STRING) IS
77          BEGIN
78               CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY",
79                      STR);
80          END PROC;
81     BEGIN
82          PROC ((A1 AND A2), "'AND'" );
83          PROC ((A1 OR A2), "'OR'" );
84          PROC ((A1 XOR A2), "'XOR'" );
85     EXCEPTION
86          WHEN OTHERS =>
87               FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " &
88                        "PARAMETERS" );
89     END;
90
91     DECLARE
92          FUNCTION FUNCAND RETURN ARR IS
93          BEGIN
94               RETURN A1 AND A2;
95          END FUNCAND;
96
97          FUNCTION FUNCOR RETURN ARR IS
98          BEGIN
99               RETURN A1 OR A2;
100          END FUNCOR;
101
102          FUNCTION FUNCXOR RETURN ARR IS
103          BEGIN
104               RETURN A1 XOR A2;
105          END FUNCXOR;
106
107     BEGIN
108          CHECK (FUNCAND, "RETURN STATEMENT", "'AND'");
109          CHECK (FUNCOR, "RETURN STATEMENT", "'OR'");
110          CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'");
111
112     EXCEPTION
113          WHEN OTHERS =>
114               FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " &
115                        "FROM FUNCTION" );
116     END;
117
118     BEGIN
119          DECLARE
120               GENERIC
121                   X : IN ARR;
122               PACKAGE PKG IS
123                    FUNCTION G RETURN ARR;
124               END PKG;
125
126               PACKAGE BODY PKG IS
127                    FUNCTION G RETURN ARR IS
128                    BEGIN
129                         RETURN X;
130                    END G;
131               END PKG;
132
133               PACKAGE PAND IS NEW PKG(X => A1 AND A2);
134               PACKAGE POR IS NEW PKG(X => A1 OR A2);
135               PACKAGE PXOR IS NEW PKG(X => A1 XOR A2);
136          BEGIN
137               CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'");
138               CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'");
139               CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'");
140          END;
141     EXCEPTION
142          WHEN OTHERS =>
143               FAILED ( "EXCEPTION RAISED DURING GENERIC " &
144                        "INSTANTIATION" );
145     END;
146
147     DECLARE
148          TYPE ACC IS ACCESS ARR;
149          AC : ACC;
150
151     BEGIN
152          AC :=  NEW ARR'(A1 AND A2);
153          CHECK (AC.ALL, "ALLOCATION", "'AND'");
154          AC :=  NEW ARR'(A1 OR A2);
155          CHECK (AC.ALL, "ALLOCATION", "'OR'");
156          AC :=  NEW ARR'(A1 XOR A2);
157          CHECK (AC.ALL, "ALLOCATION", "'XOR'");
158     EXCEPTION
159          WHEN OTHERS =>
160               FAILED ( "EXCEPTION RAISED ON ALLOCATION" );
161     END;
162
163     BEGIN
164          CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'");
165          CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'");
166          CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'");
167     EXCEPTION
168          WHEN OTHERS =>
169               FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" );
170     END;
171
172     DECLARE
173          TYPE REC IS
174               RECORD
175                    RCA : CARR;
176               END RECORD;
177          R1 : REC;
178
179     BEGIN
180          R1 := (RCA => (A1 AND A2));
181          CHECK (R1.RCA, "AGGREGATE", "'AND'");
182          R1 := (RCA => (A1 OR A2));
183          CHECK (R1.RCA, "AGGREGATE", "'OR'");
184          R1 := (RCA => (A1 XOR A2));
185          CHECK (R1.RCA, "AGGREGATE", "'XOR'");
186     EXCEPTION
187          WHEN OTHERS =>
188               FAILED ( "EXCEPTION RAISED ON AGGREGATE" );
189     END;
190
191     BEGIN
192          DECLARE
193               TYPE RECDEF IS
194                    RECORD
195                         RCDF1 : CARR := A1 AND A2;
196                         RCDF2 : CARR := A1 OR A2;
197                         RCDF3 : CARR := A1 XOR A2;
198                    END RECORD;
199               RD : RECDEF;
200          BEGIN
201               CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'");
202               CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'");
203               CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'");
204          EXCEPTION
205               WHEN OTHERS =>
206                    FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" );
207          END;
208     EXCEPTION
209          WHEN OTHERS =>
210               FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " &
211                        "DEFAULT RECORD" );
212     END;
213
214     DECLARE
215          PROCEDURE PDEF (X : CARR := A1 AND A2;
216                          Y : CARR := A1 OR A2;
217                          Z : CARR := A1 XOR A2 ) IS
218          BEGIN
219               CHECK (X, "DEFAULT PARAMETER", "'AND'");
220               CHECK (Y, "DEFAULT PARAMETER", "'OR'");
221               CHECK (Z, "DEFAULT PARAMETER", "'XOR'");
222          END PDEF;
223
224     BEGIN
225          PDEF;
226     EXCEPTION
227          WHEN OTHERS =>
228               FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" );
229     END;
230
231     RESULT;
232
233END C45112A;
234