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/] [cc/] [cc51007.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- CC51007.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 a generic formal derived tagged type is a private extension.
28
--      Specifically, check that, for a generic formal derived type whose
29
--      ancestor type has abstract primitive subprograms, neither the formal
30
--      derived type nor its descendants need be abstract. Check that objects
31
--      and components of the formal derived type and its nonabstract
32
--      descendants may be declared and allocated, as may nonabstract
33
--      functions returning these types, and that aggregates of nonabstract
34
--      descendants of the formal derived type are legal. Check that calls to
35
--      the abstract primitive subprograms of the ancestor dispatch to the
36
--      bodies corresponding to the tag of the actual parameters.
37
--
38
-- TEST DESCRIPTION:
39
--      Although the ancestor type is abstract and has abstract primitive
40
--      subprograms, these subprograms, when inherited by a formal nonabstract
41
--      derived type, are not abstract, since the formal derived type is a
42
--      nonabstract private extension.
43
--
44
--      Thus, derivatives of the formal derived type need not be abstract,
45
--      and both the formal derived type and its derivatives are considered
46
--      nonabstract types.
47
--
48
--      This test verifies that the restrictions placed on abstract types do
49
--      not apply to the formal derived type or its derivatives. Specifically,
50
--      objects of, components of, allocators of, and nonabstract functions
51
--      returning the formal derived type or its derivatives are legal. In
52
--      addition, the test verifies that a call within the instance to a
53
--      primitive subprogram of the (abstract) ancestor type dispatches to
54
--      the body corresponding to the tag of the actual parameter.
55
--
56
--
57
-- CHANGE HISTORY:
58
--      06 Dec 94   SAIC    ACVC 2.0
59
--      23 Dec 94   SAIC    Deleted illegal extension aggregate.  Corrected
60
--                          dispatching call. Editorial changes to commentary.
61
--      05 Nov 95   SAIC    ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
62
--                          to library level.
63
--      11 Aug 96   SAIC    ACVC 2.1: Added pragma Elaborate to context
64
--                          clauses of CC51007_1 and CC51007_4.
65
--
66
--!
67
 
68
package CC51007_0 is
69
 
70
   Max_Length : constant := 10;
71
   type Text is new String(1 .. Max_Length);
72
 
73
   type Alert is abstract tagged record              -- Root type of class
74
      Message : Text := (others => '*');             -- (abstract).
75
   end record;
76
 
77
   procedure Handle (A: in out Alert) is abstract;   -- Abstract dispatching
78
                                                     -- operation.
79
 
80
end CC51007_0;
81
 
82
-- No body for CC51007_0;
83
 
84
 
85
     --===================================================================--
86
 
87
 
88
with CC51007_0;
89
 
90
with Ada.Calendar;
91
pragma Elaborate (Ada.Calendar);
92
 
93
package CC51007_1 is
94
 
95
   type Low_Alert is new CC51007_0.Alert with record
96
      Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
97
   end record;
98
 
99
   procedure Handle (A: in out Low_Alert);           -- Overrides parent's
100
                                                     -- implementation.
101
   Low : Low_Alert;
102
 
103
end CC51007_1;
104
 
105
 
106
     --===================================================================--
107
 
108
 
109
package body CC51007_1 is
110
 
111
   procedure Handle (A: in out Low_Alert) is         -- Artificial for
112
   begin                                             -- testing.
113
      A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
114
      A.Message := "Low Alert!";
115
   end Handle;
116
 
117
end CC51007_1;
118
 
119
 
120
     --===================================================================--
121
 
122
 
123
with CC51007_1;
124
package CC51007_2 is
125
 
126
   type Person is (OOD, CO, CinC);
127
 
128
   type Medium_Alert is new CC51007_1.Low_Alert with record
129
      Action_Officer : Person := OOD;
130
   end record;
131
 
132
   procedure Handle (A: in out Medium_Alert);        -- Overrides parent's
133
                                                     -- implementation.
134
   Med : Medium_Alert;
135
 
136
end CC51007_2;
137
 
138
 
139
     --===================================================================--
140
 
141
 
142
with Ada.Calendar;
143
package body CC51007_2 is
144
 
145
   procedure Handle (A: in out Medium_Alert) is      -- Artificial for
146
   begin                                             -- testing.
147
      A.Action_Officer := CO;
148
      A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
149
      A.Message := "Med Alert!";
150
   end Handle;
151
 
152
end CC51007_2;
153
 
154
 
155
     --===================================================================--
156
 
157
 
158
with CC51007_0;
159
generic
160
   type Alert_Type is new CC51007_0.Alert with private;
161
   Initial_State : in Alert_Type;
162
package CC51007_3 is
163
 
164
   function Clear_Message (A: Alert_Type)                -- Function returning
165
     return Alert_Type;                                  -- formal type.
166
 
167
 
168
   Max_Note : Natural := 10;
169
   type Note is new String (1 .. Max_Note);
170
 
171
   type Extended_Alert is new Alert_Type with record
172
      Addendum : Note := (others => '*');
173
   end record;
174
 
175
   -- In instance, inherits version of Handle from
176
   -- actual corresponding to formal type.
177
 
178
   function Annotate_Alert (A: in Alert_Type'Class)      -- Function returning
179
     return Extended_Alert;                              -- derived type.
180
 
181
 
182
   Init_Ext_Alert : constant Extended_Alert     :=       -- Object declaration.
183
     (Initial_State with Addendum => "----------");      -- Aggregate.
184
 
185
 
186
   type Alert_Type_Ptr is access constant Alert_Type;
187
   type Ext_Alert_Ptr  is access          Extended_Alert;
188
 
189
   Init_Alert_Ptr     : Alert_Type_Ptr :=
190
     new Alert_Type'(Initial_State);                        -- Allocator.
191
 
192
   Init_Ext_Alert_Ptr : Ext_Alert_Ptr  :=
193
     new Extended_Alert'(Init_Ext_Alert);                -- Allocator.
194
 
195
 
196
   type Alert_Pair is record
197
      A  : Alert_Type;                                   -- Component.
198
      EA : Extended_Alert;                               -- Component.
199
   end record;
200
 
201
end CC51007_3;
202
 
203
 
204
     --===================================================================--
205
 
206
 
207
package body CC51007_3 is
208
 
209
   function Clear_Message (A: Alert_Type) return Alert_Type is
210
      Temp : Alert_Type := A;                       -- Object declaration.
211
   begin
212
      Temp.Message := (others => '-');
213
      return Temp;
214
   end Clear_Message;
215
 
216
   function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
217
      Temp : Alert_Type'Class := A;
218
   begin
219
      Handle (Temp);                                -- Dispatching call to
220
                                                    -- operation of ancestor.
221
      return (Alert_Type(Temp) with Addendum => "No comment");
222
   end Annotate_Alert;
223
 
224
end CC51007_3;
225
 
226
 
227
     --===================================================================--
228
 
229
 
230
with CC51007_1;
231
 
232
with CC51007_3;
233
pragma Elaborate (CC51007_3);
234
 
235
package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);
236
 
237
 
238
     --===================================================================--
239
 
240
 
241
with CC51007_1;
242
with CC51007_2;
243
with CC51007_3;
244
with CC51007_4;
245
 
246
with Ada.Calendar;
247
with Report;
248
procedure CC51007 is
249
 
250
   package Alert_Support renames CC51007_4;
251
 
252
   Ext : Alert_Support.Extended_Alert;
253
 
254
   TC_Result       : Alert_Support.Extended_Alert;
255
 
256
   TC_Low_Expected : constant Alert_Support.Extended_Alert :=
257
                       (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
258
                        Message         => "Low Alert!",
259
                        Addendum        => "No comment");
260
 
261
   TC_Med_Expected : constant Alert_Support.Extended_Alert :=
262
                       (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
263
                        Message         => "Med Alert!",
264
                        Addendum        => "No comment");
265
 
266
   TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;
267
 
268
 
269
   use type Alert_Support.Extended_Alert;
270
 
271
begin
272
   Report.Test ("CC51007", "Check that, for a generic formal derived type "  &
273
                "whose ancestor type has abstract primitive subprograms, "   &
274
                "neither the formal derived type nor its descendants need "  &
275
                "be abstract, and that objects of, components of, "          &
276
                "allocators of, aggregates of, and nonabstract functions "   &
277
                "returning these types are legal. Check that calls to the "  &
278
                "abstract primitive subprograms of the ancestor dispatch "   &
279
                "to the bodies corresponding to the tag of the actual "      &
280
                "parameters");
281
 
282
 
283
   TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low);  -- Dispatching
284
                                                               -- call.
285
   if TC_Result /= TC_Low_Expected then
286
      Report.Failed ("Wrong results from dispatching call (Low_Alert)");
287
   end if;
288
 
289
 
290
   TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med);  -- Dispatching
291
                                                               -- call.
292
   if TC_Result /= TC_Med_Expected then
293
      Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
294
   end if;
295
 
296
 
297
   TC_Result := Alert_Support.Annotate_Alert (Ext);   -- Results in dispatching
298
                                                      -- call.
299
   if TC_Result /= TC_Ext_Expected then
300
      Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
301
   end if;
302
 
303
 
304
   Report.Result;
305
end CC51007;

powered by: WebSVN 2.1.0

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