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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c392014.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392014.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6
--     rights in the software and documentation contained herein. Unlimited
7
--     rights are the same as those granted by the U.S. Government for older
8
--     parts of the Ada Conformity Assessment Test Suite, and are defined
9
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10
--     intends to confer upon all recipients unlimited rights equal to those
11
--     held by the ACAA. These rights include rights to use, duplicate,
12
--     release or disclose the released technical data and computer software
13
--     in whole or in part, in any manner and for any purpose whatsoever, and
14
--     to have or permit others 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 objects designated by X'Access (where X is of a class-wide
28
--    type) and new T'Class'(...) are dynamically tagged and can be used in
29
--    dispatching calls.  (Defect Report 8652/0010).
30
--
31
-- CHANGE HISTORY:
32
--    18 JAN 2001   PHL   Initial version
33
--    15 MAR 2001   RLB   Readied for release.
34
--    03 JUN 2004   RLB   Removed constraint for S0, as the subtype has
35
--                        unknown discriminants.
36
 
37
--!
38
package C392014_0 is
39
 
40
    type T (D : Integer) is abstract tagged private;
41
 
42
    procedure P (X : access T) is abstract;
43
    function Create (X : Integer) return T'Class;
44
 
45
    Result : Natural := 0;
46
 
47
private
48
    type T (D : Integer) is abstract tagged null record;
49
end C392014_0;
50
 
51
with C392014_0;
52
package C392014_1 is
53
    type T is new C392014_0.T with private;
54
    function Create (X : Integer) return T'Class;
55
private
56
    type T is new C392014_0.T with
57
        record
58
            C1 : Integer;
59
        end record;
60
    procedure P (X : access T);
61
end C392014_1;
62
 
63
package C392014_1.Child is
64
    type T is new C392014_1.T with private;
65
    procedure P (X : access T);
66
    function Create (X : Integer) return T'Class;
67
private
68
    type T is new C392014_1.T with
69
        record
70
            C1C : Integer;
71
        end record;
72
end C392014_1.Child;
73
 
74
with Report;
75
use Report;
76
with C392014_1.Child;
77
package body C392014_1 is
78
 
79
    procedure P (X : access T) is
80
    begin
81
        C392014_0.Result := C392014_0.Result + X.D + X.C1;
82
    end P;
83
 
84
    function Create (X : Integer) return T'Class is
85
    begin
86
        case X mod Ident_Int (2) is
87
            when 0 =>
88
                return C392014_1.Child.Create (X / Ident_Int (2));
89
            when 1 =>
90
                declare
91
                    Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20));
92
                begin
93
                    Y.C1 := X / Ident_Int (40);
94
                    return T'Class (Y);
95
                end;
96
            when others =>
97
                null;
98
        end case;
99
    end Create;
100
 
101
end C392014_1;
102
 
103
with C392014_0;
104
with C392014_1;
105
package C392014_2 is
106
    type T is new C392014_0.T with private;
107
    function Create (X : Integer) return T'Class;
108
private
109
    type T is new C392014_1.T with
110
        record
111
            C2 : Integer;
112
        end record;
113
    procedure P (X : access T);
114
end C392014_2;
115
 
116
with Report;
117
use Report;
118
with C392014_1.Child;
119
with C392014_2;
120
package body C392014_0 is
121
 
122
    function Create (X : Integer) return T'Class is
123
    begin
124
        case X mod 3 is
125
            when 0 =>
126
                return C392014_1.Create (X / Ident_Int (3));
127
            when 1 =>
128
                return C392014_1.Child.Create (X / Ident_Int (3));
129
            when 2 =>
130
                return C392014_2.Create (X / Ident_Int (3));
131
            when others =>
132
                null;
133
        end case;
134
    end Create;
135
 
136
end C392014_0;
137
 
138
with Report;
139
use Report;
140
with C392014_0;
141
package body C392014_1.Child is
142
 
143
    procedure P (X : access T) is
144
    begin
145
        C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C;
146
    end P;
147
 
148
    function Create (X : Integer) return T'Class is
149
        Y : T (D => X mod Ident_Int (20));
150
    begin
151
        Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20);
152
        Y.C1C := X / Ident_Int (400);
153
        return T'Class (Y);
154
    end Create;
155
 
156
end C392014_1.Child;
157
 
158
with Report;
159
use Report;
160
package body C392014_2 is
161
 
162
    procedure P (X : access T) is
163
    begin
164
        C392014_0.Result := C392014_0.Result + X.D + X.C2;
165
    end P;
166
 
167
    function Create (X : Integer) return T'Class is
168
        Y : T (D => X mod Ident_Int (20));
169
    begin
170
        Y.C2 := X / Ident_Int (600);
171
        return T'Class (Y);
172
    end Create;
173
 
174
end C392014_2;
175
 
176
with Report;
177
use Report;
178
with C392014_0;
179
with C392014_1.Child;
180
with C392014_2;
181
procedure C392014 is
182
 
183
    subtype S0 is C392014_0.T'Class;
184
    subtype S1 is C392014_1.T'Class;
185
 
186
    X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218));
187
    X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253));
188
 
189
    Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693));
190
    Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622));
191
 
192
    procedure TC_Check (Subtest : String; Expected : Integer) is
193
    begin
194
        if C392014_0.Result = Expected then
195
            Comment ("Subtest " & Subtest & " Passed");
196
        else
197
            Failed ("Subtest " & Subtest & " Failed");
198
        end if;
199
        C392014_0.Result := Ident_Int (0);
200
    end TC_Check;
201
 
202
begin
203
    Test ("C392014",
204
          "Check that objects designated by X'Access " &
205
             "(where X is of a class-wide type) and New T'Class'(...) " &
206
             "are dynamically tagged and can be used in dispatching " &
207
             "calls");
208
 
209
    C392014_0.P (X0'Access);
210
    TC_Check ("X0'Access", Ident_Int (29));
211
    C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850))));
212
    TC_Check ("New C392014_0.T'Class", Ident_Int (27));
213
    C392014_1.P (X1'Access);
214
    TC_Check ("X1'Access", Ident_Int (212));
215
    C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031))));
216
    TC_Check ("New C392014_1.T'Class", Ident_Int (65));
217
    C392014_0.P (Y0'Access);
218
    TC_Check ("Y0'Access", Ident_Int (18));
219
    C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893))));
220
    TC_Check ("New S0", Ident_Int (20));
221
    C392014_1.P (Y1'Access);
222
    TC_Check ("Y1'Access", Ident_Int (18));
223
    C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861))));
224
    TC_Check ("New S1", Ident_Int (56));
225
 
226
    Result;
227
end C392014;

powered by: WebSVN 2.1.0

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