diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c410001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c4/c410001.a | 303 |
1 files changed, 0 insertions, 303 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c410001.a b/gcc/testsuite/ada/acats/tests/c4/c410001.a deleted file mode 100644 index 26555531b06..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c410001.a +++ /dev/null @@ -1,303 +0,0 @@ --- 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; |