1-- 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
54package 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
97private
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
106end CB20003_0;                                -- package Push_Buttons
107
108
109     --=================================================================--
110
111
112with Report;
113
114package 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
182end CB20003_0;                                -- package Push_Buttons
183
184
185     --=================================================================--
186
187
188with Report;
189with CB20003_0;                               -- package Push_Buttons
190
191procedure CB20003 is
192
193   package Push_Buttons renames CB20003_0;
194
195   Console_Button : Push_Buttons.Button;
196
197begin
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
286end CB20003;
287