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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C330001.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7
--     unlimited rights in the software and documentation contained herein.
8
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9
--     this public release, the Government intends to confer upon all
10
--     recipients unlimited rights  equal to those held by the Government.
11
--     These rights include rights to use, duplicate, release or disclose the
12
--     released technical data and computer software in whole or in part, in
13
--     any manner and for any purpose whatsoever, and to have or permit others
14
--     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 a variable object of an indefinite type is properly
28
--      initialized/constrained by an initial value assignment that is
29
--      a) an aggregate, b) a function, or c) an object.  Check that objects
30
--      of the above types do not need explicit constraints if they have
31
--      initial values.
32
--
33
-- TEST DESCRIPTION:
34
--      An indefinite subtype is either:
35
--         a) An unconstrained array subtype.
36
--         b) A subtype with unknown discriminants.
37
--         c) A subtype with unconstrained discriminants without defaults.
38
--
39
--      Declare several indefinite types in a parent package specification.
40
--      In the private part, complete one type with a discriminant without
41
--      default (indefinite) and the other with a default discriminant
42
--      (definite).  Declare objects of both indefinite and definite subtypes
43
--      in children (private and public) with initialization expressions.  The
44
--      test verifies all values of the objects.  It also verifies that
45
--      Constraint_Error is raised if an attempt is made to change the
46
--      discriminants of the objects of the indefinite subtypes.
47
--
48
--
49
-- CHANGE HISTORY:
50
--      15 Jan 95   SAIC    Initial version for ACVC 2.1
51
--      25 Jul 96   SAIC    Modified test description. Deleted use C330001_0.
52
--      20 Nov 98   RLB     Added Elaborate pragmas to avoid problems
53
--                          with an unconventional, but legal, elaboration
54
--                          order.
55
--!
56
 
57
package C330001_0 is
58
 
59
   subtype Sub_Type is Integer range 1 .. 20;
60
 
61
   type Tag_W_Disc (D : Sub_Type) is tagged record
62
       C1 :  String (1 .. D);
63
   end record;
64
 
65
   -- Indefinite type declarations.
66
 
67
   type FullViewDefinite_Unknown_Disc (<>) is private;
68
 
69
   type Indefinite_No_Disc is array (Positive range <>) of Integer;
70
 
71
   type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged
72
     record
73
        C1 : Boolean := False;
74
     end record;
75
 
76
   type Indefinite_New_W_Disc (ND : Sub_Type) is new
77
     Indefinite_Tag_W_Disc (ND) with record
78
        C2 : Integer := 9;
79
     end record;
80
 
81
   type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with
82
     record
83
        S : Sub_Type := 18;
84
     end record;
85
 
86
   type Indefinite_W_Inherit_Disc_2 is
87
     new Tag_W_Disc with private;
88
 
89
   function Indef_Func_1 return FullViewDefinite_Unknown_Disc;
90
 
91
   function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2;
92
 
93
private
94
 
95
   type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is
96
      record
97
        S : String (1 .. D) := "Hi";
98
      end record;
99
 
100
   type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with
101
      record
102
        S : Sub_Type;
103
      end record;
104
 
105
end C330001_0;
106
 
107
     --==================================================================--
108
 
109
package body C330001_0 is
110
 
111
   function Indef_Func_1 return FullViewDefinite_Unknown_Disc is
112
      Var_1 : FullViewDefinite_Unknown_Disc;      -- No need for explicit
113
                                                  -- constraints, use initial
114
   begin                                          -- values.
115
      return Var_1;
116
   end Indef_Func_1;
117
 
118
   ------------------------------------------------------------------
119
   function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is
120
      Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P);
121
   begin
122
      return Var_2;
123
   end Indef_Func_2;
124
 
125
end C330001_0;
126
 
127
     --==================================================================--
128
 
129
with C330001_0;
130
pragma Elaborate(C330001_0); -- Insure that the functions can be called.
131
private
132
package C330001_0.C330001_1 is
133
 
134
   PrivateChild_Obj    : Tag_W_Disc := (D => 4, C1 => "ACVC");
135
 
136
   PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1
137
     := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15);
138
 
139
   -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in
140
   -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization
141
   -- expression.
142
 
143
   PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19);
144
 
145
   -- Since full view of FullViewDefinite_Unknown_Disc is definite in the
146
   -- parent package, no initialization expression needed for
147
   -- PrivateChild_Obj_03.
148
 
149
   PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc;
150
 
151
   PrivateChild_Obj_04 : Indefinite_No_Disc          := (12, 15);
152
 
153
end C330001_0.C330001_1;
154
 
155
     --==================================================================--
156
 
157
with C330001_0;
158
pragma Elaborate(C330001_0); -- Insure that the functions can be called.
159
package C330001_0.C330001_2 is
160
 
161
   PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1;
162
 
163
   PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2   := Indef_Func_2 (4);
164
 
165
   PublicChild_Obj_03 : Indefinite_No_Disc            := (38, 72, 21, 59);
166
 
167
   PublicChild_Obj_04 : Indefinite_Tag_W_Disc         := (D => 7, C1 => True);
168
 
169
   PublicChild_Obj_05 : Indefinite_Tag_W_Disc         := PublicChild_Obj_04;
170
 
171
   PublicChild_Obj_06 : Indefinite_New_W_Disc (6);
172
 
173
   procedure Assign_Private_Obj_3;
174
 
175
   function Raised_CE_PublicChild_Obj return Boolean;
176
 
177
   function Raised_CE_PrivateChild_Obj return Boolean;
178
 
179
   -- The following functions check the private types defined in the parent
180
   -- and the private child package from within the client program.
181
 
182
   function Verify_Public_Obj_1 return Boolean;
183
 
184
   function Verify_Public_Obj_2 return Boolean;
185
 
186
   function Verify_Private_Obj_1 return Boolean;
187
 
188
   function Verify_Private_Obj_2 return Boolean;
189
 
190
   function Verify_Private_Obj_3 return Boolean;
191
 
192
end C330001_0.C330001_2;
193
 
194
     --==================================================================--
195
 
196
with Report;
197
with C330001_0.C330001_1;
198
package body C330001_0.C330001_2 is
199
 
200
   procedure Assign_Private_Obj_3 is
201
   begin
202
      C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha");
203
   end Assign_Private_Obj_3;
204
 
205
   ------------------------------------------------------------------
206
   function Raised_CE_PublicChild_Obj return Boolean is
207
   begin
208
      PublicChild_Obj_03 := (16, 13);       -- C_E, can't change constraints
209
                                            -- of PublicChild_Obj_03.
210
 
211
      Report.Failed ("Constraint_Error not raised - Public child");
212
 
213
      -- Next line prevents dead assignment.
214
 
215
      Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image
216
                      (PublicChild_Obj_03'First) );
217
      return False;
218
 
219
   exception
220
      when Constraint_Error =>
221
         return True;                       -- Exception is expected.
222
      when others           =>
223
         return False;
224
   end Raised_CE_PublicChild_Obj;
225
 
226
   ------------------------------------------------------------------
227
   function Raised_CE_PrivateChild_Obj return Boolean is
228
   begin
229
      C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18);
230
                                            -- C_E, can't change constraints
231
                                            -- of PrivateChild_Obj_04.
232
 
233
      Report.Failed ("Constraint_Error not raised - Private child");
234
 
235
      -- Next line prevents dead assignment.
236
 
237
      Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image
238
                      (C330001_0.C330001_1.PrivateChild_Obj_04'Last) );
239
      return False;
240
 
241
   exception
242
      when Constraint_Error =>
243
         return True;                       -- Exception is expected.
244
      when others           =>
245
         return False;
246
   end Raised_CE_PrivateChild_Obj;
247
 
248
   ------------------------------------------------------------------
249
   function Verify_Public_Obj_1 return Boolean is
250
   begin
251
      return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi");
252
 
253
   end Verify_Public_Obj_1;
254
 
255
   ------------------------------------------------------------------
256
   function Verify_Public_Obj_2 return Boolean is
257
   begin
258
      return (PublicChild_Obj_02.D  = 5       and
259
              PublicChild_Obj_02.C1 = "Hello" and
260
              PublicChild_Obj_02.S  = 4);
261
 
262
   end Verify_Public_Obj_2;
263
 
264
   ------------------------------------------------------------------
265
   function Verify_Private_Obj_1 return Boolean is
266
   begin
267
      return (C330001_0.C330001_1.PrivateChild_Obj_01.D  = 4      and
268
              C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and
269
              C330001_0.C330001_1.PrivateChild_Obj_01.S  = 15);
270
 
271
   end Verify_Private_Obj_1;
272
 
273
   ------------------------------------------------------------------
274
   function Verify_Private_Obj_2 return Boolean is
275
   begin
276
      return (C330001_0.C330001_1.PrivateChild_Obj_02.D  = 5       and
277
              C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and
278
              C330001_0.C330001_1.PrivateChild_Obj_02.S  = 19);
279
 
280
   end Verify_Private_Obj_2;
281
 
282
   ------------------------------------------------------------------
283
   function Verify_Private_Obj_3 return Boolean is
284
   begin
285
      return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and
286
              C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha");
287
 
288
   end Verify_Private_Obj_3;
289
 
290
end C330001_0.C330001_2;
291
 
292
     --==================================================================--
293
 
294
with C330001_0.C330001_2;
295
with Report;
296
 
297
use  C330001_0.C330001_2;
298
 
299
procedure C330001 is
300
begin
301
   Report.Test ("C330001", "Check that a variable object of an indefinite " &
302
                "type is properly initialized/constrained by an initial "   &
303
                "value assignment that is a) an aggregate, b) a function, " &
304
                "or c) an object.  Check that objects of the above types "  &
305
                "do not need explicit constraints if they have initial "    &
306
                "values");
307
 
308
   -- Verify values of public child objects.
309
 
310
   if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then
311
      Report.Failed ("Wrong values for PublicChild_Obj_01 or " &
312
                     "PublicChild_Obj_02");
313
   end if;
314
 
315
   if PublicChild_Obj_03'First /= 1 or
316
      PublicChild_Obj_03'Last  /= 4 then
317
      Report.Failed ("Wrong values for PublicChild_Obj_03");
318
   end if;
319
 
320
   if PublicChild_Obj_05.D  /= 7 or
321
      not PublicChild_Obj_05.C1  then
322
      Report.Failed ("Wrong values for PublicChild_Obj_05");
323
   end if;
324
 
325
   if PublicChild_Obj_06.ND /= 6 or
326
      PublicChild_Obj_06.C2 /= 9 or
327
      PublicChild_Obj_06.C1      then
328
      Report.Failed ("Wrong values for PublicChild_Obj_06");
329
   end if;
330
 
331
   -- Definite object can have its discriminant changed by assignment to
332
   -- the entire object.
333
 
334
   Assign_Private_Obj_3;
335
 
336
   -- Verify values of private child objects.
337
 
338
   if not Verify_Private_Obj_1 or not
339
          Verify_Private_Obj_2 or not
340
          Verify_Private_Obj_3 then
341
      Report.Failed ("Wrong values for PrivateChild_Obj_01 or " &
342
                     "PrivateChild_Obj_02 or PrivateChild_Obj_03");
343
   end if;
344
 
345
   -- Attempt to change the discriminants of the objects of the indefinite
346
   -- subtypes:  Constraint_Error.
347
 
348
   if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then
349
      Report.Failed ("Constraint_Error not raised");
350
   end if;
351
 
352
   Report.Result;
353
 
354
end C330001;

powered by: WebSVN 2.1.0

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