diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c410001.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c410001.a | 303 |
1 files changed, 303 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c410001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c410001.a new file mode 100644 index 000000000..26555531b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c410001.a @@ -0,0 +1,303 @@ +-- C410001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that evaluating an access to subprogram variable containing +-- the value null causes the exception Constraint_Error. +-- Check that the default value for objects of access to subprogram +-- types is null. +-- +-- TEST DESCRIPTION: +-- This test defines a few simple access_to_subprogram types, and +-- objects of those types. It checks that the default values for +-- these objects is null, and that an attempt to make a subprogram +-- call via one of this objects containing a null value causes the +-- predefined exception Constraint_Error. The check is performed +--- both with the default null value, and with an explicitly assigned +-- null value, after the object has been used to successfully designate +-- and call a subprogram. +-- +-- +-- CHANGE HISTORY: +-- 05 APR 96 SAIC Initial version +-- 04 NOV 96 SAIC Revised for 2.1 release +-- 26 FEB 97 PWB.CTA Initialized variable before passing to function +--! + +----------------------------------------------------------------- C410001_0 + +package C410001_0 is + + -- used to "switch state" in the software + Expect_Exception : Boolean; + + -- define a minimal mixture of access_to_subprogram types + + type Proc_Ref is access procedure; + + type Func_Ref is access function(I:Integer) return Integer; + + type Proc_Para_Ref is access procedure(P:Proc_Ref); + + type Func_Para_Ref is access function(F:Func_Ref) return Integer; + + type Prot_Proc_Ref is access protected procedure; + + type Prot_Func_Ref is access protected function return Boolean; + + -- define some subprograms for them to reference + + procedure Proc; + + function Func(I:Integer) return Integer; + + procedure Proc_Para( Param : Proc_Ref ); + + function Func_Para( Param : Func_Ref ) return Integer; + + protected Prot_Obj is + procedure Prot_Proc; + function Prot_Func return Boolean; + end Prot_Obj; + +end C410001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C410001_0 is + + -- Note that some failing cases will cause duplicate failure messages; + -- rather than have the procedure/function bodies be null, the error + -- checking code makes for a reasonable anti-optimization feature. + + procedure Proc is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Proc"); + end if; + end Proc; + + function Func(I:Integer) return Integer is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Func"); + end if; + return Report.Ident_Int(I); + end Func; + + procedure Proc_Para( Param : Proc_Ref ) is + begin + + Param.all; -- call by explicit dereference + + if Expect_Exception then + Report.Failed("Expected exception did not occur: Proc_Para"); + end if; + + exception + when Constraint_Error => + if not Expect_Exception then + Report.Failed("Unexpected Constraint_Error: Proc_Para"); + end if; -- else null; expected the exception + when others => Report.Failed("Unexpected exception: Proc_Para"); + end Proc_Para; + + function Func_Para( Param : Func_Ref ) return Integer is + begin + + return Param(1); -- call by implicit dereference + + if Expect_Exception then + Report.Failed("Expected exception did not occur: Func_Para"); + end if; + return 1; -- really just to avoid warnings + + exception + when Constraint_Error => + if not Expect_Exception then + Report.Failed("Unexpected Constraint_Error: Func_Para"); + return 0; + else + return 1995; -- any value other than this is unexpected + end if; + when others => Report.Failed("Unexpected exception: Func_Para"); + return -42; + end Func_Para; + + protected body Prot_Obj is + + procedure Prot_Proc is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Prot_Proc"); + end if; + end Prot_Proc; + + function Prot_Func return Boolean is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Prot_Func"); + end if; + return Report.Ident_Bool( True ); + end Prot_Func; + + end Prot_Obj; + +end C410001_0; + +------------------------------------------------------------------- C410001 + +with Report; +with TCTouch; +with C410001_0; +procedure C410001 is + + Proc_Ref_Var : C410001_0.Proc_Ref; + + Func_Ref_Var : C410001_0.Func_Ref; + + Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref; + + Func_Para_Ref_Var : C410001_0.Func_Para_Ref; + + type Enclosure is record + Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref; + Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref; + end record; + + Enclosed : Enclosure; + + Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access; + + Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access; + + procedure Make_Calls( Expecting_Exceptions : Boolean ) is + type Case_Numbers is range 1..6; + Some_Integer : Integer := 0; + begin + for Cases in Case_Numbers loop + Catch_Exception : begin + case Cases is + when 1 => Proc_Ref_Var.all; + when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer ); + when 3 => Proc_Para_Ref_Var( Valid_Proc ); + when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func ); + when 5 => Enclosed.Prot_Proc_Ref_Var.all; + when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all + /= Expecting_Exceptions, + "Case 6"); + end case; + if Expecting_Exceptions then + Report.Failed("Exception expected: Case" + & Case_Numbers'Image(Cases) ); + end if; + exception + when Constraint_Error => + if not Expecting_Exceptions then + Report.Failed("Constraint_Error not expected: Case" + & Case_Numbers'Image(Cases) ); + end if; + when others => + Report.Failed("Wrong/Bad Exception: Case" + & Case_Numbers'Image(Cases) ); + end Catch_Exception; + end loop; + end Make_Calls; + +begin -- Main test procedure. + + Report.Test ("C410001", "Check that evaluating an access to subprogram " & + "variable containing the value null causes the " & + "exception Constraint_Error. Check that the " & + "default value for objects of access to " & + "subprogram types is null" ); + + -- check that the default values are null + declare + use C410001_0; -- make all "="'s visible for all types + begin + TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" ); + + TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" ); + + TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" ); + + TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" ); + + TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null, + "Enclosed.Prot_Proc_Ref_Var = null" ); + + TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null, + "Enclosed.Prot_Func_Ref_Var = null" ); + end; + + -- check that calls via the default values cause Constraint_Error + + C410001_0.Expect_Exception := True; + + Make_Calls( Expecting_Exceptions => True ); + + -- assign non-null values to the objects + + Proc_Ref_Var := C410001_0.Proc'Access; + Func_Ref_Var := C410001_0.Func'Access; + Proc_Para_Ref_Var := C410001_0.Proc_Para'Access; + Func_Para_Ref_Var := C410001_0.Func_Para'Access; + Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access, + C410001_0.Prot_Obj.Prot_Func'Access); + + -- check that the calls perform normally + + C410001_0.Expect_Exception := False; + + Make_Calls( Expecting_Exceptions => False ); + + -- check that a passed null value causes Constraint_Error + + C410001_0.Expect_Exception := True; + + Proc_Para_Ref_Var( null ); + + TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995, + "Func_Para_Ref_Var( null )"); + + -- assign the null value to the objects + + Proc_Ref_Var := null; + Func_Ref_Var := null; + Proc_Para_Ref_Var := null; + Func_Para_Ref_Var := null; + Enclosed := (null,null); + + -- check that calls now again cause Constraint_Error + + C410001_0.Expect_Exception := True; + + Make_Calls( Expecting_Exceptions => True ); + + Report.Result; + +end C410001; |