3 -- Grant of Unlimited Rights
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
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.
27 -- Check that an exception declared in a package can be raised by a
28 -- child of a child package. Check that it can be renamed in the
29 -- child of the child package and raised with the correct effect.
32 -- Declare a package which defines complex number abstraction with
33 -- user-defined exceptions (foundation code).
35 -- Add a public child package to the above package. Declare two
36 -- subprograms for the parent type.
38 -- Add a public grandchild package to the foundation package. Declare
39 -- subprograms to raise exceptions.
41 -- In the main program, "with" the grandchild package, then check that
42 -- the exceptions are raised and handled as expected. Ensure that
44 -- 1) raised in the public grandchild package and handled/reraised to
45 -- be handled by the main program.
46 -- 2) raised and handled locally by the "others" handler in the
47 -- public grandchild package.
48 -- 3) raised in the public grandchild and propagated to the main
52 -- This test depends on the following foundation code:
58 -- 06 Dec 94 SAIC ACVC 2.0
62 -- Child package of FA11D00.
64 package FA11D00
.CA11D02_0
is -- Basic_Complex
66 function "+" (Left
, Right
: Complex_Type
)
67 return Complex_Type
; -- Add two complex numbers.
69 function "*" (Left
, Right
: Complex_Type
)
70 return Complex_Type
; -- Multiply two complex numbers.
72 end FA11D00
.CA11D02_0
; -- Basic_Complex
74 --=======================================================================--
76 package body FA11D00
.CA11D02_0
is -- Basic_Complex
78 function "+" (Left
, Right
: Complex_Type
) return Complex_Type
is
80 return ( (Left
.Real
+ Right
.Real
, Left
.Imag
+ Right
.Imag
) );
82 --------------------------------------------------------------
83 function "*" (Left
, Right
: Complex_Type
) return Complex_Type
is
85 return ( Real
=> (Left
.Real
* Right
.Real
),
86 Imag
=> (Left
.Imag
* Right
.Imag
) );
89 end FA11D00
.CA11D02_0
; -- Basic_Complex
91 --=======================================================================--
93 -- Child package of FA11D00.CA11D02_0.
94 -- Grandchild package of FA11D00.
96 package FA11D00
.CA11D02_0
.CA11D02_1
is -- Array_Complex
98 Inverse_Error
: exception renames Divide_Error
; -- Reference to exception
99 -- in grandparent package.
100 Array_Size
: constant := 2;
102 type Complex_Array_Type
is
103 array (1 .. Array_Size
) of Complex_Type
; -- Reference to type
104 -- in parent package.
106 function Multiply
(Left
: Complex_Array_Type
; -- Multiply two complex
107 Right
: Complex_Array_Type
) -- arrays.
108 return Complex_Array_Type
;
110 function Add
(Left
, Right
: Complex_Array_Type
) -- Add two complex
111 return Complex_Array_Type
; -- arrays.
113 procedure Inverse
(Right
: in Complex_Array_Type
; -- Invert a complex
114 Left
: in out Complex_Array_Type
); -- array.
116 end FA11D00
.CA11D02_0
.CA11D02_1
; -- Array_Complex
118 --=======================================================================--
123 package body FA11D00
.CA11D02_0
.CA11D02_1
is -- Array_Complex
125 function Multiply
(Left
: Complex_Array_Type
;
126 Right
: Complex_Array_Type
)
127 return Complex_Array_Type
is
129 -- This procedure will raise an exception depending on the input
130 -- parameter. The exception will be handled locally by the
133 Result
: Complex_Array_Type
:= (others => Zero
);
135 subtype Vector_Size
is Positive range Left
'Range;
138 if Left
= Result
or else Right
= Result
then -- Do not multiply zero.
139 raise Multiply_Error
; -- Refence to exception in
140 -- grandparent package.
141 Report
.Failed
("Program control not transferred by raise");
143 for I
in Vector_Size
loop
144 Result
(I
) := ( Left
(I
) * Right
(I
) ); -- Basic_Complex."*".
151 Report
.Comment
("Exception is handled by others in Multiplication");
152 TC_Handled_In_Grandchild_Pkg_Func
:= true;
156 --------------------------------------------------------------
157 function Add
(Left
, Right
: Complex_Array_Type
)
158 return Complex_Array_Type
is
160 -- This function will raise an exception depending on the input
161 -- parameter. The exception will be propagated and handled
164 Result
: Complex_Array_Type
:= (others => Zero
);
166 subtype Vector_Size
is Positive range Left
'Range;
169 if Left
= Result
or Right
= Result
then -- Do not add zero.
170 raise Add_Error
; -- Refence to exception in
171 -- grandparent package.
172 Report
.Failed
("Program control not transferred by raise");
174 for I
in Vector_Size
loop
175 Result
(I
) := ( Left
(I
) + Right
(I
) ); -- Basic_Complex."+".
181 --------------------------------------------------------------
182 procedure Inverse
(Right
: in Complex_Array_Type
;
183 Left
: in out Complex_Array_Type
) is
185 -- This function will raise an exception depending on the input
186 -- parameter. The exception will be handled/reraised to be
187 -- handled by the caller.
189 Result
: Complex_Array_Type
:= (others => Zero
);
191 Array_With_Zero
: boolean := false;
194 for I
in 1 .. Right
'Length loop
195 if Right
(I
) = Zero
then -- Check for zero.
196 Array_With_Zero
:= true;
200 If Array_With_Zero
then
201 raise Inverse_Error
; -- Do not inverse zero.
202 Report
.Failed
("Program control not transferred by raise");
204 for I
in 1 .. Array_Size
loop
205 Left
(I
).Real
:= - Right
(I
).Real
;
206 Left
(I
).Imag
:= - Right
(I
).Imag
;
211 when Inverse_Error
=>
212 TC_Handled_In_Grandchild_Pkg_Proc
:= true;
214 raise; -- Reraise the Inverse_Error exception in the subtest.
215 Report
.Failed
("Exception not reraised in handler");
218 Report
.Failed
("Unexpected exception in procedure Inverse");
221 end FA11D00
.CA11D02_0
.CA11D02_1
; -- Array_Complex
223 --=======================================================================--
225 with FA11D00
.CA11D02_0
.CA11D02_1
; -- Array_Complex,
226 -- implicitly with Basic_Complex.
231 package Complex_Pkg
renames FA11D00
;
232 package Array_Complex_Pkg
renames FA11D00
.CA11D02_0
.CA11D02_1
;
235 use Array_Complex_Pkg
;
239 Report
.Test
("CA11D02", "Check that an exception declared in a package " &
240 "can be raised by a child of a child package");
242 Multiply_Complex_Subtest
:
244 Operand_1
: Complex_Array_Type
245 := ( Complex
(Int_Type
(Report
.Ident_Int
(3)),
246 Int_Type
(Report
.Ident_Int
(5))),
247 Complex
(Int_Type
(Report
.Ident_Int
(2)),
248 Int_Type
(Report
.Ident_Int
(8))) );
249 Operand_2
: Complex_Array_Type
250 := ( Complex
(Int_Type
(Report
.Ident_Int
(1)),
251 Int_Type
(Report
.Ident_Int
(2))),
252 Complex
(Int_Type
(Report
.Ident_Int
(3)),
253 Int_Type
(Report
.Ident_Int
(6))) );
254 Operand_3
: Complex_Array_Type
:= ( Zero
, Zero
);
255 Mul_Result
: Complex_Array_Type
256 := ( Complex
(Int_Type
(Report
.Ident_Int
(3)),
257 Int_Type
(Report
.Ident_Int
(10))),
258 Complex
(Int_Type
(Report
.Ident_Int
(6)),
259 Int_Type
(Report
.Ident_Int
(48))) );
260 Complex_No
: Complex_Array_Type
:= (others => Zero
);
263 If (Multiply
(Operand_1
, Operand_2
) /= Mul_Result
) then
264 Report
.Failed
("Incorrect results from multiplication");
267 -- Error is raised and exception will be handled in grandchild package.
269 Complex_No
:= Multiply
(Operand_1
, Operand_3
);
271 if Complex_No
/= (Zero
, Zero
) then
272 Report
.Failed
("Exception was not raised in multiplication");
276 when Multiply_Error
=>
277 Report
.Failed
("Exception raised in multiplication and " &
278 "propagated to caller");
279 TC_Handled_In_Grandchild_Pkg_Func
:= false;
280 -- Improper exception handling in caller.
283 Report
.Failed
("Unexpected exception in multiplication");
284 TC_Handled_In_Grandchild_Pkg_Func
:= false;
285 -- Improper exception handling in caller.
287 end Multiply_Complex_Subtest
;
292 Operand_1
: Complex_Array_Type
293 := ( Complex
(Int_Type
(Report
.Ident_Int
(2)),
294 Int_Type
(Report
.Ident_Int
(7))),
295 Complex
(Int_Type
(Report
.Ident_Int
(5)),
296 Int_Type
(Report
.Ident_Int
(8))) );
297 Operand_2
: Complex_Array_Type
298 := ( Complex
(Int_Type
(Report
.Ident_Int
(4)),
299 Int_Type
(Report
.Ident_Int
(1))),
300 Complex
(Int_Type
(Report
.Ident_Int
(2)),
301 Int_Type
(Report
.Ident_Int
(3))) );
302 Operand_3
: Complex_Array_Type
:= ( Zero
, Zero
);
303 Add_Result
: Complex_Array_Type
304 := ( Complex
(Int_Type
(Report
.Ident_Int
(6)),
305 Int_Type
(Report
.Ident_Int
(8))),
306 Complex
(Int_Type
(Report
.Ident_Int
(7)),
307 Int_Type
(Report
.Ident_Int
(11))) );
308 Complex_No
: Complex_Array_Type
:= (others => Zero
);
311 Complex_No
:= Add
(Operand_1
, Operand_2
);
313 If (Complex_No
/= Add_Result
) then
314 Report
.Failed
("Incorrect results from addition");
317 -- Error is raised in grandchild package and exception
318 -- will be propagated to caller.
320 Complex_No
:= Add
(Operand_1
, Operand_3
);
322 if Complex_No
= Add_Result
then
323 Report
.Failed
("Exception was not raised in addition");
328 TC_Propagated_To_Caller
:= true; -- Exception is propagated.
331 Report
.Failed
("Unexpected exception in addition subtest");
332 TC_Propagated_To_Caller
:= false; -- Improper exception handling
334 end Add_Complex_Subtest
;
336 Inverse_Complex_Subtest
:
338 Operand_1
: Complex_Array_Type
339 := ( Complex
(Int_Type
(Report
.Ident_Int
(1)),
340 Int_Type
(Report
.Ident_Int
(5))),
341 Complex
(Int_Type
(Report
.Ident_Int
(3)),
342 Int_Type
(Report
.Ident_Int
(11))) );
343 Operand_3
: Complex_Array_Type
344 := ( Zero
, Complex
(Int_Type
(Report
.Ident_Int
(3)),
345 Int_Type
(Report
.Ident_Int
(6))) );
346 Inv_Result
: Complex_Array_Type
347 := ( Complex
(Int_Type
(Report
.Ident_Int
(-1)),
348 Int_Type
(Report
.Ident_Int
(-5))),
349 Complex
(Int_Type
(Report
.Ident_Int
(-3)),
350 Int_Type
(Report
.Ident_Int
(-11))) );
351 Complex_No
: Complex_Array_Type
:= (others => Zero
);
354 Inverse
(Operand_1
, Complex_No
);
356 if (Complex_No
/= Inv_Result
) then
357 Report
.Failed
("Incorrect results from inverse");
360 -- Error is raised in grandchild package and exception
361 -- will be handled/reraised to caller.
363 Inverse
(Operand_3
, Complex_No
);
365 Report
.Failed
("Exception was not handled in inverse");
368 when Inverse_Error
=>
369 if not TC_Handled_In_Grandchild_Pkg_Proc
then
370 Report
.Failed
("Exception was not raised in inverse");
372 TC_Handled_In_Caller
:= true; -- Exception is reraised from
377 Report
.Failed
("Unexpected exception in inverse");
378 TC_Handled_In_Caller
:= false;
379 -- Improper exception handling in caller.
381 end Inverse_Complex_Subtest
;
383 if not (TC_Handled_In_Caller
and -- Check to see that all
384 TC_Handled_In_Grandchild_Pkg_Proc
and -- exceptions were handled
385 TC_Handled_In_Grandchild_Pkg_Func
and -- in proper location.
386 TC_Propagated_To_Caller
)
388 Report
.Failed
("Exceptions handled in incorrect locations");