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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cb/] [cb20003.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- CB20003.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 can be raised, reraised, and handled in an
28
--      accessed subprogram.
29
--
30
--
31
-- TEST DESCRIPTION:
32
--      Declare a record type, with one component being an access to
33
--      subprogram type.  Various subprograms are defined to fit the profile
34
--      of this access type, such that the record component can refer to
35
--      any of the subprograms.
36
--
37
--      Each of the subprograms raises a different exception, based on the
38
--      value of an input parameter.  Exceptions are 1) raised, handled with
39
--      an others handler, reraised and propagated to main to be handled in
40
--      a specific handler; 2) raised, handled in a specific handler, reraised
41
--      and propagated to the main to be handled in an others handler there,
42
--      and 3) raised and propagated directly to the caller by the subprogram.
43
--
44
--      Boolean variables are set throughout the test to ensure that correct
45
--      exception processing has occurred, and these variables are verified at
46
--      the conclusion of the test.
47
--
48
--
49
-- CHANGE HISTORY:
50
--      06 Dec 94   SAIC    ACVC 2.0
51
--
52
--!
53
 
54
package CB20003_0 is                          -- package Push_Buttons
55
 
56
 
57
   Non_Default_Priority,
58
   Non_Alert_Priority,
59
   Non_Emergency_Priority : exception;
60
 
61
   Handled_With_Others,
62
   Reraised_In_Subprogram,
63
   Handled_In_Caller      : Boolean := False;
64
 
65
   subtype Priority_Type is Integer range 1 .. 10;
66
 
67
   Default_Priority   : Priority_Type := 1;
68
   Alert_Priority     : Priority_Type := 3;
69
   Emergency_Priority : Priority_Type := 5;
70
 
71
 
72
   type Button is tagged private;                  -- Private tagged type.
73
 
74
   type Button_Response_Ptr is access procedure (P : in     Priority_Type;
75
                                                 B : in out Button);
76
 
77
 
78
   -- Procedures accessible with Button_Response_Ptr type.
79
 
80
   procedure Default_Response   (P : in     Priority_Type;
81
                                 B : in out Button);
82
 
83
   procedure Alert_Response     (P : in     Priority_Type;
84
                                 B : in out Button);
85
 
86
   procedure Emergency_Response (P : in     Priority_Type;
87
                                 B : in out Button);
88
 
89
 
90
 
91
   procedure Push (B : in out Button;
92
                   P : in     Priority_Type);
93
 
94
   procedure Set_Response (B : in out Button;
95
                           R : in     Button_Response_Ptr);
96
 
97
private
98
 
99
   type Button is tagged
100
      record
101
         Priority :  Priority_Type       := Default_Priority;
102
         Response :  Button_Response_Ptr := Default_Response'Access;
103
      end record;
104
 
105
 
106
end CB20003_0;                                -- package Push_Buttons
107
 
108
 
109
     --=================================================================--
110
 
111
 
112
with Report;
113
 
114
package body CB20003_0 is                     -- package Push_Buttons
115
 
116
 
117
   procedure Push (B : in out Button;
118
                   P : in     Priority_Type) is
119
   begin                                  -- Invoking subprogram designated
120
      B.Response (P, B);                  -- by access value.
121
   end Push;
122
 
123
 
124
   procedure Set_Response (B : in out Button;
125
                           R : in     Button_Response_Ptr) is
126
   begin
127
      B.Response := R;      -- Set procedure value in record
128
   end Set_Response;
129
 
130
 
131
   procedure Default_Response (P : in     Priority_Type;
132
                               B : in out Button) is
133
   begin
134
      if (P > Default_Priority) then
135
         raise Non_Default_Priority;
136
         Report.Failed ("Exception not raised in procedure body");
137
      else
138
         B.Priority := P;
139
      end if;
140
   exception
141
      when others =>                    -- Catch exception with others handler
142
         Handled_With_Others := True;   -- Successfully caught with "others"
143
         raise;
144
         Report.Failed ("Exception not reraised in handler");
145
   end Default_Response;
146
 
147
 
148
 
149
   procedure Alert_Response (P : in     Priority_Type;
150
                             B : in out Button) is
151
   begin
152
      if (P > Alert_Priority) then
153
         raise Non_Alert_Priority;
154
         Report.Failed ("Exception not raised in procedure body");
155
      else
156
         B.Priority := P;
157
      end if;
158
   exception
159
      when Non_Alert_Priority =>
160
         Reraised_In_Subprogram := True;
161
         raise;                                  -- Propagate to caller.
162
         Report.Failed ("Exception not reraised in procedure excpt handler");
163
      when others =>
164
         Report.Failed ("Incorrect exception raised/handled");
165
   end Alert_Response;
166
 
167
 
168
 
169
   procedure Emergency_Response (P : in     Priority_type;
170
                                 B : in out Button) is
171
   begin
172
      if (P > Emergency_Priority) then
173
         raise Non_Emergency_Priority;
174
         Report.Failed ("Exception not raised in procedure body");
175
      else
176
         B.Priority := P;
177
      end if;
178
      -- No exception handler here, exception will be propagated to caller.
179
   end Emergency_Response;
180
 
181
 
182
end CB20003_0;                                -- package Push_Buttons
183
 
184
 
185
     --=================================================================--
186
 
187
 
188
with Report;
189
with CB20003_0;                               -- package Push_Buttons
190
 
191
procedure CB20003 is
192
 
193
   package Push_Buttons renames CB20003_0;
194
 
195
   Console_Button : Push_Buttons.Button;
196
 
197
begin
198
 
199
   Report.Test ("CB20003", "Check that exceptions can be raised, "  &
200
                           "reraised, and handled in a subprogram " &
201
                           "referenced by an access to subprogram value");
202
 
203
 
204
   Default_Response_Processing:                 -- The exception
205
                                                -- Handled_With_Others is to
206
                                                -- be caught with an others
207
                                                -- handler in Default_Resp.,
208
                                                -- reraised, and handled with
209
                                                -- a specific handler here.
210
   begin
211
 
212
      Push_Buttons.Push (Console_Button,        -- Raise exception that will
213
                         Report.Ident_Int(2));  -- be handled in procedure.
214
   exception
215
      when Push_Buttons.Non_Default_Priority =>
216
         if not Push_Buttons.Handled_With_Others then   -- Not reraised in
217
                                                        -- procedure.
218
            Report.Failed
219
              ("Exception not handled/reraised in procedure");
220
         end if;
221
      when others =>
222
         Report.Failed ("Exception handled in " &
223
                        " Default_Response_Processing block");
224
   end Default_Response_Processing;
225
 
226
 
227
 
228
   Alert_Response_Processing:
229
   begin
230
 
231
      Push_Buttons.Set_Response (Console_Button,
232
                                 Push_Buttons.Alert_Response'access);
233
 
234
      Push_Buttons.Push (Console_Button,        -- Raise exception that will
235
                         Report.Ident_Int(4));  -- be handled in procedure,
236
                                                -- reraised, and propagated
237
                                                -- to caller.
238
      Report.Failed ("Exception not propagated to caller " &
239
                     "in Alert_Response_Processing block");
240
 
241
   exception
242
      when Push_Buttons.Non_Alert_Priority =>
243
         if not Push_Buttons.Reraised_In_Subprogram then  -- Not reraised in
244
                                                          -- procedure.
245
            Report.Failed ("Exception not reraised in procedure");
246
         end if;
247
      when others =>
248
         Report.Failed ("Exception handled in " &
249
                        " Alert_Response_Processing block");
250
   end Alert_Response_Processing;
251
 
252
 
253
 
254
   Emergency_Response_Processing:
255
   begin
256
 
257
      Push_Buttons.Set_Response (Console_Button,
258
                                 Push_Buttons.Emergency_Response'access);
259
 
260
      Push_Buttons.Push (Console_Button,        -- Raise exception that will
261
                         Report.Ident_Int(6));  -- be propagated directly to
262
                                                -- caller.
263
      Report.Failed ("Exception not propagated to caller " &
264
                     "in Emergency_Response_Processing block");
265
 
266
   exception
267
      when Push_Buttons.Non_Emergency_Priority =>
268
         Push_Buttons.Handled_In_Caller := True;
269
      when others =>
270
         Report.Failed ("Exception handled in " &
271
                        " Emergency_Response_Processing block");
272
   end Emergency_Response_Processing;
273
 
274
 
275
 
276
   if not (Push_Buttons.Handled_With_Others and
277
           Push_Buttons.Reraised_In_Subprogram and
278
           Push_Buttons.Handled_In_Caller )
279
   then
280
      Report.Failed ("Incorrect exception handling in referenced subprograms");
281
   end if;
282
 
283
 
284
   Report.Result;
285
 
286
end CB20003;

powered by: WebSVN 2.1.0

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