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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C731001.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
6
--     F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
7
--     software and documentation contained herein.  Unlimited rights are
8
--     defined in DFAR 252.227-7013(a)(19).  By making this public release,
9
--     the Government intends to confer upon all recipients unlimited rights
10
--     equal to those held by the Government.  These rights include rights to
11
--     use, duplicate, release or disclose the released technical data and
12
--     computer software in whole or in part, in any manner and for any purpose
13
--     whatsoever, and to have or permit others to do so.
14
--
15
--                                    DISCLAIMER
16
--
17
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
18
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
19
--     WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
20
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
21
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
22
--     PARTICULAR PURPOSE OF SAID MATERIAL.
23
--*
24
--
25
-- OBJECTIVE
26
--     Check that inherited operations can be overridden, even when they are
27
--     inherited in a body.
28
--     The test cases here are inspired by the AARM examples given in
29
--     the discussion of AARM-7.3.1(7.a-7.v).
30
--     This discussion was confirmed by AI95-00035.
31
--
32
-- TEST DESCRIPTION
33
--     See AARM-7.3.1.
34
--
35
-- CHANGE HISTORY:
36
--      29 JUN 1999   RAD   Initial Version
37
--      23 SEP 1999   RLB   Improved comments, renamed, issued.
38
--      20 AUG 2001   RLB   Corrected 'verbose' flag.
39
--
40
--!
41
 
42
with Report; use Report; pragma Elaborate_All(Report);
43
package C731001_1 is
44
    pragma Elaborate_Body;
45
private
46
    procedure Check_String(X, Y: String);
47
    function Check_String(X, Y: String) return String;
48
        -- This one is a function, so we can call it in package specs.
49
end C731001_1;
50
 
51
package body C731001_1 is
52
 
53
    Verbose: Boolean := False;
54
 
55
    procedure Check_String(X, Y: String) is
56
    begin
57
        if Verbose then
58
            Comment("""" & X & """ = """ & Y & """?");
59
        end if;
60
        if X /= Y then
61
            Failed("""" & X & """ should be """ & Y & """");
62
        end if;
63
    end Check_String;
64
 
65
    function Check_String(X, Y: String) return String is
66
    begin
67
        Check_String(X, Y);
68
        return X;
69
    end Check_String;
70
 
71
end C731001_1;
72
 
73
private package C731001_1.Parent is
74
 
75
    procedure Call_Main;
76
 
77
    type Root is tagged null record;
78
    subtype Renames_Root is Root;
79
    subtype Root_Class is Renames_Root'Class;
80
    function Make return Root;
81
    function Op1(X: Root) return String;
82
    function Call_Op2(X: Root'Class) return String;
83
private
84
    function Op2(X: Root) return String;
85
end C731001_1.Parent;
86
 
87
procedure C731001_1.Parent.Main;
88
 
89
with C731001_1.Parent.Main;
90
package body C731001_1.Parent is
91
 
92
    procedure Call_Main is
93
    begin
94
        Main;
95
    end Call_Main;
96
 
97
    function Make return Root is
98
        Result: Root;
99
    begin
100
        return Result;
101
    end Make;
102
 
103
    function Op1(X: Root) return String is
104
    begin
105
        return "Parent.Op1 body";
106
    end Op1;
107
 
108
    function Op2(X: Root) return String is
109
    begin
110
        return "Parent.Op2 body";
111
    end Op2;
112
 
113
    function Call_Op2(X: Root'Class) return String is
114
    begin
115
        return Op2(X);
116
    end Call_Op2;
117
 
118
begin
119
 
120
    Check_String(Op1(Root'(Make)), "Parent.Op1 body");
121
    Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
122
 
123
    Check_String(Op2(Root'(Make)), "Parent.Op2 body");
124
    Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
125
 
126
end C731001_1.Parent;
127
 
128
with C731001_1.Parent; use C731001_1.Parent;
129
private package C731001_1.Unrelated is
130
 
131
    type T2 is new Root with null record;
132
    subtype T2_Class is T2'Class;
133
    function Make return T2;
134
    function Op2(X: T2) return String;
135
end C731001_1.Unrelated;
136
 
137
with C731001_1.Parent; use C731001_1.Parent;
138
    pragma Elaborate(C731001_1.Parent);
139
package body C731001_1.Unrelated is
140
 
141
    function Make return T2 is
142
        Result: T2;
143
    begin
144
        return Result;
145
    end Make;
146
 
147
    function Op2(X: T2) return String is
148
    begin
149
        return "Unrelated.Op2 body";
150
    end Op2;
151
begin
152
 
153
    Check_String(Op1(T2'(Make)), "Parent.Op1 body");
154
    Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
155
    Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
156
 
157
    Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
158
    Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
159
    Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
160
    Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
161
    Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
162
 
163
end C731001_1.Unrelated;
164
 
165
package C731001_1.Parent.Child is
166
    pragma Elaborate_Body;
167
 
168
    type T3 is new Root with null record;
169
    subtype T3_Class is T3'Class;
170
    function Make return T3;
171
 
172
    T3_Obj: T3;
173
    T3_Class_Obj: T3_Class := T3_Obj;
174
    T3_Root_Class_Obj: Root_Class := T3_Obj;
175
 
176
    X3: constant String :=
177
      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
178
      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
179
      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
180
 
181
      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
182
      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
183
      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
184
 
185
    package Nested is
186
        type T4 is new Root with null record;
187
        subtype T4_Class is T4'Class;
188
        function Make return T4;
189
 
190
        T4_Obj: T4;
191
        T4_Class_Obj: T4_Class := T4_Obj;
192
        T4_Root_Class_Obj: Root_Class := T4_Obj;
193
 
194
        X4: constant String :=
195
          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
196
          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
197
          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
198
 
199
          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
200
          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
201
          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
202
 
203
    private
204
 
205
        XX4: constant String :=
206
          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
207
          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
208
          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
209
 
210
          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
211
          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
212
          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
213
 
214
    end Nested;
215
 
216
    use Nested;
217
 
218
    XXX4: constant String :=
219
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
220
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
221
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
222
 
223
      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
224
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
225
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
226
 
227
private
228
 
229
    XX3: constant String :=
230
      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
231
      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
232
      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
233
 
234
      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
235
      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
236
      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
237
 
238
      Check_String(Op2(T3_Obj), "Parent.Op2 body") &
239
      Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
240
      Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
241
 
242
    XXXX4: constant String :=
243
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
244
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
245
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
246
 
247
      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
248
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
249
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
250
 
251
      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
252
 
253
end C731001_1.Parent.Child;
254
 
255
with C731001_1.Unrelated; use C731001_1.Unrelated;
256
    pragma Elaborate(C731001_1.Unrelated);
257
package body C731001_1.Parent.Child is
258
 
259
    XXX3: constant String :=
260
      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
261
      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
262
      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
263
 
264
      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
265
      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
266
      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
267
 
268
      Check_String(Op2(T3_Obj), "Parent.Op2 body") &
269
      Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
270
      Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
271
 
272
    XXXXX4: constant String :=
273
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
274
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
275
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
276
 
277
      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
278
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
279
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
280
 
281
      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
282
 
283
    function Make return T3 is
284
        Result: T3;
285
    begin
286
        return Result;
287
    end Make;
288
 
289
    package body Nested is
290
        function Make return T4 is
291
            Result: T4;
292
        begin
293
            return Result;
294
        end Make;
295
 
296
        XXXXXX4: constant String :=
297
          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
298
          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
299
          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
300
 
301
          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
302
          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
303
          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
304
 
305
          Check_String(Op2(T4_Obj), "Parent.Op2 body") &
306
          Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
307
          Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
308
 
309
    end Nested;
310
 
311
    type T5 is new T2 with null record;
312
    subtype T5_Class is T5'Class;
313
    function Make return T5;
314
 
315
    function Make return T5 is
316
        Result: T5;
317
    begin
318
        return Result;
319
    end Make;
320
 
321
    XXXXXXX4: constant String :=
322
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
323
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
324
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
325
 
326
      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
327
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
328
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
329
 
330
      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
331
 
332
end C731001_1.Parent.Child;
333
 
334
procedure C731001_1.Main;
335
 
336
with C731001_1.Parent;
337
procedure C731001_1.Main is
338
begin
339
    C731001_1.Parent.Call_Main;
340
end C731001_1.Main;
341
 
342
with C731001_1.Parent.Child;
343
    use C731001_1.Parent;
344
    use C731001_1.Parent.Child;
345
    use C731001_1.Parent.Child.Nested;
346
with C731001_1.Unrelated; use C731001_1.Unrelated;
347
procedure C731001_1.Parent.Main is
348
 
349
    Root_Obj: Root := Make;
350
    Root_Class_Obj: Root_Class := Root'(Make);
351
 
352
    T2_Obj: T2 := Make;
353
    T2_Class_Obj: T2_Class := T2_Obj;
354
    T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
355
 
356
    T3_Obj: T3 := Make;
357
    T3_Class_Obj: T3_Class := T3_Obj;
358
    T3_Root_Class_Obj: Root_Class := T3_Obj;
359
 
360
    T4_Obj: T4 := Make;
361
    T4_Class_Obj: T4_Class := T4_Obj;
362
    T4_Root_Class_Obj: Root_Class := T4_Obj;
363
 
364
begin
365
    Test("C731001_1", "Check that inherited operations can be overridden, even"
366
                    & " when they are inherited in a body");
367
 
368
    Check_String(Op1(Root_Obj), "Parent.Op1 body");
369
    Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
370
 
371
    Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
372
    Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
373
 
374
    Check_String(Op1(T2_Obj), "Parent.Op1 body");
375
    Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
376
    Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
377
 
378
    Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
379
    Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
380
    Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
381
    Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
382
    Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
383
 
384
    Check_String(Op1(T3_Obj), "Parent.Op1 body");
385
    Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
386
    Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
387
 
388
    Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
389
    Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
390
    Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
391
 
392
    Check_String(Op1(T4_Obj), "Parent.Op1 body");
393
    Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
394
    Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
395
 
396
    Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
397
    Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
398
    Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
399
 
400
    Result;
401
end C731001_1.Parent.Main;
402
 
403
with C731001_1.Main;
404
procedure C731001 is
405
begin
406
    C731001_1.Main;
407
end C731001;

powered by: WebSVN 2.1.0

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