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