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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc54004.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- CC54004.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 the designated type of a generic formal pool-specific
28
--      access type may be class-wide. Check that calls to primitive
29
--      subprograms in the instance dispatch to the appropriate bodies when
30
--      the controlling operand is a dereference of an object of the access-
31
--      to-class-wide type.
32
--
33
-- TEST DESCRIPTION:
34
--      A hierarchy of types is declared in two packages. The root type of
35
--      the class is declared as abstract in a separate package. It possesses
36
--      an abstract primitive subprogram Handle. A concrete type extends the
37
--      root type in a second package with a component of an enumeration type.
38
--      A second type extends this extension in the same package. Both
39
--      derivatives override the root type's primitive subprogram with a
40
--      non-abstract subprogram.
41
--
42
--      The generic implements a heterogeneous stack of access-to-class-wide
43
--      objects in the root type's class. A subprogram declared in the
44
--      generic calls Handle using dereferences of each of the class-wide
45
--      objects on the stack as operand. Each call to Handle should dispatch
46
--      to the appropriate body based on the tag of the operand. The
47
--      overriding versions of Handle each set the component of the type to
48
--      a different value. The value of the component is checked to verify
49
--      that the calls dispatched correctly.
50
--
51
--
52
-- CHANGE HISTORY:
53
--      06 Dec 94   SAIC    ACVC 2.0
54
--      10 Apr 96   SAIC    ACVC 2.1: Added pragma Elaborate to context clause
55
--                          preceding CC54004_3.
56
--
57
--!
58
 
59
package CC54004_0 is
60
 
61
   -- The types and operations defined here are artificial. The component
62
   -- TC_Code is the only component required for testing purposes.
63
 
64
   type TC_Code_Type is (None, Low, Medium);
65
 
66
   type Alert is abstract tagged record              -- Abstract type.
67
      TC_Code : TC_Code_Type;    -- Testing flag.
68
   end record;
69
 
70
   procedure Handle (A : in out Alert);              -- Non-abstract primitive
71
                                                     -- subprogram.
72
   -- ...Other operations.
73
 
74
   type Alert_Ptr is access Alert'Class;             -- Access-to-class-wide
75
                                                     -- type.
76
end CC54004_0;
77
 
78
 
79
     --===================================================================--
80
 
81
 
82
package body CC54004_0 is
83
 
84
   procedure Handle (A : in out Alert) is
85
   begin
86
      A.TC_Code := None;
87
   end Handle;
88
 
89
end CC54004_0;
90
 
91
 
92
     --===================================================================--
93
 
94
 
95
with CC54004_0;
96
use  CC54004_0;
97
package CC54004_1 is
98
 
99
   type Low_Alert is new CC54004_0.Alert with record
100
      C1 : String (1 .. 5) := "Dummy";
101
      -- ...Other components.
102
   end record;
103
 
104
   procedure Handle (A : in out Low_Alert);          -- Overrides parent's
105
                                                     -- operations.
106
   --...Other operations.
107
 
108
 
109
   type Medium_Alert is new Low_Alert with record
110
      C : Integer := 6;
111
      -- ...Other components.
112
   end record;
113
 
114
   procedure Handle (A : in out Medium_Alert);       -- Overrides parent's
115
                                                     -- operations.
116
   --...Other operations.
117
 
118
end CC54004_1;
119
 
120
 
121
     --===================================================================--
122
 
123
package body CC54004_1 is
124
 
125
   procedure Handle (A : in out Low_Alert) is
126
   begin
127
      A.TC_Code := Low;
128
   end Handle;
129
 
130
   procedure Handle (A : in out Medium_Alert) is
131
   begin
132
      A.TC_Code := Medium;
133
   end Handle;
134
 
135
end CC54004_1;
136
 
137
 
138
     --===================================================================--
139
 
140
 
141
with CC54004_0;
142
generic
143
   type Element_Type is abstract new CC54004_0.Alert with private;
144
   type Element_Ptr  is access Element_Type'Class;
145
package CC54004_2 is
146
 
147
   type Stack_Type is private;
148
 
149
   procedure Push (Stack     : in out Stack_Type;
150
                   Elem_Ptr  : in     Element_Ptr);
151
 
152
   procedure Pop  (Stack     : in out Stack_Type;
153
                   Elem_Ptr  :    out Element_Ptr);
154
 
155
   procedure Process_Stack (Stack : in out Stack_Type);
156
 
157
   -- ... Other operations.
158
 
159
private
160
 
161
   subtype Index is Positive range 1 .. 5;
162
   type Stack_Type is array (Index) of Element_Ptr;
163
 
164
   Top : Index := 1;
165
 
166
end CC54004_2;
167
 
168
 
169
     --===================================================================--
170
 
171
 
172
package body CC54004_2 is
173
 
174
   procedure Push (Stack    : in out Stack_Type;
175
                   Elem_Ptr : in     Element_Ptr) is
176
   begin
177
      Stack(Top) := Elem_Ptr;
178
      Top := Top + 1;     -- Artificial: no Constraint_Error protection.
179
   end Push;
180
 
181
 
182
   procedure Pop  (Stack     : in out Stack_Type;
183
                   Elem_Ptr  :    out Element_Ptr)is
184
   begin
185
      Top := Top - 1;     -- Artificial: no Constraint_Error protection.
186
      Elem_Ptr := Stack(Top);
187
   end Pop;
188
 
189
 
190
   -- Call Handle for each element on the stack. Since the dereferenced access
191
   -- object is of a class-wide type, all calls to Handle are dispatching. The
192
   -- version of Handle called will be that declared for the type
193
   -- corresponding to the tag of the operand.
194
 
195
   procedure Process_Stack (Stack  : in out Stack_Type) is
196
   begin -- Artificial: no Constraint_Error protection.
197
      for I in reverse Index'First .. (Top - 1) loop
198
         Handle (Stack(I).all);            -- Call dispatches based on
199
      end loop;                            -- tag of operand.
200
   end Process_Stack;
201
 
202
end CC54004_2;
203
 
204
 
205
     --===================================================================--
206
 
207
 
208
with CC54004_0;
209
with CC54004_1;
210
with CC54004_2;
211
pragma Elaborate (CC54004_2);
212
 
213
package CC54004_3 is
214
 
215
   package Alert_Stacks is new CC54004_2 (Element_Type => CC54004_0.Alert,
216
                                          Element_Ptr  => CC54004_0.Alert_Ptr);
217
 
218
   -- All overriding versions of Handle visible at the point of instantiation.
219
 
220
   Alert_List  : Alert_Stacks.Stack_Type;
221
 
222
   procedure TC_Create_Alert_Stack;
223
 
224
end CC54004_3;
225
 
226
 
227
     --===================================================================--
228
 
229
 
230
package body CC54004_3 is
231
 
232
   procedure TC_Create_Alert_Stack is
233
   begin
234
      Alert_Stacks.Push (Alert_List, new CC54004_1.Low_Alert);
235
      Alert_Stacks.Push (Alert_List, new CC54004_1.Medium_Alert);
236
   end TC_Create_Alert_Stack;
237
 
238
end CC54004_3;
239
 
240
 
241
     --===================================================================--
242
 
243
 
244
with CC54004_0;
245
with CC54004_1;
246
with CC54004_3;
247
 
248
with Report;
249
procedure CC54004 is
250
   TC_Low_Ptr, TC_Med_Ptr : CC54004_0.Alert_Ptr;
251
   TC_Low_Actual          : CC54004_1.Low_Alert;
252
   TC_Med_Actual          : CC54004_1.Medium_Alert;
253
 
254
   use type CC54004_0.TC_Code_Type;
255
begin
256
   Report.Test ("CC54004", "Check that the designated type of a generic " &
257
                "formal pool-specific access type may be class-wide");
258
 
259
 
260
   -- Create stack of elements:
261
 
262
   CC54004_3.TC_Create_Alert_Stack;
263
 
264
 
265
   -- Commence dispatching operations on stack elements:
266
 
267
   CC54004_3.Alert_Stacks.Process_Stack (CC54004_3.Alert_List);
268
 
269
 
270
   -- Pop "handled" alerts off stack:
271
 
272
   CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Med_Ptr);
273
   CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Low_Ptr);
274
 
275
 
276
   -- Verify results:
277
 
278
   if TC_Low_Ptr.all not in CC54004_1.Low_Alert    or else
279
      TC_Med_Ptr.all not in CC54004_1.Medium_Alert
280
   then
281
      Report.Failed ("Class-wide objects do not have expected tags");
282
 
283
   -- The explicit dereference of the "Pop"ed pointers results in views of
284
   -- the designated objects, the nominal subtypes of which are class-wide.
285
   -- In order to be able to reference the component TC_Code, these views
286
   -- must be converted to a specific type possessing that component.
287
 
288
   elsif CC54004_1.Low_Alert(TC_Low_Ptr.all).TC_Code    /= CC54004_0.Low    or
289
         CC54004_1.Medium_Alert(TC_Med_Ptr.all).TC_Code /= CC54004_0.Medium
290
   then
291
      Report.Failed ("Calls did not dispatch to expected operations");
292
   end if;
293
 
294
   Report.Result;
295
end CC54004;

powered by: WebSVN 2.1.0

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