Subversion Repositories openrisc

-- CB20003.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 exceptions can be raised, reraised, and handled in an

--      accessed subprogram.

--

--

-- TEST DESCRIPTION:

--      Declare a record type, with one component being an access to

--      subprogram type.  Various subprograms are defined to fit the profile

--      of this access type, such that the record component can refer to

--      any of the subprograms.

--

--      Each of the subprograms raises a different exception, based on the

--      value of an input parameter.  Exceptions are 1) raised, handled with

--      an others handler, reraised and propagated to main to be handled in

--      a specific handler; 2) raised, handled in a specific handler, reraised

--      and propagated to the main to be handled in an others handler there,

--      and 3) raised and propagated directly to the caller by the subprogram.

--

--      Boolean variables are set throughout the test to ensure that correct

--      exception processing has occurred, and these variables are verified at

--      the conclusion of the test.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

package CB20003_0 is                          -- package Push_Buttons

   Non_Default_Priority,

   Non_Alert_Priority,

   Non_Emergency_Priority : exception;

   Handled_With_Others,

   Reraised_In_Subprogram,

   Handled_In_Caller      : Boolean := False;

   subtype Priority_Type is Integer range 1 .. 10;

   Default_Priority   : Priority_Type := 1;

   Alert_Priority     : Priority_Type := 3;

   Emergency_Priority : Priority_Type := 5;

   type Button is tagged private;                  -- Private tagged type.

   type Button_Response_Ptr is access procedure (P : in     Priority_Type;

                                                 B : in out Button);

   -- Procedures accessible with Button_Response_Ptr type.

   procedure Default_Response   (P : in     Priority_Type;

                                 B : in out Button);

   procedure Alert_Response     (P : in     Priority_Type;

                                 B : in out Button);

   procedure Emergency_Response (P : in     Priority_Type;

                                 B : in out Button);

   procedure Push (B : in out Button;

                   P : in     Priority_Type);

   procedure Set_Response (B : in out Button;

                           R : in     Button_Response_Ptr);

private

   type Button is tagged

      record

         Priority :  Priority_Type       := Default_Priority;

         Response :  Button_Response_Ptr := Default_Response'Access;

      end record;

end CB20003_0;                                -- package Push_Buttons

     --=================================================================--

with Report;

package body CB20003_0 is                     -- package Push_Buttons

   procedure Push (B : in out Button;

                   P : in     Priority_Type) is

   begin                                  -- Invoking subprogram designated

      B.Response (P, B);                  -- by access value.

   end Push;

   procedure Set_Response (B : in out Button;

                           R : in     Button_Response_Ptr) is

   begin

      B.Response := R;      -- Set procedure value in record

   end Set_Response;

   procedure Default_Response (P : in     Priority_Type;

                               B : in out Button) is

   begin

      if (P > Default_Priority) then

         raise Non_Default_Priority;

         Report.Failed ("Exception not raised in procedure body");

      else

         B.Priority := P;

      end if;

   exception

      when others =>                    -- Catch exception with others handler

         Handled_With_Others := True;   -- Successfully caught with "others"

         raise;

         Report.Failed ("Exception not reraised in handler");

   end Default_Response;

   procedure Alert_Response (P : in     Priority_Type;

                             B : in out Button) is

   begin

      if (P > Alert_Priority) then

         raise Non_Alert_Priority;

         Report.Failed ("Exception not raised in procedure body");

      else

         B.Priority := P;

      end if;

   exception

      when Non_Alert_Priority =>

         Reraised_In_Subprogram := True;

         raise;                                  -- Propagate to caller.

         Report.Failed ("Exception not reraised in procedure excpt handler");

      when others =>

         Report.Failed ("Incorrect exception raised/handled");

   end Alert_Response;

   procedure Emergency_Response (P : in     Priority_type;

                                 B : in out Button) is

   begin

      if (P > Emergency_Priority) then

         raise Non_Emergency_Priority;

         Report.Failed ("Exception not raised in procedure body");

      else

         B.Priority := P;

      end if;

      -- No exception handler here, exception will be propagated to caller.

   end Emergency_Response;

end CB20003_0;                                -- package Push_Buttons

     --=================================================================--

with Report;

with CB20003_0;                               -- package Push_Buttons

procedure CB20003 is

   package Push_Buttons renames CB20003_0;

   Console_Button : Push_Buttons.Button;

begin

   Report.Test ("CB20003", "Check that exceptions can be raised, "  &

                           "reraised, and handled in a subprogram " &

                           "referenced by an access to subprogram value");

   Default_Response_Processing:                 -- The exception

                                                -- Handled_With_Others is to

                                                -- be caught with an others

                                                -- handler in Default_Resp.,

                                                -- reraised, and handled with

                                                -- a specific handler here.

   begin

      Push_Buttons.Push (Console_Button,        -- Raise exception that will

                         Report.Ident_Int(2));  -- be handled in procedure.

   exception

      when Push_Buttons.Non_Default_Priority =>

         if not Push_Buttons.Handled_With_Others then   -- Not reraised in

                                                        -- procedure.

            Report.Failed

              ("Exception not handled/reraised in procedure");

         end if;

      when others =>

         Report.Failed ("Exception handled in " &

                        " Default_Response_Processing block");

   end Default_Response_Processing;

   Alert_Response_Processing:

   begin

      Push_Buttons.Set_Response (Console_Button,

                                 Push_Buttons.Alert_Response'access);

      Push_Buttons.Push (Console_Button,        -- Raise exception that will

                         Report.Ident_Int(4));  -- be handled in procedure,

                                                -- reraised, and propagated

                                                -- to caller.

      Report.Failed ("Exception not propagated to caller " &

                     "in Alert_Response_Processing block");

   exception

      when Push_Buttons.Non_Alert_Priority =>

         if not Push_Buttons.Reraised_In_Subprogram then  -- Not reraised in

                                                          -- procedure.

            Report.Failed ("Exception not reraised in procedure");

         end if;

      when others =>

         Report.Failed ("Exception handled in " &

                        " Alert_Response_Processing block");

   end Alert_Response_Processing;

   Emergency_Response_Processing:

   begin

      Push_Buttons.Set_Response (Console_Button,

                                 Push_Buttons.Emergency_Response'access);

      Push_Buttons.Push (Console_Button,        -- Raise exception that will

                         Report.Ident_Int(6));  -- be propagated directly to

                                                -- caller.

      Report.Failed ("Exception not propagated to caller " &

                     "in Emergency_Response_Processing block");

   exception

      when Push_Buttons.Non_Emergency_Priority =>

         Push_Buttons.Handled_In_Caller := True;

      when others =>

         Report.Failed ("Exception handled in " &

                        " Emergency_Response_Processing block");

   end Emergency_Response_Processing;

   if not (Push_Buttons.Handled_With_Others and

           Push_Buttons.Reraised_In_Subprogram and

           Push_Buttons.Handled_In_Caller )

   then

      Report.Failed ("Incorrect exception handling in referenced subprograms");

   end if;

   Report.Result;

end CB20003;