Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cc/cc51d01.a @ 111:04ced10e8804
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 -- CC51D01.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 specific tagged 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 type derived from it. Declare an | |
42 -- operation for the root tagged type and override it for the derived | |
43 -- type. Derive a type from this derived type, but do not override the | |
44 -- operation. Declare a generic subprogram which operates on lists of | |
45 -- elements of tagged types. Provide the generic subprogram with two | |
46 -- formal parameters: (1) a formal derived tagged type which represents a | |
47 -- list element type, and (2) a generic formal package with the list | |
48 -- abstraction package as template. Use the formal derived type as the | |
49 -- generic formal actual part for the formal package. Within the generic | |
50 -- subprogram, call the operation of the root tagged type. In the main | |
51 -- program, instantiate the generic list package and the generic | |
52 -- subprogram with the root tagged type and each derivative, then call | |
53 -- each instance with an object of the appropriate type. | |
54 -- | |
55 -- TEST FILES: | |
56 -- The following files comprise this test: | |
57 -- | |
58 -- FC51D00.A | |
59 -- -> CC51D01.A | |
60 -- | |
61 -- | |
62 -- CHANGE HISTORY: | |
63 -- 06 Dec 94 SAIC ACVC 2.0 | |
64 -- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from | |
65 -- main subprogram to package CC51D01_0. Removed | |
66 -- case passing class-wide actual to instance. | |
67 -- Updated test description and modified comments. | |
68 -- | |
69 --! | |
70 | |
71 package CC51D01_0 is -- This package simulates support for a personnel | |
72 -- database. | |
73 | |
74 type SSN_Type is new String (1 .. 9); | |
75 | |
76 type Blind_ID_Type is tagged record -- Root type of | |
77 SSN : SSN_Type; -- class. | |
78 -- ... Other components. | |
79 end record; | |
80 | |
81 procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. | |
82 | |
83 -- ... Other operations. | |
84 | |
85 | |
86 type Name_Type is new String (1 .. 9); | |
87 | |
88 type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative | |
89 Name : Name_Type := "Doe "; -- of root type. | |
90 -- ... Other components. | |
91 end record; | |
92 | |
93 -- Inherits Update_ID from parent. | |
94 | |
95 procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's | |
96 -- implementation. | |
97 | |
98 | |
99 type Ranked_ID_Type is new Named_ID_Type with record | |
100 Level : Integer := 0; -- Indirect derivative | |
101 -- ... Other components. -- of root type. | |
102 end record; | |
103 | |
104 -- Inherits Update_ID from parent. | |
105 | |
106 end CC51D01_0; | |
107 | |
108 | |
109 --==================================================================-- | |
110 | |
111 | |
112 package body CC51D01_0 is | |
113 | |
114 -- The implementations of Update_ID are purely artificial; the validity of | |
115 -- their implementations in the context of the abstraction is irrelevant to | |
116 -- the feature being tested. | |
117 | |
118 procedure Update_ID (Item : in out Blind_ID_Type) is | |
119 begin | |
120 Item.SSN := "111223333"; | |
121 end Update_ID; | |
122 | |
123 | |
124 procedure Update_ID (Item : in out Named_ID_Type) is | |
125 begin | |
126 Item.SSN := "444556666"; | |
127 -- ... Other stuff. | |
128 end Update_ID; | |
129 | |
130 end CC51D01_0; | |
131 | |
132 | |
133 --==================================================================-- | |
134 | |
135 | |
136 -- -- | |
137 -- Formal package used here. -- | |
138 -- -- | |
139 | |
140 with FC51D00; -- Generic list abstraction. | |
141 with CC51D01_0; -- Tagged type declarations. | |
142 generic -- This procedure simulates a generic operation for types | |
143 -- in the class rooted at Blind_ID_Type. | |
144 type Elem_Type is new CC51D01_0.Blind_ID_Type with private; | |
145 with package List_Mgr is new FC51D00 (Elem_Type); | |
146 procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); | |
147 | |
148 | |
149 --==================================================================-- | |
150 | |
151 | |
152 -- The implementation of CC51D01_1 is purely artificial; the validity | |
153 -- of its implementation in the context of the abstraction is irrelevant | |
154 -- to the feature being tested. | |
155 -- | |
156 -- The expected behavior here is as follows: for each actual type corresponding | |
157 -- to Elem_Type, the call to Update_ID should invoke the actual type's | |
158 -- implementation, which updates the object's SSN field. Write_Element then | |
159 -- adds the object to the list. | |
160 | |
161 procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is | |
162 Element : Elem_Type := E; -- Can't update IN parameter. | |
163 begin | |
164 Update_ID (Element); -- Executes actual type's version. | |
165 List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version. | |
166 end CC51D01_1; | |
167 | |
168 | |
169 --==================================================================-- | |
170 | |
171 | |
172 with FC51D00; -- Generic list abstraction. | |
173 with CC51D01_0; -- Tagged type declarations. | |
174 with CC51D01_1; -- Generic operation. | |
175 | |
176 with Report; | |
177 procedure CC51D01 is | |
178 | |
179 use CC51D01_0; -- All types & ops | |
180 -- directly visible. | |
181 | |
182 -- Begin test code declarations: ----------------------- | |
183 | |
184 TC_Expected_1 : Blind_ID_Type := (SSN => "111223333"); | |
185 TC_Expected_2 : Named_ID_Type := ("444556666", "Doe "); | |
186 TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0); | |
187 | |
188 TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); | |
189 TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); | |
190 TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0); | |
191 | |
192 -- End test code declarations. ------------------------- | |
193 | |
194 | |
195 -- Begin instantiations and list declarations: --------- | |
196 | |
197 -- At this point in an application, the generic list package would be | |
198 -- instantiated for one of the visible tagged types. Next, the generic | |
199 -- subprogram would be instantiated for the same tagged type and the | |
200 -- preceding list package instance. | |
201 -- | |
202 -- In order to cover all the important cases, this test instantiates several | |
203 -- packages and subprograms (probably more than would typically appear | |
204 -- in user code). | |
205 | |
206 -- Support for lists of blind IDs: | |
207 | |
208 package Blind_Lists is new FC51D00 (Blind_ID_Type); | |
209 procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists); | |
210 Blind_List : Blind_Lists.List_Type; | |
211 | |
212 | |
213 -- Support for lists of named IDs: | |
214 | |
215 package Named_Lists is new FC51D00 (Named_ID_Type); | |
216 procedure Update_and_Write is new -- Overloads subprog | |
217 CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type. | |
218 List_Mgr => Named_Lists); | |
219 Named_List : Named_Lists.List_Type; | |
220 | |
221 | |
222 -- Support for lists of ranked IDs: | |
223 | |
224 package Ranked_Lists is new FC51D00 (Ranked_ID_Type); | |
225 procedure Update_and_Write is new -- Overloads. | |
226 CC51D01_1 (Elem_Type => Ranked_ID_Type, | |
227 List_Mgr => Ranked_Lists); | |
228 Ranked_List : Ranked_Lists.List_Type; | |
229 | |
230 -- End instantiations and list declarations. ----------- | |
231 | |
232 | |
233 begin | |
234 Report.Test ("CC51D01", "Formal private extension, specific tagged " & | |
235 "type actual: body of primitive subprogram executed is " & | |
236 "that of actual type. Check for subprograms declared in " & | |
237 "a formal package"); | |
238 | |
239 | |
240 Update_and_Write (Blind_List, TC_Initial_1); | |
241 | |
242 if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then | |
243 Report.Failed ("Wrong result for root tagged type"); | |
244 end if; | |
245 | |
246 | |
247 Update_and_Write (Named_List, TC_Initial_2); | |
248 | |
249 if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then | |
250 Report.Failed ("Wrong result for type derived directly from root"); | |
251 end if; | |
252 | |
253 | |
254 Update_and_Write (Ranked_List, TC_Initial_3); | |
255 | |
256 if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then | |
257 Report.Failed ("Wrong result for type derived indirectly from root"); | |
258 end if; | |
259 | |
260 | |
261 Report.Result; | |
262 end CC51D01; |