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 a subprogram declaration can be completed by a
28 -- subprogram renaming declaration. In particular, check that such a
29 -- renaming-as-body can be given in a package body to complete a
30 -- subprogram declared in the package specification. Check that calls
31 -- to the subprogram invoke the body of the renamed subprogram. Check
32 -- that a renaming allows a copy of an inherited or predefined subprogram
33 -- before overriding it later. Check that renaming a dispatching
34 -- operation calls the correct body in case of overriding.
37 -- This test declares a record type, an integer type, and a tagged type
38 -- with a set of operations in a package. A renaming of a predefined
39 -- equality operation of a tagged type is also defined in this package.
40 -- The predefined operation is overridden in the private part. In a
41 -- separate package, a subtype of the record type and integer type
42 -- are declared. Subset of the full set of operations for the record
43 -- and types is reexported using renamings-as-bodies. Other operations
44 -- are given explicit bodies. The test verifies that the appropriate
45 -- body is executed for each operation on the subtype.
49 -- 06 Dec 94 SAIC ACVC 2.0
50 -- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1
56 type Component
is (Op_Of_Type
, Op_Of_Subtype
, Initial_Value
);
59 Called
: Component
:= Op_Of_Subtype
;
62 procedure Root_Proc
(P
: in out Root
);
63 procedure Over_Proc
(P
: in out Root
);
65 function Root_Func
return Root
;
66 function Over_Func
return Root
;
68 type Short_Int
is range 1 .. 98;
70 function "+" (P1
, P2
: Short_Int
) return Short_Int
;
71 function Name
(P1
, P2
: Short_Int
) return Short_Int
;
73 type Tag_Type
is tagged record
74 C
: Component
:= Initial_Value
;
76 -- Inherits predefined operator "=" and others.
78 function Predefined_Equal
(P1
, P2
: Tag_Type
) return Boolean
80 -- Renames predefined operator "=" before overriding.
83 function "=" (P1
, P2
: Tag_Type
)
84 return Boolean; -- Overrides predefined operator "=".
90 --==================================================================--
93 package body C854001_0
is
95 procedure Root_Proc
(P
: in out Root
) is
97 P
.Called
:= Initial_Value
;
100 ---------------------------------------
101 procedure Over_Proc
(P
: in out Root
) is
103 P
.Called
:= Op_Of_Type
;
106 ---------------------------------------
107 function Root_Func
return Root
is
109 return (Called
=> Op_Of_Type
);
112 ---------------------------------------
113 function Over_Func
return Root
is
115 return (Called
=> Initial_Value
);
118 ---------------------------------------
119 function "+" (P1
, P2
: Short_Int
) return Short_Int
is
124 ---------------------------------------
125 function Name
(P1
, P2
: Short_Int
) return Short_Int
is
130 ---------------------------------------
131 function "=" (P1
, P2
: Tag_Type
) return Boolean is
138 --==================================================================--
144 subtype Root_Subtype
is C854001_0
.Root
;
145 subtype Short_Int_Subtype
is C854001_0
.Short_Int
;
147 procedure Ren_Proc
(P
: in out Root_Subtype
);
148 procedure Same_Proc
(P
: in out Root_Subtype
);
150 function Ren_Func
return Root_Subtype
;
151 function Same_Func
return Root_Subtype
;
153 function Other_Name
(P1
, P2
: Short_Int_Subtype
) return Short_Int_Subtype
;
154 function "-" (P1
, P2
: Short_Int_Subtype
) return Short_Int_Subtype
;
156 function User_Defined_Equal
(P1
, P2
: C854001_0
.Tag_Type
) return Boolean
157 renames C854001_0
."="; -- Executes body of the
158 -- overriding declaration in
163 --==================================================================--
167 package body C854001_1
is
170 -- Renaming-as-body for procedure:
173 procedure Ren_Proc
(P
: in out Root_Subtype
)
174 renames C854001_0
.Root_Proc
;
175 procedure Same_Proc
(P
: in out Root_Subtype
)
176 renames C854001_0
.Over_Proc
;
179 -- Renaming-as-body for function:
182 function Ren_Func
return Root_Subtype
renames C854001_0
.Root_Func
;
183 function Same_Func
return Root_Subtype
renames C854001_0
.Over_Func
;
185 function Other_Name
(P1
, P2
: Short_Int_Subtype
) return Short_Int_Subtype
186 renames C854001_0
."+";
187 function "-" (P1
, P2
: Short_Int_Subtype
) return Short_Int_Subtype
188 renames C854001_0
.Name
;
193 --==================================================================--
196 with C854001_1
; -- Subtype and associated operations.
202 Operand1
: Root_Subtype
;
203 Operand2
: Root_Subtype
;
204 Operand3
: Root_Subtype
;
205 Operand4
: Root_Subtype
;
206 Operand5
: Short_Int_Subtype
:= 55;
207 Operand6
: Short_Int_Subtype
:= 46;
208 Operand7
: Short_Int_Subtype
;
209 Operand8
: C854001_0
.Tag_Type
; -- Both Operand8 & Operand9 have
210 Operand9
: C854001_0
.Tag_Type
; -- the same default values.
212 -- Direct visibility to operator symbols
213 use type C854001_0
.Component
;
214 use type C854001_0
.Short_Int
;
217 Report
.Test
("C854001", "Check that a renaming-as-body can be given " &
218 "in a package body to complete a subprogram " &
219 "declared in the package specification. " &
220 "Check that calls to the subprogram invoke " &
221 "the body of the renamed subprogram");
224 -- Only operations of the subtype are available.
228 if Operand1
.Called
/= C854001_0
.Initial_Value
then
229 Report
.Failed
("Error calling procedure Ren_Proc");
232 ---------------------------------------
233 Same_Proc
(Operand2
);
234 if Operand2
.Called
/= C854001_0
.Op_Of_Type
then
235 Report
.Failed
("Error calling procedure Same_Proc");
238 ---------------------------------------
239 Operand3
:= Ren_Func
;
240 if Operand3
.Called
/= C854001_0
.Op_Of_Type
then
241 Report
.Failed
("Error calling function Ren_Func");
244 ---------------------------------------
245 Operand4
:= Same_Func
;
246 if Operand4
.Called
/= C854001_0
.Initial_Value
then
247 Report
.Failed
("Error calling function Same_Func");
250 ---------------------------------------
251 Operand7
:= C854001_1
."-" (Operand5
, Operand6
);
252 if Operand7
/= 47 then
253 Report
.Failed
("Error calling function & ""-""");
256 ---------------------------------------
257 Operand7
:= Other_Name
(Operand5
, Operand6
);
258 if Operand7
/= 15 then
259 Report
.Failed
("Error calling function Other_Name");
262 ---------------------------------------
263 -- Executes body of the overriding declaration in the private part
265 if User_Defined_Equal
(Operand8
, Operand9
) then
266 Report
.Failed
("Error calling function User_Defined_Equal");
269 ---------------------------------------
270 -- Executes predefined operation.
271 if not C854001_0
.Predefined_Equal
(Operand8
, Operand9
) then
272 Report
.Failed
("Error calling function Predefined_Equal");