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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C460006.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 view conversion to a tagged type is permitted in the
28
--      prefix of a selected component, an object renaming declaration, and
29
--      (if the operand is a variable) on the left side of an assignment
30
--      statement. Check that such a renaming or assignment does not change
31
--      the tag of the operand.
32
--
33
--      Check that, for a view conversion of a tagged type, each
34
--      nondiscriminant component of the new view denotes the matching
35
--      component of the operand object. Check that reading the value of the
36
--      view yields the result of converting the value of the operand object
37
--      to the target subtype.
38
--
39
-- TEST DESCRIPTION:
40
--      The fact that the tag of an object is not changed is verified by
41
--      making calls to primitive operations which in turn make (re)dispatching
42
--      calls, and confirming that the proper bodies are executed.
43
--
44
--      Selected components are checked in three contexts: as the object name
45
--      in an object renaming declaration, as the left operand of an inequality
46
--      operation, and as the left side of an assignment statement.
47
--
48
--      View conversions of an object of a 2nd level type extension are
49
--      renamed as objects of an ancestor type and of a class-wide type. In
50
--      one case the operand of the conversion is itself a renaming of an
51
--      object.
52
--
53
--      View conversions of an object of a 2nd level type extension are
54
--      checked for equality with record aggregates of various ancestor types.
55
--      In one case, the view conversion is to a class-wide type, and it is
56
--      checked for equality with the result of a class-wide function with
57
--      the following structure:
58
--
59
--         function F return T'Class is
60
--            A : DDT     := Expected_Value;
61
--            X : T'Class := T(A);
62
--         begin
63
--            return X;
64
--
65
--         end F;
66
--
67
--         ...
68
--
69
--         Var : DDT := Expected_Value;
70
--
71
--         if (T'Class(Var) /= F) then    -- Condition should yield FALSE.
72
--            FAIL;
73
--         end if;
74
--
75
--      The view conversion to which X is initialized does not affect the
76
--      value or tag of the operand; the tag of X is that of type DDT (not T),
77
--      and the components are those of A. The result of this function
78
--      should equal the value of an object of type DDT initialized to the
79
--      same value as F.A.
80
--
81
--      To check that assignment to a view conversion does not change the tag
82
--      of the operand, an assignment is made to a conversion of an object,
83
--      and the object is then passed as an actual to a dispatching operation.
84
--      Conversions to both specific and class-wide types are checked.
85
--
86
--
87
-- CHANGE HISTORY:
88
--      20 Jul 95   SAIC    Initial prerelease version.
89
--      24 Apr 96   SAIC    Added type conversions.
90
--
91
--!
92
 
93
package C460006_0 is
94
 
95
   type Call_ID_Kind is (None, Parent_Outer,     Parent_Inner,
96
                               Child_Outer,      Child_Inner,
97
                               Grandchild_Outer, Grandchild_Inner);
98
 
99
   type Root_Type is abstract tagged record
100
      First_Call  : Call_ID_Kind := None;
101
      Second_Call : Call_ID_Kind := None;
102
   end record;
103
 
104
   procedure Inner_Proc (X : in out Root_Type) is abstract;
105
   procedure Outer_Proc (X : in out Root_Type) is abstract;
106
 
107
end C460006_0;
108
 
109
 
110
     --==================================================================--
111
 
112
 
113
package C460006_0.C460006_1 is
114
 
115
   type Parent_Type is new Root_Type with record
116
      C1 : Integer := 0;
117
   end record;
118
 
119
   procedure Inner_Proc (X : in out Parent_Type);
120
   procedure Outer_Proc (X : in out Parent_Type);
121
 
122
end C460006_0.C460006_1;
123
 
124
 
125
     --==================================================================--
126
 
127
 
128
package body C460006_0.C460006_1 is
129
 
130
   procedure Inner_Proc (X : in out Parent_Type) is
131
   begin
132
      X.Second_Call := Parent_Inner;
133
   end Inner_Proc;
134
 
135
   -------------------------------------------------
136
   procedure Outer_Proc (X : in out Parent_Type) is
137
   begin
138
      X.First_Call := Parent_Outer;
139
      Inner_Proc ( Parent_Type'Class(X) );
140
   end Outer_Proc;
141
 
142
end C460006_0.C460006_1;
143
 
144
 
145
     --==================================================================--
146
 
147
 
148
package C460006_0.C460006_1.C460006_2 is
149
 
150
   type Child_Type is new Parent_Type with record
151
      C2 : String(1 .. 5) := "-----";
152
   end record;
153
 
154
   procedure Inner_Proc (X : in out Child_Type);
155
   procedure Outer_Proc (X : in out Child_Type);
156
 
157
end C460006_0.C460006_1.C460006_2;
158
 
159
 
160
     --==================================================================--
161
 
162
 
163
package body C460006_0.C460006_1.C460006_2 is
164
 
165
   procedure Inner_Proc (X : in out Child_Type) is
166
   begin
167
      X.Second_Call := Child_Inner;
168
   end Inner_Proc;
169
 
170
   -------------------------------------------------
171
   procedure Outer_Proc (X : in out Child_Type) is
172
   begin
173
      X.First_Call := Child_Outer;
174
      Inner_Proc ( Parent_Type'Class(X) );
175
   end Outer_Proc;
176
 
177
end C460006_0.C460006_1.C460006_2;
178
 
179
 
180
     --==================================================================--
181
 
182
 
183
package C460006_0.C460006_1.C460006_2.C460006_3 is
184
 
185
   type Grandchild_Type is new Child_Type with record
186
      C3: String(1 .. 5) := "-----";
187
   end record;
188
 
189
   procedure Inner_Proc (X : in out Grandchild_Type);
190
   procedure Outer_Proc (X : in out Grandchild_Type);
191
 
192
 
193
   function ClassWide_Func return Parent_Type'Class;
194
 
195
 
196
   Grandchild_Value : constant Grandchild_Type := (First_Call  => None,
197
                                                   Second_Call => None,
198
                                                   C1          => 15,
199
                                                   C2          => "Hello",
200
                                                   C3          => "World");
201
 
202
end C460006_0.C460006_1.C460006_2.C460006_3;
203
 
204
 
205
     --==================================================================--
206
 
207
 
208
package body C460006_0.C460006_1.C460006_2.C460006_3 is
209
 
210
   procedure Inner_Proc (X : in out Grandchild_Type) is
211
   begin
212
      X.Second_Call := Grandchild_Inner;
213
   end Inner_Proc;
214
 
215
   -------------------------------------------------
216
   procedure Outer_Proc (X : in out Grandchild_Type) is
217
   begin
218
      X.First_Call := Grandchild_Outer;
219
      Inner_Proc ( Parent_Type'Class(X) );
220
   end Outer_Proc;
221
 
222
   -------------------------------------------------
223
   function ClassWide_Func return Parent_Type'Class is
224
      A : Grandchild_Type   := Grandchild_Value;
225
      X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A.
226
   begin
227
      return X;
228
   end ClassWide_Func;
229
 
230
end C460006_0.C460006_1.C460006_2.C460006_3;
231
 
232
 
233
     --==================================================================--
234
 
235
 
236
with C460006_0.C460006_1.C460006_2.C460006_3;
237
 
238
with Report;
239
procedure C460006 is
240
 
241
   package Root_Package       renames C460006_0;
242
   package Parent_Package     renames C460006_0.C460006_1;
243
   package Child_Package      renames C460006_0.C460006_1.C460006_2;
244
   package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3;
245
 
246
begin
247
   Report.Test ("C460006", "Check that a view conversion to a tagged type " &
248
                "is permitted in the prefix of a selected component, an "   &
249
                "object renaming declaration, and (if the operand is a "    &
250
                "variable) on the left side of an assignment statement.  "  &
251
                "Check that such a renaming or assignment does not change " &
252
                " the tag of the operand");
253
 
254
 
255
   --
256
   -- Check conversion as prefix of selected component:
257
   --
258
 
259
   Selected_Component_Subtest:
260
   declare
261
      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
262
 
263
      Var    : Grandchild_Type   := Grandchild_Value;
264
      CW_Var : Parent_Type'Class := Var;
265
 
266
      Ren    : Integer renames Parent_Type(Var).C1;
267
 
268
   begin
269
      if Ren /= 15 then
270
         Report.Failed ("Wrong value: selected component in renaming");
271
      end if;
272
 
273
      if Child_Type(Var).C2 /= "Hello" then
274
         Report.Failed ("Wrong value: selected component in IF");
275
      end if;
276
 
277
      Grandchild_Type(CW_Var).C3(2..4) := "eir";
278
      if CW_Var /= Parent_Type'Class
279
                   (Grandchild_Type'(None, None, 15, "Hello", "Weird"))
280
      then
281
         Report.Failed ("Wrong value: selected component in assignment");
282
      end if;
283
   end Selected_Component_Subtest;
284
 
285
 
286
   --
287
   -- Check conversion in object renaming:
288
   --
289
 
290
   Object_Renaming_Subtest:
291
   declare
292
      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
293
 
294
      Var : Grandchild_Type := Grandchild_Value;
295
      Ren1 : Parent_Type       renames Parent_Type(Var);
296
      Ren2 : Child_Type        renames Child_Type(Var);
297
      Ren3 : Parent_Type'Class renames Parent_Type'Class(Var);
298
      Ren4 : Parent_Type       renames Parent_Type(Ren2); -- Rename of rename.
299
   begin
300
      Outer_Proc (Ren1);
301
      if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then
302
         Report.Failed ("Value or tag not preserved by object renaming: Ren1");
303
      end if;
304
 
305
      Outer_Proc (Ren2);
306
      if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then
307
         Report.Failed ("Value or tag not preserved by object renaming: Ren2");
308
      end if;
309
 
310
      Outer_Proc (Ren3);
311
      if Ren3 /= Parent_Type'Class
312
                 (Grandchild_Type'(Grandchild_Outer,
313
                                   Grandchild_Inner,
314
                                   15,
315
                                   "Hello",
316
                                   "World"))
317
      then
318
         Report.Failed ("Value or tag not preserved by object renaming: Ren3");
319
      end if;
320
 
321
      Outer_Proc (Ren4);
322
      if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then
323
         Report.Failed ("Value or tag not preserved by object renaming: Ren4");
324
      end if;
325
   end Object_Renaming_Subtest;
326
 
327
 
328
   --
329
   -- Check reading view conversion, and conversion as left side of assignment:
330
   --
331
 
332
   View_Conversion_Subtest:
333
   declare
334
      use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
335
 
336
      Var : Grandchild_Type := Grandchild_Value;
337
      Specific  : Child_Type;
338
      ClassWide : Parent_Type'Class := Var;   -- Grandchild_Type tag.
339
   begin
340
      if Parent_Type(Var) /= (None, None, 15) then
341
         Report.Failed ("View has wrong value: #1");
342
      end if;
343
 
344
      if Child_Type(Var) /= (None, None, 15, "Hello") then
345
         Report.Failed ("View has wrong value: #2");
346
      end if;
347
 
348
      if Parent_Type'Class(Var) /= ClassWide_Func then
349
         Report.Failed ("Upward view conversion did not preserve " &
350
                        "extension's components");
351
      end if;
352
 
353
 
354
      Parent_Type(Specific) := (None, None, 26); -- Assign to view.
355
      Outer_Proc (Specific);                     -- Call dispatching op.
356
 
357
      if Specific /= (Child_Outer, Child_Inner, 26, "-----") then
358
         Report.Failed ("Value or tag not preserved by assignment: Specific");
359
      end if;
360
 
361
 
362
      Parent_Type(ClassWide) := (None, None, 44); -- Assign to view.
363
      Outer_Proc (ClassWide);                     -- Call dispatching op.
364
 
365
      if ClassWide /= Parent_Type'Class
366
                      (Grandchild_Type'(Grandchild_Outer,
367
                                        Grandchild_Inner,
368
                                        44,
369
                                        "Hello",
370
                                        "World"))
371
      then
372
         Report.Failed ("Value or tag not preserved by assignment: ClassWide");
373
      end if;
374
   end View_Conversion_Subtest;
375
 
376
   Report.Result;
377
 
378
end C460006;

powered by: WebSVN 2.1.0

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