c940016.a

来自「linux下编程用 编译软件」· A 代码 · 共 212 行

-- C940016.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.
--*
--
-- TEST OBJECTIVE:
--      Check that an Unchecked_Deallocation of a protected object
--      performs the required finalization on the protected object.
--
-- TEST DESCRIPTION:
--      Test that finalization takes place when an Unchecked_Deallocation
--      deallocates a protected object with queued callers. 
--      Try protected objects that have no other finalization code and
--      protected objects with user defined finalization.
--
--
-- CHANGE HISTORY:
--      16 Jan 96   SAIC    ACVC 2.1
--      10 Jul 96   SAIC    Fixed race condition noted by reviewers.
--
--!


with Ada.Finalization;
package C940016_0 is
    Verbose : constant Boolean := False;
    Finalization_Occurred : Boolean := False;

    type Has_Finalization is new Ada.Finalization.Limited_Controlled with
          record
             Placeholder : Integer;
          end record;
    procedure Finalize (Object : in out Has_Finalization);
end C940016_0;


with Report;
with ImpDef;
package body C940016_0 is
    procedure Finalize (Object : in out Has_Finalization) is
    begin
	delay ImpDef.Clear_Ready_Queue;
        Finalization_Occurred := True;
        if Verbose then
            Report.Comment ("in Finalize");
        end if;
    end Finalize;
end C940016_0;



with Report;
with Ada.Finalization;
with C940016_0;
with Ada.Unchecked_Deallocation;
with ImpDef;

procedure C940016 is
   Verbose : constant Boolean := C940016_0.Verbose;

begin
 
   Report.Test ("C940016", "Check that Unchecked_Deallocation of a" &
                           " protected object finalizes the" &
                           " protected object");

   First_Check: declare
       protected type Semaphore is
           entry Wait;
           procedure Signal;
       private
           Count : Integer := 0;
       end Semaphore;
       protected body Semaphore is
           entry Wait when Count > 0 is
           begin
               Count := Count - 1;
           end Wait;

           procedure Signal is
           begin
              Count := Count + 1;
           end Signal;
       end Semaphore;

       type pSem is access Semaphore;
       procedure Zap_Semaphore is new 
           Ada.Unchecked_Deallocation (Semaphore, pSem);
       Sem_Ptr : pSem := new Semaphore;

       -- positive confirmation that Blocker got the exception
       Ok : Boolean := False;

       task Blocker;

       task body Blocker is
       begin
           Sem_Ptr.Wait;
           Report.Failed ("Program_Error not raised in waiting task");
       exception
           when Program_Error =>
               Ok := True;
               if Verbose then
                   Report.Comment ("Blocker received Program_Error");
               end if;
           when others =>
               Report.Failed ("Wrong exception in Blocker");
       end Blocker;

   begin  -- First_Check
       -- wait for Blocker to get blocked on the semaphore
       delay ImpDef.Clear_Ready_Queue;
       Zap_Semaphore (Sem_Ptr);
       -- make sure Blocker has time to complete
       delay ImpDef.Clear_Ready_Queue * 2;
       if not Ok then
           Report.Failed ("finalization not properly performed");
           -- Blocker is probably hung so kill it
           abort Blocker;
       end if;
   end First_Check;
 

   Second_Check : declare
      -- here we want to check that the raising of Program_Error
      -- occurs before the other finalization actions.
       protected type Semaphore is
           entry Wait;
           procedure Signal;
       private
           Count : Integer := 0;
           Component : C940016_0.Has_Finalization;
       end Semaphore;
       protected body Semaphore is
           entry Wait when Count > 0 is
           begin
               Count := Count - 1;
           end Wait;

           procedure Signal is
           begin
              Count := Count + 1;
           end Signal;
       end Semaphore;

       type pSem is access Semaphore;
       procedure Zap_Semaphore is new 
           Ada.Unchecked_Deallocation (Semaphore, pSem);
       Sem_Ptr : pSem := new Semaphore;

       -- positive confirmation that Blocker got the exception
       Ok : Boolean := False;

       task Blocker;

       task body Blocker is
       begin
           Sem_Ptr.Wait;
           Report.Failed ("Program_Error not raised in waiting task 2");
       exception
           when Program_Error =>
               Ok := True;
               if C940016_0.Finalization_Occurred then
                   Report.Failed ("wrong order for finalization 2");
               elsif Verbose then
                   Report.Comment ("Blocker received Program_Error 2");
               end if;
           when others =>
               Report.Failed ("Wrong exception in Blocker 2");
       end Blocker;

   begin  -- Second_Check
       -- wait for Blocker to get blocked on the semaphore
       delay ImpDef.Clear_Ready_Queue;
       Zap_Semaphore (Sem_Ptr);
       -- make sure Blocker has time to complete
       delay ImpDef.Clear_Ready_Queue * 2;
       if not Ok then
           Report.Failed ("finalization not properly performed 2");
           -- Blocker is probably hung so kill it
           abort Blocker;
       end if;
       if not C940016_0.Finalization_Occurred then
           Report.Failed ("user defined finalization didn't happen");
       end if;
   end Second_Check;
 

   Report.Result;
 
end C940016;