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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CDD2A03.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 default Read and Write attributes for a limited type
28
--    extension are created from the parent type's attribute (which may be
29
--    user-defined) and those for the extension components, if the extension
30
--    components are non-limited or have user-defined attributes.  Check that
31
--    such limited type extension attributes are callable (Defect Report
32
--    8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence
33
--     of 13.13.2(9/1) and 13.13.2(36/1)).
34
--
35
-- CHANGE HISTORY:
36
--     1 AUG 2001   PHL   Initial version.
37
--     3 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 CDD2A03 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 Lim is limited
66
        record
67
            C : Int;
68
        end record;
69
 
70
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim);
71
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim);
72
    function Input (Stream : access Root_Stream_Type'Class) return Lim;
73
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim);
74
 
75
    for Lim'Read use Read;
76
    for Lim'Write use Write;
77
    for Lim'Input use Input;
78
    for Lim'Output use Output;
79
 
80
 
81
    type Parent (D1, D2 : Int; B : Boolean) is tagged limited
82
        record
83
            S : Str (D1 .. D2);
84
            case B is
85
                when False =>
86
                    C1 : Integer;
87
                when True =>
88
                    C2 : Float;
89
            end case;
90
        end record;
91
 
92
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
93
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
94
    function Input (Stream : access Root_Stream_Type'Class) return Parent;
95
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
96
 
97
    for Parent'Read use Read;
98
    for Parent'Write use Write;
99
    for Parent'Input use Input;
100
    for Parent'Output use Output;
101
 
102
 
103
    procedure Actual_Read
104
                 (Stream : access Root_Stream_Type'Class; Item : out Int) is
105
    begin
106
        Integer'Read (Stream, Integer (Item));
107
    end Actual_Read;
108
 
109
    procedure Actual_Write
110
                 (Stream : access Root_Stream_Type'Class; Item : Int) is
111
    begin
112
        Integer'Write (Stream, Integer (Item));
113
    end Actual_Write;
114
 
115
    function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
116
    begin
117
        return Int (Integer'Input (Stream));
118
    end Actual_Input;
119
 
120
    procedure Actual_Output
121
                 (Stream : access Root_Stream_Type'Class; Item : Int) is
122
    begin
123
        Integer'Output (Stream, Integer (Item));
124
    end Actual_Output;
125
 
126
 
127
    procedure Actual_Read
128
                 (Stream : access Root_Stream_Type'Class; Item : out Lim) is
129
    begin
130
        Integer'Read (Stream, Integer (Item.C));
131
    end Actual_Read;
132
 
133
    procedure Actual_Write
134
                 (Stream : access Root_Stream_Type'Class; Item : Lim) is
135
    begin
136
        Integer'Write (Stream, Integer (Item.C));
137
    end Actual_Write;
138
 
139
    function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is
140
        Result : Lim;
141
    begin
142
        Result.C := Int (Integer'Input (Stream));
143
        return Result;
144
    end Actual_Input;
145
 
146
    procedure Actual_Output
147
                 (Stream : access Root_Stream_Type'Class; Item : Lim) is
148
    begin
149
        Integer'Output (Stream, Integer (Item.C));
150
    end Actual_Output;
151
 
152
 
153
    procedure Actual_Read
154
                 (Stream : access Root_Stream_Type'Class; Item : out Parent) is
155
    begin
156
        case Item.B is
157
            when False =>
158
                Item.C1 := 7;
159
            when True =>
160
                Float'Read (Stream, Item.C2);
161
        end case;
162
        Str'Read (Stream, Item.S);
163
    end Actual_Read;
164
 
165
    procedure Actual_Write
166
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
167
    begin
168
        case Item.B is
169
            when False =>
170
                null; -- Don't write C1
171
            when True =>
172
                Float'Write (Stream, Item.C2);
173
        end case;
174
        Str'Write (Stream, Item.S);
175
    end Actual_Write;
176
 
177
    function Actual_Input
178
                (Stream : access Root_Stream_Type'Class) return Parent is
179
        X : Parent (1, 1, True);
180
    begin
181
        raise Input_Output_Error;
182
        return X;
183
    end Actual_Input;
184
 
185
    procedure Actual_Output
186
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
187
    begin
188
        raise Input_Output_Error;
189
    end Actual_Output;
190
 
191
    package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
192
                                                Actual_Write => Actual_Write,
193
                                                Actual_Input => Actual_Input,
194
                                                Actual_Read => Actual_Read,
195
                                                Actual_Output => Actual_Output);
196
 
197
    package Lim_Ops is new Counting_Stream_Ops (T => Lim,
198
                                                Actual_Write => Actual_Write,
199
                                                Actual_Input => Actual_Input,
200
                                                Actual_Read => Actual_Read,
201
                                                Actual_Output => Actual_Output);
202
 
203
    package Parent_Ops is
204
       new Counting_Stream_Ops (T => Parent,
205
                                Actual_Write => Actual_Write,
206
                                Actual_Input => Actual_Input,
207
                                Actual_Read => Actual_Read,
208
                                Actual_Output => Actual_Output);
209
 
210
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
211
       renames Int_Ops.Read;
212
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
213
       renames Int_Ops.Write;
214
    function Input (Stream : access Root_Stream_Type'Class) return Int'Base
215
       renames Int_Ops.Input;
216
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
217
       renames Int_Ops.Output;
218
 
219
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim)
220
       renames Lim_Ops.Read;
221
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim)
222
       renames Lim_Ops.Write;
223
    function Input (Stream : access Root_Stream_Type'Class) return Lim
224
       renames Lim_Ops.Input;
225
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim)
226
       renames Lim_Ops.Output;
227
 
228
    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
229
       renames Parent_Ops.Read;
230
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
231
       renames Parent_Ops.Write;
232
    function Input (Stream : access Root_Stream_Type'Class) return Parent
233
       renames Parent_Ops.Input;
234
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
235
       renames Parent_Ops.Output;
236
 
237
    type Derived1 is new Parent with
238
        record
239
            C3 : Int;
240
        end record;
241
 
242
    type Derived2 (D : Int) is new Parent (D1 => D,
243
                                           D2 => D,
244
                                           B => False) with
245
        record
246
            C3 : Lim;
247
        end record;
248
 
249
begin
250
    Test ("CDD2A03",
251
          "Check that the default Read and Write attributes for a limited " &
252
             "type extension are created from the parent type's " &
253
             "attribute (which may be user-defined) and those for the " &
254
             "extension components, if the extension components are " &
255
             "non-limited or have user-defined attributes; check that such " &
256
             "limited type extension attributes are callable");
257
 
258
    Test1:
259
        declare
260
            S : aliased My_Stream (1000);
261
            X1 : Derived1 (D1 => Int (Ident_Int (2)),
262
                           D2 => Int (Ident_Int (5)),
263
                           B => Ident_Bool (True));
264
            X2 : Derived1 (D1 => Int (Ident_Int (2)),
265
                           D2 => Int (Ident_Int (5)),
266
                           B => Ident_Bool (True));
267
        begin
268
            X1.S := Str (Ident_Str ("bcde"));
269
            X1.C2 := Float (Ident_Int (4));
270
            X1.C3 := Int (Ident_Int (99));
271
 
272
            Derived1'Write (S'Access, X1);
273
            if Int_Ops.Get_Counts /=
274
               (Read => 0, Write => 1, Input => 0, Output => 0) then
275
                Failed ("Error writing extension components - 1");
276
            end if;
277
            if Parent_Ops.Get_Counts /=
278
               (Read => 0, Write => 1, Input => 0, Output => 0) then
279
                Failed ("Didn't call parent type's Write - 1");
280
            end if;
281
 
282
            Derived1'Read (S'Access, X2);
283
            if Int_Ops.Get_Counts /=
284
               (Read => 1, Write => 1, Input => 0, Output => 0) then
285
                Failed ("Error reading extension components - 1");
286
            end if;
287
            if Parent_Ops.Get_Counts /=
288
               (Read => 1, Write => 1, Input => 0, Output => 0) then
289
                Failed ("Didn't call inherited Read - 1");
290
            end if;
291
        end Test1;
292
 
293
    Test2:
294
        declare
295
            S : aliased My_Stream (1000);
296
            X1 : Derived2 (D => Int (Ident_Int (7)));
297
            X2 : Derived2 (D => Int (Ident_Int (7)));
298
        begin
299
            X1.S := Str (Ident_Str ("g"));
300
            X1.C1 := Ident_Int (4);
301
            X1.C3.C := Int (Ident_Int (666));
302
 
303
            Derived2'Write (S'Access, X1);
304
            if Lim_Ops.Get_Counts /=
305
               (Read => 0, Write => 1, Input => 0, Output => 0) then
306
                Failed ("Error writing extension components - 2");
307
            end if;
308
            if Parent_Ops.Get_Counts /=
309
               (Read => 1, Write => 2, Input => 0, Output => 0) then
310
                Failed ("Didn't call inherited Write - 2");
311
            end if;
312
 
313
            Derived2'Read (S'Access, X2);
314
            if Lim_Ops.Get_Counts /=
315
               (Read => 1, Write => 1, Input => 0, Output => 0) then
316
                Failed ("Error reading extension components - 2");
317
            end if;
318
            if Parent_Ops.Get_Counts /=
319
               (Read => 2, Write => 2, Input => 0, Output => 0) then
320
                Failed ("Didn't call inherited Read - 2");
321
            end if;
322
        end Test2;
323
 
324
    Result;
325
end CDD2A03;

powered by: WebSVN 2.1.0

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