Subversion Repositories openrisc_me

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