1-- C940016.A
2--
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--
26-- TEST OBJECTIVE:
27--      Check that an Unchecked_Deallocation of a protected object
28--      performs the required finalization on the protected object.
29--
30-- TEST DESCRIPTION:
31--      Test that finalization takes place when an Unchecked_Deallocation
32--      deallocates a protected object with queued callers.
33--      Try protected objects that have no other finalization code and
34--      protected objects with user defined finalization.
35--
36--
37-- CHANGE HISTORY:
38--      16 Jan 96   SAIC    ACVC 2.1
39--      10 Jul 96   SAIC    Fixed race condition noted by reviewers.
40--
41--!
42
43
44with Ada.Finalization;
45package C940016_0 is
46    Verbose : constant Boolean := False;
47    Finalization_Occurred : Boolean := False;
48
49    type Has_Finalization is new Ada.Finalization.Limited_Controlled with
50          record
51             Placeholder : Integer;
52          end record;
53    procedure Finalize (Object : in out Has_Finalization);
54end C940016_0;
55
56
57with Report;
58with ImpDef;
59package body C940016_0 is
60    procedure Finalize (Object : in out Has_Finalization) is
61    begin
62	delay ImpDef.Clear_Ready_Queue;
63        Finalization_Occurred := True;
64        if Verbose then
65            Report.Comment ("in Finalize");
66        end if;
67    end Finalize;
68end C940016_0;
69
70
71
72with Report;
73with Ada.Finalization;
74with C940016_0;
75with Ada.Unchecked_Deallocation;
76with ImpDef;
77
78procedure C940016 is
79   Verbose : constant Boolean := C940016_0.Verbose;
80
81begin
82
83   Report.Test ("C940016", "Check that Unchecked_Deallocation of a" &
84                           " protected object finalizes the" &
85                           " protected object");
86
87   First_Check: declare
88       protected type Semaphore is
89           entry Wait;
90           procedure Signal;
91       private
92           Count : Integer := 0;
93       end Semaphore;
94       protected body Semaphore is
95           entry Wait when Count > 0 is
96           begin
97               Count := Count - 1;
98           end Wait;
99
100           procedure Signal is
101           begin
102              Count := Count + 1;
103           end Signal;
104       end Semaphore;
105
106       type pSem is access Semaphore;
107       procedure Zap_Semaphore is new
108           Ada.Unchecked_Deallocation (Semaphore, pSem);
109       Sem_Ptr : pSem := new Semaphore;
110
111       -- positive confirmation that Blocker got the exception
112       Ok : Boolean := False;
113
114       task Blocker;
115
116       task body Blocker is
117       begin
118           Sem_Ptr.Wait;
119           Report.Failed ("Program_Error not raised in waiting task");
120       exception
121           when Program_Error =>
122               Ok := True;
123               if Verbose then
124                   Report.Comment ("Blocker received Program_Error");
125               end if;
126           when others =>
127               Report.Failed ("Wrong exception in Blocker");
128       end Blocker;
129
130   begin  -- First_Check
131       -- wait for Blocker to get blocked on the semaphore
132       delay ImpDef.Clear_Ready_Queue;
133       Zap_Semaphore (Sem_Ptr);
134       -- make sure Blocker has time to complete
135       delay ImpDef.Clear_Ready_Queue * 2;
136       if not Ok then
137           Report.Failed ("finalization not properly performed");
138           -- Blocker is probably hung so kill it
139           abort Blocker;
140       end if;
141   end First_Check;
142
143
144   Second_Check : declare
145      -- here we want to check that the raising of Program_Error
146      -- occurs before the other finalization actions.
147       protected type Semaphore is
148           entry Wait;
149           procedure Signal;
150       private
151           Count : Integer := 0;
152           Component : C940016_0.Has_Finalization;
153       end Semaphore;
154       protected body Semaphore is
155           entry Wait when Count > 0 is
156           begin
157               Count := Count - 1;
158           end Wait;
159
160           procedure Signal is
161           begin
162              Count := Count + 1;
163           end Signal;
164       end Semaphore;
165
166       type pSem is access Semaphore;
167       procedure Zap_Semaphore is new
168           Ada.Unchecked_Deallocation (Semaphore, pSem);
169       Sem_Ptr : pSem := new Semaphore;
170
171       -- positive confirmation that Blocker got the exception
172       Ok : Boolean := False;
173
174       task Blocker;
175
176       task body Blocker is
177       begin
178           Sem_Ptr.Wait;
179           Report.Failed ("Program_Error not raised in waiting task 2");
180       exception
181           when Program_Error =>
182               Ok := True;
183               if C940016_0.Finalization_Occurred then
184                   Report.Failed ("wrong order for finalization 2");
185               elsif Verbose then
186                   Report.Comment ("Blocker received Program_Error 2");
187               end if;
188           when others =>
189               Report.Failed ("Wrong exception in Blocker 2");
190       end Blocker;
191
192   begin  -- Second_Check
193       -- wait for Blocker to get blocked on the semaphore
194       delay ImpDef.Clear_Ready_Queue;
195       Zap_Semaphore (Sem_Ptr);
196       -- make sure Blocker has time to complete
197       delay ImpDef.Clear_Ready_Queue * 2;
198       if not Ok then
199           Report.Failed ("finalization not properly performed 2");
200           -- Blocker is probably hung so kill it
201           abort Blocker;
202       end if;
203       if not C940016_0.Finalization_Occurred then
204           Report.Failed ("user defined finalization didn't happen");
205       end if;
206   end Second_Check;
207
208
209   Report.Result;
210
211end C940016;
212