|
111
|
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;
|
