c410001.a

来自「用于进行gcc测试」· A 代码 · 共 304 行

-- 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;