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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C432004.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 type of an extension aggregate may be derived from the
28
--      type of the ancestor part through multiple record extensions. Check
29
--      for ancestor parts that are subtype marks. Check that the type of the
30
--      ancestor part may be abstract.
31
--
32
-- TEST DESCRIPTION:
33
--      This test defines the following type hierarchies:
34
--
35
--                (A)                           (F)
36
--              Abstract                      Abstract
37
--           Tagged record                 Tagged private
38
--            /         \                   /          \
39
--           /          (C)               (G)           \
40
--         (B)        Abstract         Abstract         (H)
41
--       Record       private          record         Private
42
--      extension     extension        extension     extension
43
--          |             |                |             |
44
--         (D)           (E)              (I)           (J)
45
--       Record        Record           Record        Record
46
--      extension     extension        extension     extension
47
--
48
--      Extension aggregates for B, D, E, I, and J are constructed using each
49
--      of its ancestor types as the ancestor part (except for E and J, for
50
--      which only the immediate ancestor is used, since using A and F,
51
--      respectively, as the ancestor part would be illegal).
52
--
53
--      X1 : B := (A with ...);
54
--      X2 : D := (A with ...);         X5 : I := (F with ...);
55
--      X3 : D := (B with ...);         X6 : I := (G with ...);
56
--      X4 : E := (C with ...);         X7 : J := (H with ...);
57
--
58
--      For each assignment of an aggregate, the value of the target object is
59
--      checked to ensure that the proper values for each component were
60
--      assigned.
61
--
62
--
63
-- CHANGE HISTORY:
64
--      06 Dec 94   SAIC    ACVC 2.0
65
--
66
--!
67
 
68
package C432004_0 is
69
 
70
   type Drawers is record
71
      Building : natural;
72
   end record;
73
 
74
   type Location is access Drawers;
75
 
76
   type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic);
77
 
78
   type SampleType_A is abstract tagged record
79
      Era : Eras := Cenozoic;
80
      Loc : Location;
81
   end record;
82
 
83
   type SampleType_F is abstract tagged private;
84
 
85
   -- The following function is needed to verify the values of the
86
   -- private components.
87
   function TC_Correct_Result (Rec : SampleType_F'Class;
88
                               E   : Eras) return Boolean;
89
 
90
private
91
   type SampleType_F is abstract tagged record
92
      Era : Eras := Mesozoic;
93
   end record;
94
 
95
end C432004_0;
96
 
97
     --==================================================================--
98
 
99
package body C432004_0 is
100
 
101
   function TC_Correct_Result (Rec : SampleType_F'Class;
102
                               E   : Eras) return Boolean is
103
   begin
104
      return (Rec.Era = E);
105
   end TC_Correct_Result;
106
 
107
end C432004_0;
108
 
109
     --==================================================================--
110
 
111
with C432004_0;
112
package C432004_1 is
113
 
114
   type Periods is
115
      (Aphebian, Helikian, Hadrynian,
116
       Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,
117
       Triassic, Jurassic, Cretaceous,
118
       Tertiary, Quaternary);
119
 
120
   type SampleType_B is new C432004_0.SampleType_A with record
121
      Period : Periods := Quaternary;
122
   end record;
123
 
124
   type SampleType_C is abstract new C432004_0.SampleType_A with private;
125
 
126
   -- The following function is needed to verify the values of the
127
   -- extension's private components.
128
   function TC_Correct_Result (Rec : SampleType_C'Class;
129
                               P   : Periods) return Boolean;
130
 
131
   type SampleType_G is abstract new C432004_0.SampleType_F with record
132
      Period : Periods := Jurassic;
133
      Loc    : C432004_0.Location;
134
   end record;
135
 
136
   type SampleType_H is new C432004_0.SampleType_F with private;
137
 
138
   -- The following function is needed to verify the values of the
139
   -- extension's private components.
140
   function TC_Correct_Result (Rec : SampleType_H'Class;
141
                               P   : Periods;
142
                               E   : C432004_0.Eras) return Boolean;
143
 
144
private
145
   type SampleType_C is abstract new C432004_0.SampleType_A with record
146
      Period : Periods := Quaternary;
147
   end record;
148
 
149
   type SampleType_H is new C432004_0.SampleType_F with record
150
      Period : Periods := Jurassic;
151
   end record;
152
 
153
end C432004_1;
154
 
155
     --==================================================================--
156
 
157
package body C432004_1 is
158
 
159
   function TC_Correct_Result (Rec : SampleType_C'Class;
160
                               P   : Periods) return Boolean is
161
   begin
162
      return (Rec.Period = P);
163
   end TC_Correct_Result;
164
 
165
   -------------------------------------------------------------
166
   function TC_Correct_Result (Rec : SampleType_H'Class;
167
                               P   : Periods;
168
                               E   : C432004_0.Eras) return Boolean is
169
   begin
170
      return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E);
171
   end TC_Correct_Result;
172
 
173
end C432004_1;
174
 
175
     --==================================================================--
176
 
177
with C432004_0;
178
with C432004_1;
179
package C432004_2 is
180
 
181
   -- All types herein are record extensions, since aggregates
182
   -- cannot be given for private extensions
183
 
184
   type SampleType_D is new C432004_1.SampleType_B with record
185
      Sample_On_Loan : Boolean := False;
186
   end record;
187
 
188
   type SampleType_E is new C432004_1.SampleType_C
189
     with null record;
190
 
191
   type SampleType_I is new C432004_1.SampleType_G with record
192
      Sample_On_Loan : Boolean := True;
193
   end record;
194
 
195
   type SampleType_J is new C432004_1.SampleType_H with record
196
      Sample_On_Loan : Boolean := True;
197
   end record;
198
 
199
end C432004_2;
200
 
201
 
202
     --==================================================================--
203
 
204
with Report;
205
with C432004_0;
206
with C432004_1;
207
with C432004_2;
208
use  C432004_1;
209
use  C432004_2;
210
 
211
procedure C432004 is
212
 
213
   -- Variety of extension aggregates.
214
 
215
   -- Default values for the components of SampleType_A
216
   -- (Era => Cenozoic, Loc => null).
217
   Sample_B  :  SampleType_B
218
             := (C432004_0.SampleType_A with Period => Devonian);
219
 
220
   -- Default values from SampleType_A (Era => Cenozoic, Loc => null).
221
   Sample_D1 :  SampleType_D
222
             := (C432004_0.SampleType_A with Period => Cambrian,
223
                                     Sample_On_Loan => True);
224
 
225
   -- Default values from SampleType_A and SampleType_B
226
   -- (Era => Cenozoic, Loc => null, Period => Quaternary).
227
   Sample_D2 :  SampleType_D
228
             := (SampleType_B with Sample_On_Loan => True);
229
 
230
   -- Default values from SampleType_A and SampleType_C
231
   -- (Era => Cenozoic, Loc => null, Period => Quaternary).
232
   Sample_E  :  SampleType_E
233
             := (SampleType_C with null record);
234
 
235
   -- Default value from SampleType_F (Era => Mesozoic).
236
   Sample_I1 :  SampleType_I
237
             := (C432004_0.SampleType_F with Period => Tertiary,
238
                 Loc => new C432004_0.Drawers'(Building => 9),
239
                 Sample_On_Loan => False);
240
 
241
   -- Default values from SampleType_F and SampleType_G
242
   -- (Era => Mesozoic, Period => Jurassic, Loc => null).
243
   Sample_I2 :  SampleType_I
244
             := (SampleType_G with Sample_On_Loan => False);
245
 
246
   -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic).
247
   Sample_J  :  SampleType_J
248
             := (SampleType_H with Sample_On_Loan => False);
249
 
250
   use type C432004_0.Eras;
251
   use type C432004_0.Location;
252
 
253
begin
254
 
255
   Report.Test ("C432004", "Check that the type of an extension aggregate "  &
256
                "may be derived from the type of the ancestor part through " &
257
                "multiple record extensions");
258
 
259
   if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then
260
      Report.Failed ("Object of record extension of abstract ancestor, " &
261
                     "SampleType_B, failed content check");
262
   end if;
263
 
264
   -------------------
265
   if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null,
266
                    Period => Cambrian, Sample_On_Loan => True) then
267
      Report.Failed ("Object 1 of record extension of record extension, "  &
268
                     "of abstract ancestor, SampleType_D, failed content " &
269
                     "check");
270
   end if;
271
 
272
   -------------------
273
   if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then
274
      Report.Failed ("Object 2 of record extension of record extension, "  &
275
                     "of abstract ancestor, SampleType_D, failed content " &
276
                     "check");
277
   end if;
278
   -------------------
279
   if Sample_E.Era /= C432004_0.Cenozoic or
280
      Sample_E.Loc /= null               or
281
      not TC_Correct_Result (Sample_E, Quaternary) then
282
         Report.Failed ("Object of record extension of abstract private " &
283
                        "extension of abstract ancestor, SampleType_E, "  &
284
                        "failed content check");
285
   end if;
286
 
287
   -------------------
288
   if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or
289
     Sample_I1.Period         /= Tertiary                             or
290
     Sample_I1.Loc.Building   /= 9                                    or
291
     Sample_I1.Sample_On_Loan /= False                                then
292
       Report.Failed ("Object 1 of record extension of abstract record " &
293
                      "extension of abstract private ancestor, "         &
294
                      "SampleType_I, failed content check");
295
   end if;
296
 
297
   -------------------
298
   if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or
299
     Sample_I2.Period         /= Jurassic                             or
300
     Sample_I2.Loc            /= null                                 or
301
     Sample_I2.Sample_On_Loan /= False                                then
302
       Report.Failed ("Object 2 of record extension of abstract record " &
303
                      "extension of abstract private ancestor, "         &
304
                      "SampleType_I, failed content check");
305
   end if;
306
 
307
   -------------------
308
   if not TC_Correct_Result (Sample_J,
309
                             Jurassic,
310
                             C432004_0.Mesozoic) or
311
     Sample_J.Sample_On_Loan /= False            then
312
        Report.Failed ("Object of record extension of private extension " &
313
                       "of abstract private ancestor, SampleType_J, "     &
314
                       "failed content check");
315
   end if;
316
 
317
   Report.Result;
318
 
319
end C432004;

powered by: WebSVN 2.1.0

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