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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C954017.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
-- OBJECTIVE:
27
--      Check that when an exception is raised in the rendezvous of a task
28
--      that was called by a requeue the exception is propagated to the
29
--      original caller and that the requeuing task is unaffected.
30
--
31
-- TEST DESCRIPTION:
32
--      The Intermediate task requeues a call from the Original_Caller to the
33
--      Receiver.  While the Receiver is in the accept body for this
34
--      rendezvous a Constraint_Error exception is raised.  Check that the
35
--      exception is propagated to the Original_Caller, that the Receiver's
36
--      normal exception logic is employed and that the Intermediate task
37
--      is undisturbed.
38
--      There are several delay loops in this test any one of which could
39
--      cause it to hang (and thus fail).
40
--
41
--
42
-- CHANGE HISTORY:
43
--      06 Dec 94   SAIC    ACVC 2.0
44
--      25 Nov 95   SAIC    Fixed shared global variable problem for
45
--                          ACVC 2.0.1
46
--
47
--!
48
 
49
with Report;
50
with ImpDef;
51
 
52
 
53
procedure C954017 is
54
 
55
   TC_Original_Caller_Complete   : Boolean := false;
56
   TC_Intermediate_Complete      : Boolean := false;
57
   TC_Receiver_Complete          : Boolean := false;
58
   TC_Exception                  : Exception;
59
 
60
 
61
   protected type Shared_Boolean (Initial_Value : Boolean := False) is
62
      procedure Set_True;
63
      procedure Set_False;
64
      function  Value return Boolean;
65
   private
66
      Current_Value : Boolean := Initial_Value;
67
   end Shared_Boolean;
68
 
69
   protected body Shared_Boolean is
70
      procedure Set_True is
71
      begin
72
         Current_Value := True;
73
      end Set_True;
74
 
75
      procedure Set_False is
76
      begin
77
         Current_Value := False;
78
      end Set_False;
79
 
80
      function Value return Boolean is
81
      begin
82
         return Current_Value;
83
      end Value;
84
   end Shared_Boolean;
85
 
86
   TC_Exception_Process_Complete : Shared_Boolean (False);
87
 
88
   task Original_Caller is
89
      entry Start;
90
   end Original_Caller;
91
 
92
   task Intermediate is
93
      entry Input;
94
   end Intermediate;
95
 
96
   task Receiver is
97
      entry Input;
98
   end Receiver;
99
 
100
 
101
   task body Original_Caller is
102
   begin
103
      accept Start;    -- wait for the trigger from Main
104
 
105
      Intermediate.Input;
106
      Report.Failed ("Exception not propagated to Original_Caller");
107
 
108
   exception
109
      when TC_Exception =>
110
               TC_Original_Caller_Complete := true;     -- Expected behavior
111
      when others        =>
112
               Report.Failed ("Unexpected Exception in Original_Caller task");
113
   end Original_Caller;
114
 
115
 
116
   task body Intermediate is
117
   begin
118
      accept Input do
119
         -- Within this accept call another task
120
         requeue Receiver.Input with abort;
121
      end Input;
122
 
123
      -- Wait for Main to ensure that the exception housekeeping is finished
124
      while not TC_Exception_Process_Complete.Value loop
125
         delay ImpDef.Minimum_Task_Switch;
126
      end loop;
127
 
128
      TC_Intermediate_Complete := true;
129
 
130
   exception
131
      when others =>
132
                  Report.Failed ("Unexpected exception in Intermediate task");
133
   end Intermediate;
134
 
135
 
136
   task body Receiver is
137
   --
138
   begin
139
      accept Input do
140
         null;  -- the user code for the rendezvous is stubbed out
141
 
142
         -- Test Control: Raise an exception in the destination task which
143
         -- should then be propagated
144
         raise TC_Exception;
145
 
146
      end Input;
147
   exception
148
      when TC_Exception =>
149
            TC_Receiver_Complete := true;  -- expected behavior
150
      when others        =>
151
            Report.Failed ("Unexpected Exception in Receiver Task");
152
   end Receiver;
153
 
154
 
155
begin
156
 
157
   Report.Test ("C954017", "Requeue: exception processing");
158
 
159
   Original_Caller.Start;   -- Start the test after the Report.Test
160
 
161
   -- Wait for the whole of the exception process to complete
162
   while not ( Original_Caller'terminated and Receiver'terminated ) loop
163
      delay ImpDef.Minimum_Task_Switch;
164
   end loop;
165
 
166
   -- Inform the Intermediate task that the process is complete to allow
167
   -- it to continue to completion itself
168
   TC_Exception_Process_Complete.Set_True;
169
 
170
   -- Wait for everything to settle before reporting the result
171
   while not ( Intermediate'terminated ) loop
172
      delay ImpDef.Minimum_Task_Switch;
173
   end loop;
174
 
175
 
176
   if not ( TC_Original_Caller_Complete and
177
            TC_Intermediate_Complete    and
178
            TC_Receiver_Complete)       then
179
      Report.Failed ("Proper paths not traversed");
180
   end if;
181
 
182
   Report.Result;
183
 
184
end C954017;

powered by: WebSVN 2.1.0

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