1-- 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
68package 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
90private
91   type SampleType_F is abstract tagged record
92      Era : Eras := Mesozoic;
93   end record;
94
95end C432004_0;
96
97     --==================================================================--
98
99package 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
107end C432004_0;
108
109     --==================================================================--
110
111with C432004_0;
112package 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
144private
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
153end C432004_1;
154
155     --==================================================================--
156
157package 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
173end C432004_1;
174
175     --==================================================================--
176
177with C432004_0;
178with C432004_1;
179package 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
199end C432004_2;
200
201
202     --==================================================================--
203
204with Report;
205with C432004_0;
206with C432004_1;
207with C432004_2;
208use  C432004_1;
209use  C432004_2;
210
211procedure 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
253begin
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
319end C432004;
320