3 -- Grant of Unlimited Rights
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
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.
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.
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.
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.
56 -- The following files comprise this test:
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.
71 package CC51D01_0
is -- This package simulates support for a personnel
74 type SSN_Type
is new String (1 .. 9);
76 type Blind_ID_Type
is tagged record -- Root type of
77 SSN
: SSN_Type
; -- class.
78 -- ... Other components.
81 procedure Update_ID
(Item
: in out Blind_ID_Type
); -- Parent operation.
83 -- ... Other operations.
86 type Name_Type
is new String (1 .. 9);
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.
93 -- Inherits Update_ID from parent.
95 procedure Update_ID
(Item
: in out Named_ID_Type
); -- Overrides parent's
99 type Ranked_ID_Type
is new Named_ID_Type
with record
100 Level
: Integer := 0; -- Indirect derivative
101 -- ... Other components. -- of root type.
104 -- Inherits Update_ID from parent.
109 --==================================================================--
112 package body CC51D01_0
is
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.
118 procedure Update_ID
(Item
: in out Blind_ID_Type
) is
120 Item
.SSN
:= "111223333";
124 procedure Update_ID
(Item
: in out Named_ID_Type
) is
126 Item
.SSN
:= "444556666";
133 --==================================================================--
137 -- Formal package used here. --
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
);
149 --==================================================================--
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.
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.
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.
164 Update_ID
(Element
); -- Executes actual type's version.
165 List_Mgr
.Write_Element
(1, L
, Element
); -- Executes actual type's version.
169 --==================================================================--
172 with FC51D00
; -- Generic list abstraction.
173 with CC51D01_0
; -- Tagged type declarations.
174 with CC51D01_1
; -- Generic operation.
179 use CC51D01_0
; -- All types & ops
182 -- Begin test code declarations: -----------------------
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);
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);
192 -- End test code declarations. -------------------------
195 -- Begin instantiations and list declarations: ---------
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.
202 -- In order to cover all the important cases, this test instantiates several
203 -- packages and subprograms (probably more than would typically appear
206 -- Support for lists of blind IDs:
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
;
213 -- Support for lists of named IDs:
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
;
222 -- Support for lists of ranked IDs:
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
;
230 -- End instantiations and list declarations. -----------
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 " &
240 Update_and_Write
(Blind_List
, TC_Initial_1
);
242 if (Blind_Lists
.View_Element
(1, Blind_List
) /= TC_Expected_1
) then
243 Report
.Failed
("Wrong result for root tagged type");
247 Update_and_Write
(Named_List
, TC_Initial_2
);
249 if (Named_Lists
.View_Element
(1, Named_List
) /= TC_Expected_2
) then
250 Report
.Failed
("Wrong result for type derived directly from root");
254 Update_and_Write
(Ranked_List
, TC_Initial_3
);
256 if (Ranked_Lists
.View_Element
(1, Ranked_List
) /= TC_Expected_3
) then
257 Report
.Failed
("Wrong result for type derived indirectly from root");