OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c8/] [c854001.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- 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
 
54
package 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
 
82
private
83
   function "=" (P1, P2 : Tag_Type)
84
     return Boolean;                   -- Overrides predefined operator "=".
85
 
86
 
87
end C854001_0;
88
 
89
 
90
     --==================================================================--
91
 
92
 
93
package 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
 
136
end C854001_0;
137
 
138
     --==================================================================--
139
 
140
 
141
with C854001_0;
142
package 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.
160
end C854001_1;
161
 
162
 
163
     --==================================================================--
164
 
165
 
166
with C854001_0;
167
package 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
 
190
end C854001_1;
191
 
192
 
193
     --==================================================================--
194
 
195
with C854001_0;
196
with C854001_1;  -- Subtype and associated operations.
197
use  C854001_1;
198
 
199
with Report;
200
 
201
procedure 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
 
216
begin
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
 
277
end C854001;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.