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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CB40005.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 exceptions raised in non-generic code can be handled by
28
--      a procedure in a generic package.  Check that the exception identity
29
--      can be properly retrieved from the generic code and used by the
30
--      non-generic code.
31
--
32
-- TEST DESCRIPTION:
33
--      This test models a possible usage paradigm for the type:
34
--        Ada.Exceptions.Exception_Occurrence.
35
--
36
--      A generic package takes access to procedure types (allowing it to
37
--      be used at any accessibility level) and defines a "fail soft"
38
--      procedure that takes designators to a procedure to call, a
39
--      procedure to call in the event that it fails, and a function to
40
--      call to determine the next action.
41
--
42
--      In the event an exception occurs on the call to the first procedure,
43
--      the exception is stored in a stack; along with the designator to the
44
--      procedure that caused it; allowing the procedure to be called again,
45
--      or the exception to be re-raised.
46
--
47
--      A full implementation of such a tool would use a more robust storage
48
--      mechanism, and would provide a more flexible interface.
49
--
50
--
51
-- CHANGE HISTORY:
52
--      29 MAR 96   SAIC   Initial version
53
--      12 NOV 96   SAIC   Revised for 2.1 release
54
--
55
--!
56
 
57
----------------------------------------------------------------- CB40005_0
58
 
59
with Ada.Exceptions;
60
generic
61
  type Proc_Pointer is access procedure;
62
  type Func_Pointer is access function return Proc_Pointer;
63
package CB40005_0 is -- Fail_Soft
64
 
65
 
66
  procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
67
                            Proc_To_Call_On_Exception : Proc_Pointer := null;
68
                            Retry_Routine : Func_Pointer := null );
69
 
70
  function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence;
71
 
72
  function Top_Event_Procedure return Proc_Pointer;
73
 
74
  procedure Pop_Event;
75
 
76
  function Event_Stack_Size return Natural;
77
 
78
end CB40005_0; -- Fail_Soft
79
 
80
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0
81
 
82
with Report;
83
package body CB40005_0 is
84
 
85
  type History_Event is record
86
    Exception_Event  : Ada.Exceptions.Exception_Occurrence_Access;
87
    Procedure_Called : Proc_Pointer;
88
  end record;
89
 
90
  procedure Store_Event( Proc_Called : Proc_Pointer;
91
                         Error       : Ada.Exceptions.Exception_Occurrence );
92
 
93
  procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
94
                            Proc_To_Call_On_Exception : Proc_Pointer := null;
95
                            Retry_Routine : Func_Pointer := null ) is
96
 
97
    Current_Proc_To_Call : Proc_Pointer := Proc_To_Call;
98
 
99
  begin
100
    while Current_Proc_To_Call /= null loop
101
      begin
102
        Current_Proc_To_Call.all;  -- call procedure through pointer
103
        Current_Proc_To_Call := null;
104
      exception
105
        when Capture: others =>
106
          Store_Event( Current_Proc_To_Call, Capture );
107
          if Proc_To_Call_On_Exception /= null then
108
            Proc_To_Call_On_Exception.all;
109
          end if;
110
          if Retry_Routine /= null then
111
            Current_Proc_To_Call := Retry_Routine.all;
112
          else
113
            Current_Proc_To_Call := null;
114
          end if;
115
      end;
116
    end loop;
117
  end Fail_Soft_Call;
118
 
119
  Stack : array(1..10) of History_Event;  -- minimal, sufficient for testing
120
 
121
  Stack_Top : Natural := 0;
122
 
123
  procedure Store_Event( Proc_Called : Proc_Pointer;
124
                         Error       : Ada.Exceptions.Exception_Occurrence )
125
  is
126
  begin
127
    Stack_Top := Stack_Top +1;
128
    Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error),
129
                          Proc_Called );
130
  end Store_Event;
131
 
132
  function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is
133
  begin
134
    if Stack_Top > 0 then
135
      return Stack(Stack_Top).Exception_Event.all;
136
    else
137
      return Ada.Exceptions.Null_Occurrence;
138
    end if;
139
  end Top_Event_Exception;
140
 
141
  function Top_Event_Procedure return Proc_Pointer is
142
  begin
143
    if Stack_Top > 0 then
144
      return Stack(Stack_Top).Procedure_Called;
145
    else
146
      return null;
147
    end if;
148
  end Top_Event_Procedure;
149
 
150
  procedure Pop_Event is
151
  begin
152
    if Stack_Top > 0 then
153
      Stack_Top := Stack_Top -1;
154
    else
155
      Report.Failed("Stack Error");
156
    end if;
157
  end Pop_Event;
158
 
159
  function Event_Stack_Size return Natural is
160
  begin
161
    return Stack_Top;
162
  end Event_Stack_Size;
163
 
164
end CB40005_0;
165
 
166
------------------------------------------------------------------- CB40005
167
 
168
with Report;
169
with TCTouch;
170
with CB40005_0;
171
with Ada.Exceptions;
172
procedure CB40005 is
173
 
174
  type Proc_Pointer is access procedure;
175
  type Func_Pointer is access function return Proc_Pointer;
176
 
177
  package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer);
178
 
179
  procedure Cause_Standard_Exception;
180
 
181
  procedure Cause_Visible_Exception;
182
 
183
  procedure Cause_Invisible_Exception;
184
 
185
  Exception_Procedure_Pointer : Proc_Pointer;
186
 
187
  Visible_Exception : exception;
188
 
189
  procedure Action_On_Exception;
190
 
191
  function Retry_Procedure return Proc_Pointer;
192
 
193
  Raise_Error : Boolean;
194
 
195
  -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
196
 
197
  procedure Cause_Standard_Exception is
198
  begin
199
    TCTouch.Touch('S');  --------------------------------------------------- S
200
    if Raise_Error then
201
      raise Constraint_Error;
202
    end if;
203
  end Cause_Standard_Exception;
204
 
205
  procedure Cause_Visible_Exception is
206
  begin
207
    TCTouch.Touch('V');  --------------------------------------------------- V
208
    if Raise_Error then
209
      raise Visible_Exception;
210
    end if;
211
  end Cause_Visible_Exception;
212
 
213
  procedure Cause_Invisible_Exception is
214
    Invisible_Exception : exception;
215
  begin
216
    TCTouch.Touch('I');  --------------------------------------------------- I
217
    if Raise_Error then
218
      raise Invisible_Exception;
219
    end if;
220
  end Cause_Invisible_Exception;
221
 
222
  procedure Action_On_Exception is
223
  begin
224
    TCTouch.Touch('A');  --------------------------------------------------- A
225
  end Action_On_Exception;
226
 
227
  function Retry_Procedure return Proc_Pointer is
228
  begin
229
    TCTouch.Touch('R');  --------------------------------------------------- R
230
    return Action_On_Exception'Access;
231
  end Retry_Procedure;
232
 
233
         -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
234
 
235
begin  -- Main test procedure.
236
 
237
  Report.Test ("CB40005", "Check that exceptions raised in non-generic " &
238
                          "code can be handled by a procedure in a generic " &
239
                          "package.  Check that the exception identity can " &
240
                          "be properly retrieved from the generic code and " &
241
                          "used by the non-generic code" );
242
 
243
  -- first, check that the no exception cases cause no action on the stack
244
  Raise_Error := False;
245
 
246
  Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access );    -- S
247
 
248
  Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access,       -- V
249
                            Action_On_Exception'Access,
250
                            Retry_Procedure'Access );
251
 
252
  Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access,     -- I
253
                            null,
254
                            Retry_Procedure'Access );
255
 
256
  TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack");
257
 
258
  TCTouch.Validate( "SVI", "Non error case check" );
259
 
260
  -- second, check that error cases add to the stack
261
  Raise_Error := True;
262
 
263
  Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access );    -- S
264
 
265
  Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access,       -- V
266
                            Action_On_Exception'Access,           -- A
267
                            Retry_Procedure'Access );             -- RA
268
 
269
  Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access,     -- I
270
                            null,
271
                            Retry_Procedure'Access );             -- RA
272
 
273
  TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3");
274
 
275
  TCTouch.Validate( "SVARAIRA", "Error case check" );
276
 
277
  -- check that the exceptions and procedure were stored correctly
278
  -- on the stack
279
  Raise_Error := False;
280
 
281
  -- return procedure pointer from top of stack and call the procedure
282
  -- through that pointer:
283
 
284
  Fail_Soft.Top_Event_Procedure.all;
285
 
286
  TCTouch.Validate( "I", "Invisible case unwind" );
287
 
288
  begin
289
    Ada.Exceptions.Raise_Exception(
290
      Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
291
    Report.Failed("1: Exception not raised");
292
  exception
293
    when Constraint_Error  => Report.Failed("1: Raised Constraint_Error");
294
    when Visible_Exception => Report.Failed("1: Raised Visible_Exception");
295
    when others            => null; -- expected case
296
  end;
297
 
298
  Fail_Soft.Pop_Event;
299
 
300
  -- return procedure pointer from top of stack and call the procedure
301
  -- through that pointer:
302
 
303
  Fail_Soft.Top_Event_Procedure.all;
304
 
305
  TCTouch.Validate( "V", "Visible case unwind" );
306
 
307
  begin
308
    Ada.Exceptions.Raise_Exception(
309
      Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
310
    Report.Failed("2: Exception not raised");
311
  exception
312
    when Constraint_Error  => Report.Failed("2: Raised Constraint_Error");
313
    when Visible_Exception => null; -- expected case
314
    when others            => Report.Failed("2: Raised Invisible_Exception");
315
  end;
316
 
317
  Fail_Soft.Pop_Event;
318
 
319
  Fail_Soft.Top_Event_Procedure.all;
320
 
321
  TCTouch.Validate( "S", "Standard case unwind" );
322
 
323
  begin
324
    Ada.Exceptions.Raise_Exception(
325
      Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
326
    Report.Failed("3: Exception not raised");
327
  exception
328
    when Constraint_Error  => null; -- expected case
329
    when Visible_Exception => Report.Failed("3: Raised Visible_Exception");
330
    when others            => Report.Failed("3: Raised Invisible_Exception");
331
  end;
332
 
333
  Fail_Soft.Pop_Event;
334
 
335
  TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops");
336
 
337
  Report.Result;
338
 
339
end CB40005;

powered by: WebSVN 2.1.0

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