1-- C854001.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 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.
35--
36-- TEST DESCRIPTION:
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.
46--
47--
48-- CHANGE HISTORY:
49--      06 Dec 94   SAIC    ACVC 2.0
50--      07 Nov 95   SAIC    Update and repair for ACVC 2.0.1
51--
52--!
53
54package C854001_0 is
55
56   type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value);
57
58   type Root is record
59      Called : Component := Op_Of_Subtype;
60   end record;
61
62   procedure Root_Proc (P: in out Root);
63   procedure Over_Proc (P: in out Root);
64
65   function Root_Func return Root;
66   function Over_Func return Root;
67
68   type Short_Int is range 1 .. 98;
69
70   function "+" (P1, P2 : Short_Int) return Short_Int;
71   function Name (P1, P2 : Short_Int) return Short_Int;
72
73   type Tag_Type is tagged record
74      C : Component := Initial_Value;
75   end record;
76   -- Inherits predefined operator "=" and others.
77
78   function Predefined_Equal (P1, P2 : Tag_Type) return Boolean
79     renames "=";
80   -- Renames predefined operator "=" before overriding.
81
82private
83   function "=" (P1, P2 : Tag_Type)
84     return Boolean;                   -- Overrides predefined operator "=".
85
86
87end C854001_0;
88
89
90     --==================================================================--
91
92
93package body C854001_0 is
94
95   procedure Root_Proc (P: in out Root) is
96   begin
97      P.Called := Initial_Value;
98   end Root_Proc;
99
100   ---------------------------------------
101   procedure Over_Proc (P: in out Root) is
102   begin
103      P.Called := Op_Of_Type;
104   end Over_Proc;
105
106   ---------------------------------------
107   function Root_Func return Root is
108   begin
109      return (Called => Op_Of_Type);
110   end Root_Func;
111
112   ---------------------------------------
113   function Over_Func return Root is
114   begin
115      return (Called => Initial_Value);
116   end Over_Func;
117
118   ---------------------------------------
119   function "+" (P1, P2 : Short_Int) return Short_Int is
120   begin
121      return 15;
122   end "+";
123
124   ---------------------------------------
125   function Name (P1, P2 : Short_Int) return Short_Int is
126   begin
127      return 47;
128   end Name;
129
130   ---------------------------------------
131   function "=" (P1, P2 : Tag_Type) return Boolean is
132   begin
133      return False;
134   end "=";
135
136end C854001_0;
137
138     --==================================================================--
139
140
141with C854001_0;
142package C854001_1 is
143
144   subtype Root_Subtype is C854001_0.Root;
145   subtype Short_Int_Subtype is C854001_0.Short_Int;
146
147   procedure Ren_Proc  (P: in out Root_Subtype);
148   procedure Same_Proc (P: in out Root_Subtype);
149
150   function Ren_Func  return Root_Subtype;
151   function Same_Func return Root_Subtype;
152
153   function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
154   function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
155
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
159                                                  -- the private part.
160end C854001_1;
161
162
163     --==================================================================--
164
165
166with C854001_0;
167package body C854001_1 is
168
169   --
170   -- Renaming-as-body for procedure:
171   --
172
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;
177
178   --
179   -- Renaming-as-body for function:
180   --
181
182   function Ren_Func  return Root_Subtype renames C854001_0.Root_Func;
183   function Same_Func return Root_Subtype renames C854001_0.Over_Func;
184
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;
189
190end C854001_1;
191
192
193     --==================================================================--
194
195with C854001_0;
196with C854001_1;  -- Subtype and associated operations.
197use  C854001_1;
198
199with Report;
200
201procedure C854001 is
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.
211
212   -- Direct visibility to operator symbols
213   use type C854001_0.Component;
214   use type C854001_0.Short_Int;
215
216begin
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");
222
223   --
224   -- Only operations of the subtype are available.
225   --
226
227   Ren_Proc  (Operand1);
228   if Operand1.Called /= C854001_0.Initial_Value then
229      Report.Failed ("Error calling procedure Ren_Proc");
230   end if;
231
232   ---------------------------------------
233   Same_Proc (Operand2);
234   if Operand2.Called /= C854001_0.Op_Of_Type then
235      Report.Failed ("Error calling procedure Same_Proc");
236   end if;
237
238   ---------------------------------------
239   Operand3 := Ren_Func;
240   if Operand3.Called /= C854001_0.Op_Of_Type then
241      Report.Failed ("Error calling function Ren_Func");
242   end if;
243
244   ---------------------------------------
245   Operand4 := Same_Func;
246   if Operand4.Called /= C854001_0.Initial_Value then
247      Report.Failed ("Error calling function Same_Func");
248   end if;
249
250   ---------------------------------------
251   Operand7 := C854001_1."-" (Operand5, Operand6);
252   if Operand7 /= 47 then
253      Report.Failed ("Error calling function & ""-""");
254   end if;
255
256   ---------------------------------------
257   Operand7 := Other_Name (Operand5, Operand6);
258   if Operand7 /= 15 then
259      Report.Failed ("Error calling function Other_Name");
260   end if;
261
262   ---------------------------------------
263   -- Executes body of the overriding declaration in the private part
264   -- of C854001_0.
265   if User_Defined_Equal (Operand8, Operand9) then
266      Report.Failed ("Error calling function User_Defined_Equal");
267   end if;
268
269   ---------------------------------------
270   -- Executes predefined operation.
271   if not C854001_0.Predefined_Equal (Operand8, Operand9) then
272      Report.Failed ("Error calling function Predefined_Equal");
273   end if;
274
275   Report.Result;
276
277end C854001;
278