Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cc/cc51d02.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- CC51D02.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, in an instance, each implicit declaration of a user-defined
28 -- subprogram of a formal private extension declares a view of the
29 -- corresponding primitive subprogram of the ancestor, and that if the
30 -- tag in a call is statically determined to be that of the formal type,
31 -- the body executed will be that corresponding to the actual type.
32 --
33 -- Check subprograms declared within a generic formal package. Check for
34 -- the case where the actual type passed to the formal private extension
35 -- is a class-wide type. Check for several types in the same class.
36 --
37 --
38 -- TEST DESCRIPTION:
39 -- Declare a list abstraction in a generic package which manages lists of
40 -- elements of any nonlimited type (foundation code). Declare a package
41 -- which declares a tagged type and a derivative. Declare an operation
42 -- for the root tagged type and override it for the derivative. Declare
43 -- a generic subprogram which operates on lists of elements of tagged
44 -- types. Provide the generic subprogram with two formal parameters: (1)
45 -- a formal derived tagged type which represents a list element type, and
46 -- (2) a generic formal package with the list abstraction package as
47 -- template. Use the formal derived type as the generic formal actual
48 -- part for the formal package. Within the generic subprogram, call the
49 -- operation of the root tagged type. In the main program, instantiate
50 -- the generic list package and the generic subprogram with the class-wide
51 -- type for the root tagged type.
52 --
53 -- TEST FILES:
54 -- The following files comprise this test:
55 --
56 -- FC51D00.A
57 -- -> CC51D02.A
58 --
59 --
60 -- CHANGE HISTORY:
61 -- 06 Dec 94 SAIC ACVC 2.0
62 -- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2
63 -- from specific to class-wide. Eliminated (illegal)
64 -- assignment step prior to comparison of
65 -- TC_Expected_X with item on stack.
66 --
67 --!
68
69 package CC51D02_0 is -- This package simulates support for a personnel
70 -- database.
71
72 type SSN_Type is new String (1 .. 9);
73
74 type Blind_ID_Type is tagged record -- Root type of
75 SSN : SSN_Type; -- class.
76 -- ... Other components.
77 end record;
78
79 procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation.
80
81 -- ... Other operations.
82
83
84 type Name_Type is new String (1 .. 9);
85
86 type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative
87 Name : Name_Type := "Doe "; -- of root type.
88 -- ... Other components.
89 end record;
90
91 -- Inherits Update_ID from parent.
92
93 procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's
94 -- implementation.
95
96 end CC51D02_0;
97
98
99 --==================================================================--
100
101
102 package body CC51D02_0 is
103
104 -- The implementations of Update_ID are purely artificial; the validity of
105 -- their implementations in the context of the abstraction is irrelevant to
106 -- the feature being tested.
107
108 procedure Update_ID (Item : in out Blind_ID_Type) is
109 begin
110 Item.SSN := "111223333";
111 end Update_ID;
112
113
114 procedure Update_ID (Item : in out Named_ID_Type) is
115 begin
116 Item.SSN := "444556666";
117 -- ... Other stuff.
118 end Update_ID;
119
120 end CC51D02_0;
121
122
123 --==================================================================--
124
125
126 -- --
127 -- Formal package used here. --
128 -- --
129
130 with FC51D00; -- Generic list abstraction.
131 with CC51D02_0; -- Tagged type declarations.
132 generic -- This procedure simulates a generic operation for types
133 -- in the class rooted at Blind_ID_Type.
134 type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private;
135 with package List_Mgr is new FC51D00 (Elem_Type);
136 procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
137
138
139 --==================================================================--
140
141
142 -- The implementation of CC51D02_1 is purely artificial; the validity
143 -- of its implementation in the context of the abstraction is irrelevant
144 -- to the feature being tested.
145 --
146 -- The expected behavior here is as follows: for each actual type corresponding
147 -- to Elem_Type, the call to Update_ID should invoke the actual type's
148 -- implementation (based on the tag of the actual), which updates the object's
149 -- SSN field. Write_Element then adds the object to the list.
150
151 procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
152 Element : Elem_Type := E; -- Can't update IN parameter.
153 -- Initialization of unconstrained variable.
154 begin
155 Update_ID (Element); -- Executes actual type's version
156 -- (for this test, this will be a
157 -- dispatching call).
158 List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version
159 -- (for this test, this will be a
160 -- class-wide operation).
161 end CC51D02_1;
162
163
164 --==================================================================--
165
166
167 with FC51D00; -- Generic list abstraction.
168 with CC51D02_0; -- Tagged type declarations.
169 with CC51D02_1; -- Generic operation.
170
171 with Report;
172 procedure CC51D02 is
173
174 use CC51D02_0; -- All types & ops
175 -- directly visible.
176
177 -- Begin test code declarations: -----------------------
178
179 TC_Expected_1 : Blind_ID_Type'Class :=
180 Blind_ID_Type'(SSN => "111223333");
181 TC_Expected_2 : Blind_ID_Type'Class :=
182 Named_ID_Type'("444556666", "Doe ");
183
184
185 TC_Initial_1 : Blind_ID_Type := (SSN => "777889999");
186 TC_Initial_2 : Named_ID_Type := ("777889999", "Doe ");
187 TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2;
188
189 -- End test code declarations. -------------------------
190
191
192 package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class);
193
194 procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class,
195 ID_Class_Lists);
196
197 Blind_List : ID_Class_Lists.List_Type;
198 Named_List : ID_Class_Lists.List_Type;
199 Maimed_List : ID_Class_Lists.List_Type;
200
201
202 begin
203 Report.Test ("CC51D02", "Formal private extension, class-wide actual: " &
204 "body of primitive subprogram executed is that of actual " &
205 "type. Check for subprograms declared in formal package");
206
207
208 Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual.
209
210 if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then
211 Report.Failed ("Result for root type actual is not in proper class");
212 elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
213 Report.Failed ("Wrong result for root type actual");
214 end if;
215
216
217 Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual.
218
219 if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then
220 Report.Failed ("Result for derived type actual is not in proper class");
221 elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then
222 Report.Failed ("Wrong result for derived type actual");
223 end if;
224
225
226 -- In the subtest below, an object of a class-wide type (TC_Initial_3) is
227 -- passed to Update_and_Write. It has been initialized with an object of
228 -- type Named_ID_Type, so the result should be identical to
229 -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that
230 -- a new list of Named IDs is used (Maimed_List). This is to assure test
231 -- validity, since Named_List has already been updated by a previous
232 -- subtest.
233
234 Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual.
235
236 if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then
237 Report.Failed ("Result for class-wide actual is not in proper class");
238 elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then
239 Report.Failed ("Wrong result for class-wide actual");
240 end if;
241
242
243 Report.Result;
244 end CC51D02;