URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c410001.a] - Rev 149
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log