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