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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cd/] [cdd2a02.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- CDD2A02.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 the Read, Write, Input, and Output attributes are inherited
28
--    for untagged derived types.  (Defect Report 8652/0040,
29
--     as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and
30
--     13.13.2(25/1)).
31
--
32
-- CHANGE HISTORY:
33
--    30 JUL 2001   PHL   Initial version.
34
--     5 DEC 2001   RLB   Reformatted for ACATS.
35
--
36
--!
37
with Ada.Streams;
38
use Ada.Streams;
39
with FDD2A00;
40
use FDD2A00;
41
with Report;
42
use Report;
43
procedure CDD2A02 is
44
 
45
    type Int is range 1 .. 10;
46
    type Str is array (Int range <>) of Character;
47
 
48
    procedure Read (Stream : access Root_Stream_Type'Class;
49
                    Item : out Int'Base);
50
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
51
    function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
52
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
53
 
54
    for Int'Read use Read;
55
    for Int'Write use Write;
56
    for Int'Input use Input;
57
    for Int'Output use Output;
58
 
59
 
60
    type Parent (D1, D2 : Int; B : Boolean) is
61
        record
62
            S : Str (D1 .. D2);
63
            case B is
64
                when False =>
65
                    C1 : Integer;
66
                when True =>
67
                    C2 : Float;
68
            end case;
69
        end record;
70
 
71
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
72
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
73
    function Input (Stream : access Root_Stream_Type'Class) return Parent;
74
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
75
 
76
    for Parent'Read use Read;
77
    for Parent'Write use Write;
78
    for Parent'Input use Input;
79
    for Parent'Output use Output;
80
 
81
 
82
    procedure Actual_Read
83
                 (Stream : access Root_Stream_Type'Class; Item : out Int) is
84
    begin
85
        Integer'Read (Stream, Integer (Item));
86
    end Actual_Read;
87
 
88
    procedure Actual_Write
89
                 (Stream : access Root_Stream_Type'Class; Item : Int) is
90
    begin
91
        Integer'Write (Stream, Integer (Item));
92
    end Actual_Write;
93
 
94
    function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
95
    begin
96
        return Int (Integer'Input (Stream));
97
    end Actual_Input;
98
 
99
    procedure Actual_Output
100
                 (Stream : access Root_Stream_Type'Class; Item : Int) is
101
    begin
102
        Integer'Output (Stream, Integer (Item));
103
    end Actual_Output;
104
 
105
 
106
    procedure Actual_Read
107
                 (Stream : access Root_Stream_Type'Class; Item : out Parent) is
108
    begin
109
        case Item.B is
110
            when False =>
111
                Item.C1 := 7;
112
            when True =>
113
                Float'Read (Stream, Item.C2);
114
        end case;
115
        Str'Read (Stream, Item.S);
116
    end Actual_Read;
117
 
118
    procedure Actual_Write
119
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
120
    begin
121
        case Item.B is
122
            when False =>
123
                null; -- Don't write C1
124
            when True =>
125
                Float'Write (Stream, Item.C2);
126
        end case;
127
        Str'Write (Stream, Item.S);
128
    end Actual_Write;
129
 
130
    function Actual_Input
131
                (Stream : access Root_Stream_Type'Class) return Parent is
132
        D1, D2 : Int;
133
        B : Boolean;
134
    begin
135
        Int'Read (Stream, D2);
136
        Boolean'Read (Stream, B);
137
        Int'Read (Stream, D1);
138
 
139
        declare
140
            Item : Parent (D1 => D1, D2 => D2, B => B);
141
        begin
142
            Parent'Read (Stream, Item);
143
            return Item;
144
        end;
145
 
146
    end Actual_Input;
147
 
148
    procedure Actual_Output
149
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
150
    begin
151
        Int'Write (Stream, Item.D2);
152
        Boolean'Write (Stream, Item.B);
153
        Int'Write (Stream, Item.D1);
154
        Parent'Write (Stream, Item);
155
    end Actual_Output;
156
 
157
    package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
158
                                                Actual_Write => Actual_Write,
159
                                                Actual_Input => Actual_Input,
160
                                                Actual_Read => Actual_Read,
161
                                                Actual_Output => Actual_Output);
162
 
163
    package Parent_Ops is
164
       new Counting_Stream_Ops (T => Parent,
165
                                Actual_Write => Actual_Write,
166
                                Actual_Input => Actual_Input,
167
                                Actual_Read => Actual_Read,
168
                                Actual_Output => Actual_Output);
169
 
170
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
171
       renames Int_Ops.Read;
172
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
173
       renames Int_Ops.Write;
174
    function Input (Stream : access Root_Stream_Type'Class) return Int'Base
175
       renames Int_Ops.Input;
176
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
177
       renames Int_Ops.Output;
178
 
179
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
180
       renames Parent_Ops.Read;
181
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
182
       renames Parent_Ops.Write;
183
    function Input (Stream : access Root_Stream_Type'Class) return Parent
184
       renames Parent_Ops.Input;
185
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
186
       renames Parent_Ops.Output;
187
 
188
begin
189
    Test ("CDD2A02", "Check that the Read, Write, Input, and Output " &
190
                     "attributes are inherited for untagged derived types");
191
 
192
    Test1:
193
        declare
194
            type Derived1 is new Parent;
195
            S : aliased My_Stream (1000);
196
            X1 : Derived1 (D1 => Int (Ident_Int (2)),
197
                           D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
198
            Y1 : Derived1 := (D1 => 3,
199
                              D2 => 6,
200
                              B => False,
201
                              S => Str (Ident_Str ("3456")),
202
                              C1 => Ident_Int (100));
203
            X2 : Derived1 (D1 => Int (Ident_Int (2)),
204
                           D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
205
        begin
206
            X1.S := Str (Ident_Str ("bcde"));
207
            X1.C2 := Float (Ident_Int (4));
208
 
209
            Derived1'Write (S'Access, X1);
210
            if Int_Ops.Get_Counts /=
211
               (Read => 0, Write => 0, Input => 0, Output => 0) then
212
                Failed ("Error writing discriminants - 1");
213
            end if;
214
            if Parent_Ops.Get_Counts /=
215
               (Read => 0, Write => 1, Input => 0, Output => 0) then
216
                Failed ("Didn't call inherited Write - 1");
217
            end if;
218
 
219
            Derived1'Read (S'Access, X2);
220
            if Int_Ops.Get_Counts /=
221
               (Read => 0, Write => 0, Input => 0, Output => 0) then
222
                Failed ("Error reading discriminants - 1");
223
            end if;
224
            if Parent_Ops.Get_Counts /=
225
               (Read => 1, Write => 1, Input => 0, Output => 0) then
226
                Failed ("Didn't call inherited Read - 1");
227
            end if;
228
 
229
            if X2 /= (D1 => 2,
230
                      D2 => 5,
231
                      B => True,
232
                      S => Str (Ident_Str ("bcde")),
233
                      C2 => Float (Ident_Int (4))) then
234
                Failed
235
                   ("Inherited Read and Write are not inverses of each other - 1");
236
            end if;
237
 
238
            Derived1'Output (S'Access, Y1);
239
            if Int_Ops.Get_Counts /=
240
               (Read => 0, Write => 2, Input => 0, Output => 0) then
241
                Failed ("Error writing discriminants - 2");
242
            end if;
243
            if Parent_Ops.Get_Counts /=
244
               (Read => 1, Write => 2, Input => 0, Output => 1) then
245
                Failed ("Didn't call inherited Output - 2");
246
            end if;
247
 
248
            declare
249
                Y2 : Derived1 := Derived1'Input (S'Access);
250
            begin
251
                if Int_Ops.Get_Counts /=
252
                   (Read => 2, Write => 2, Input => 0, Output => 0) then
253
                    Failed ("Error reading discriminants - 2");
254
                end if;
255
                if Parent_Ops.Get_Counts /=
256
                   (Read => 2, Write => 2, Input => 1, Output => 1) then
257
                    Failed ("Didn't call inherited Input - 2");
258
                end if;
259
 
260
                if Y2 /= (D1 => 3,
261
                          D2 => 6,
262
                          B => False,
263
                          S => Str (Ident_Str ("3456")),
264
                          C1 => Ident_Int (7)) then
265
                    Failed
266
                       ("Inherited Input and Output are not inverses of each other - 2");
267
                end if;
268
            end;
269
        end Test1;
270
 
271
    Test2:
272
        declare
273
            type Derived2 (D : Int) is new Parent (D1 => D,
274
                                                   D2 => D,
275
                                                   B => False);
276
            S : aliased My_Stream (1000);
277
            X1 : Derived2 (D => Int (Ident_Int (7)));
278
            Y1 : Derived2 := (D => 8,
279
                              S => Str (Ident_Str ("8")),
280
                              C1 => Ident_Int (200));
281
            X2 : Derived2 (D => Int (Ident_Int (7)));
282
        begin
283
            X1.S := Str (Ident_Str ("g"));
284
            X1.C1 := Ident_Int (4);
285
 
286
            Derived2'Write (S'Access, X1);
287
            if Int_Ops.Get_Counts /=
288
               (Read => 2, Write => 2, Input => 0, Output => 0) then
289
                Failed ("Error writing discriminants - 3");
290
            end if;
291
            if Parent_Ops.Get_Counts /=
292
               (Read => 2, Write => 3, Input => 1, Output => 1) then
293
                Failed ("Didn't call inherited Write - 3");
294
            end if;
295
 
296
            Derived2'Read (S'Access, X2);
297
            if Int_Ops.Get_Counts /=
298
               (Read => 2, Write => 2, Input => 0, Output => 0) then
299
                Failed ("Error reading discriminants - 3");
300
            end if;
301
            if Parent_Ops.Get_Counts /=
302
               (Read => 3, Write => 3, Input => 1, Output => 1) then
303
                Failed ("Didn't call inherited Read - 3");
304
            end if;
305
 
306
            if X2 /= (D => 7,
307
                      S => Str (Ident_Str ("g")),
308
                      C1 => Ident_Int (7)) then
309
                Failed
310
                   ("Inherited Read and Write are not inverses of each other - 3");
311
            end if;
312
 
313
            Derived2'Output (S'Access, Y1);
314
            if Int_Ops.Get_Counts /=
315
               (Read => 2, Write => 4, Input => 0, Output => 0) then
316
                Failed ("Error writing discriminants - 4");
317
            end if;
318
            if Parent_Ops.Get_Counts /=
319
               (Read => 3, Write => 4, Input => 1, Output => 2) then
320
                Failed ("Didn't call inherited Output - 4");
321
            end if;
322
 
323
            declare
324
                Y2 : Derived2 := Derived2'Input (S'Access);
325
            begin
326
                if Int_Ops.Get_Counts /=
327
                   (Read => 4, Write => 4, Input => 0, Output => 0) then
328
                    Failed ("Error reading discriminants - 4");
329
                end if;
330
                if Parent_Ops.Get_Counts /=
331
                   (Read => 4, Write => 4, Input => 2, Output => 2) then
332
                    Failed ("Didn't call inherited Input - 4");
333
                end if;
334
 
335
                if Y2 /= (D => 8,
336
                          S => Str (Ident_Str ("8")),
337
                          C1 => Ident_Int (7)) then
338
                    Failed
339
                       ("Inherited Input and Output are not inverses of each other - 4");
340
                end if;
341
            end;
342
        end Test2;
343
 
344
    Result;
345
end CDD2A02;

powered by: WebSVN 2.1.0

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