OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c9/] [c940016.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- 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
 
44
with Ada.Finalization;
45
package 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);
54
end C940016_0;
55
 
56
 
57
with Report;
58
with ImpDef;
59
package 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;
68
end C940016_0;
69
 
70
 
71
 
72
with Report;
73
with Ada.Finalization;
74
with C940016_0;
75
with Ada.Unchecked_Deallocation;
76
with ImpDef;
77
 
78
procedure C940016 is
79
   Verbose : constant Boolean := C940016_0.Verbose;
80
 
81
begin
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
 
211
end C940016;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.