cb20001.a

来自「Mac OS X 10.4.9 for x86 Source Code gcc」· A 代码 · 共 229 行

-- CB20001.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 handled in accept bodies, and that a
--      task object that has an exception handled in an accept body is still
--      viable for future use.
--
-- TEST DESCRIPTION:
--      Declare a task that has exception handlers within an accept
--      statement in the task body.  Declare a task object, and make entry
--      calls with data that will cause various exceptions to be raised
--      by the accept statement.  Ensure that the exceptions are: 
--         1) raised and handled locally in the accept body
--         2) raised in the accept body and handled/reraised to be handled 
--            by the task body
--         3) raised in the accept body and propagated to the calling 
--            procedure. 
--
--       
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

with Report;

package CB20001_0 is               

   Incorrect_Data,
   Location_Error,
   Off_Screen_Data           : exception;

   TC_Handled_In_Accept,
   TC_Reraised_In_Accept,
   TC_Handled_In_Task_Block,
   TC_Handled_In_Caller      : boolean := False;

   type Location_Type is range 0 .. 2000;

   task type Submarine_Type is
      entry Contact (Location : in Location_Type);
   end Submarine_Type;

   Current_Position : Location_Type := 0;

end CB20001_0;


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


package body CB20001_0 is


   task body Submarine_Type is
   begin
      loop

         Task_Block:
         begin
            select
               accept Contact (Location : in Location_Type) do
                  if Location > 1000 then
                     raise Off_Screen_Data;
                  elsif (Location > 500) and (Location <= 1000) then
                     raise Location_Error;
                  elsif (Location > 100) and (Location <= 500) then
                     raise Incorrect_Data;
                  else
                     Current_Position := Location;
                  end if;
               exception
                  when Off_Screen_Data =>
                     TC_Handled_In_Accept := True;
                  when Location_Error =>
                     TC_Reraised_In_Accept := True;
                     raise;   -- Reraise the Location_Error exception
                              -- in the task block.
               end Contact;
            or
               terminate;
            end select;

         exception

            when Off_Screen_Data =>
                TC_Handled_In_Accept := False;
                Report.Failed ("Off_Screen_Data exception " &
                               "improperly handled in task block");

            when Location_Error =>
                TC_Handled_In_Task_Block := True;
         end Task_Block;

      end loop;

   exception

      when Location_Error | Off_Screen_Data =>
         TC_Handled_In_Accept := False;
         TC_Handled_In_Task_Block := False;
         Report.Failed ("Exception improperly propagated out to task body"); 
      when others =>
         null;
   end Submarine_Type;

end CB20001_0;


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


with CB20001_0;       
with Report;
with ImpDef;

procedure CB20001 is

   package Submarine_Tracking renames CB20001_0;

   Trident       : Submarine_Tracking.Submarine_Type;   -- Declare task
   Sonar_Contact : Submarine_Tracking.Location_Type;

   TC_LEB_Error,
   TC_Main_Handler_Used : Boolean := False;

begin

   Report.Test ("CB20001", "Check that exceptions can be handled " &
                           "in accept bodies");


   Off_Screen_Block:
   begin
      Sonar_Contact := 1500;
      Trident.Contact (Sonar_Contact);  -- Cause Off_Screen_Data exception
                                        -- to be raised and handled in a task 
                                        -- accept body.
   exception                            
      when Submarine_Tracking.Off_Screen_Data =>
          TC_Main_Handler_Used := True;
          Report.Failed ("Off_Screen_Data exception improperly handled " &
                         "in calling procedure");
      when others =>
          Report.Failed ("Exception handled unexpectedly in " &
                         "Off_Screen_Block");
   end Off_Screen_Block;


   Location_Error_Block:
   begin
      Sonar_Contact := 700;
      Trident.Contact (Sonar_Contact);  -- Cause Location_Error exception
                                        -- to be raised in task accept body,
                                        -- propogated to a task block, and
                                        -- handled there.  Corresponding
                                        -- exception propagated here also.
      Report.Failed ("Expected exception not raised");
   exception                            
      when Submarine_Tracking.Location_Error =>
          TC_LEB_Error := True;
      when others =>
          Report.Failed ("Exception handled unexpectedly in " &
                         "Location_Error_Block");
   end Location_Error_Block;


   Incorrect_Data_Block:
   begin
      Sonar_Contact := 200;
      Trident.Contact (Sonar_Contact);  -- Cause Incorrect_Data exception
                                        -- to be raised in task accept body,
                                        -- propogated to calling procedure.
      Report.Failed ("Expected exception not raised");
   exception                            
      when Submarine_Tracking.Incorrect_Data =>
          Submarine_Tracking.TC_Handled_In_Caller := True;
      when others =>
          Report.Failed ("Exception handled unexpectedly in " &
                         "Incorrect_Data_Block");
   end Incorrect_Data_Block;


   if TC_Main_Handler_Used or
      not (Submarine_Tracking.TC_Handled_In_Caller     and -- Check to see that
           Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions
           Submarine_Tracking.TC_Handled_In_Accept     and -- were handled in
           Submarine_Tracking.TC_Reraised_In_Accept    and -- proper locations.
           TC_LEB_Error)       
   then                                                    
      Report.Failed ("Exceptions handled in incorrect locations");
   end if;

   if Integer(Submarine_Tracking.Current_Position) /= 0 then
      Report.Failed ("Variable incorrectly written in task processing");
   end if;

   delay ImpDef.Minimum_Task_Switch;
   if Trident'Callable then
      Report.Failed ("Task didn't terminate with exception propagation");
   end if;

   Report.Result;

end CB20001;