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/] [cdd2a01.a] - Blame information for rev 816

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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