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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C540001.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 an expression in a case statement may be of a generic formal
28
--      type.  Check that a function call may be used as a case statement
29
--      expression.  Check that a call to a generic formal function may be
30
--      used as a case statement expression.  Check that a call to an inherited
31
--      function may be used as a case statement expression even if its result
32
--      type does not correspond to any nameable subtype.
33
--
34
-- TEST DESCRIPTION:
35
--      This transition test creates examples where expressions in a case
36
--      statement can be a generic formal object and a call to a generic formal
37
--      function.  This test also creates examples when either a function call,
38
--      a renaming of a function, or a call to an inherited function is used
39
--      in the case expressions, the choices of the case statement only need
40
--      to cover the values in the result of the function.
41
--
42
--      Inspired by B54A08A.ADA.
43
--
44
--
45
-- CHANGE HISTORY:
46
--      12 Feb 96   SAIC    Initial version for ACVC 2.1.
47
--
48
--!
49
 
50
package C540001_0 is
51
   type Int is range 1 .. 2;
52
 
53
end C540001_0;
54
 
55
     --==================================================================--
56
 
57
with C540001_0;
58
package C540001_1 is
59
   type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3.
60
   type Mixed     is ('A','B', 'C', None);
61
   subtype Small_Num is Natural range 0 .. 10;
62
   type Small_Int is range 1 .. 2;
63
   function Get_Small_Int (P : Boolean) return Small_Int;
64
   procedure Assign_Mixed (P1 : in     Boolean;
65
                           P2 :    out Mixed);
66
 
67
   type Tagged_Type is tagged
68
     record
69
        C1 : Enum_Type;
70
     end record;
71
   function Get_Tagged (P : Tagged_Type) return C540001_0.Int;
72
 
73
end C540001_1;
74
 
75
     --==================================================================--
76
 
77
package body C540001_1 is
78
   function Get_Small_Int (P : Boolean) return Small_Int is
79
   begin
80
      if P then
81
         return Small_Int'First;
82
      else
83
         return Small_Int'Last;
84
      end if;
85
   end Get_Small_Int;
86
 
87
   ---------------------------------------------------------------------
88
   procedure Assign_Mixed (P1 : in     Boolean;
89
                           P2 :    out Mixed) is
90
   begin
91
      case Get_Small_Int (P1) is          -- Function call as expression
92
           when 1  => P2 := None;         -- in case statement.
93
           when 2  => P2 := 'A';
94
           -- No others needed.
95
      end case;
96
 
97
   end Assign_Mixed;
98
 
99
   ---------------------------------------------------------------------
100
   function Get_Tagged (P : Tagged_Type) return C540001_0.Int is
101
   begin
102
      return C540001_0.Int'Last;
103
   end Get_Tagged;
104
 
105
end C540001_1;
106
 
107
     --==================================================================--
108
 
109
generic
110
 
111
   type Formal_Scalar is range <>;
112
 
113
   FSO : Formal_Scalar;
114
 
115
package C540001_2 is
116
 
117
   type Enum is (Alpha, Beta, Theta);
118
 
119
   procedure Assign_Enum (ET : out Enum);
120
 
121
end C540001_2;
122
 
123
     --==================================================================--
124
 
125
package body C540001_2 is
126
 
127
   procedure Assign_Enum (ET : out Enum) is
128
   begin
129
      case FSO is                         -- Type of expression in case
130
           when 1      => ET := Alpha;    -- statement is generic formal type.
131
           when 2      => ET := Beta;
132
           when others => ET := Theta;
133
      end case;
134
 
135
   end Assign_Enum;
136
 
137
end C540001_2;
138
 
139
     --==================================================================--
140
 
141
with C540001_1;
142
generic
143
 
144
   type Formal_Enum_Type is new C540001_1.Enum_Type;
145
 
146
   with function Formal_Func (P : C540001_1.Small_Num)
147
     return Formal_Enum_Type is <>;
148
 
149
function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type;
150
 
151
     --==================================================================--
152
 
153
function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is
154
 
155
begin
156
   return Formal_Func (P);
157
end C540001_3;
158
 
159
     --==================================================================--
160
 
161
with C540001_1;
162
generic
163
 
164
   type Formal_Int_Type is new C540001_1.Small_Int;
165
 
166
   with function Formal_Func return Formal_Int_Type;
167
 
168
package C540001_4 is
169
 
170
   procedure Gen_Assign_Mixed (P : out C540001_1.Mixed);
171
 
172
end C540001_4;
173
 
174
     --==================================================================--
175
 
176
package body C540001_4 is
177
 
178
   procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is
179
   begin
180
      case Formal_Func is                          -- Case expression is
181
         when 1      => P := C540001_1.'A';        -- generic function.
182
         when others => P := C540001_1.'B';
183
      end case;
184
 
185
   end Gen_Assign_Mixed;
186
 
187
end C540001_4;
188
 
189
     --==================================================================--
190
 
191
with C540001_1;
192
package C540001_5 is
193
   type New_Tagged is new C540001_1.Tagged_Type with
194
      record
195
         C2 : C540001_1.Mixed;
196
      end record;
197
 
198
    -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int;
199
    -- Note that the return type of the inherited function is not
200
    -- nameable here.
201
 
202
   procedure Assign_Tagged (P1 : in     New_Tagged;
203
                            P2 :    out New_Tagged);
204
 
205
end C540001_5;
206
 
207
     --==================================================================--
208
 
209
package body C540001_5 is
210
 
211
   procedure Assign_Tagged (P1 : in     New_Tagged;
212
                            P2 :    out New_Tagged) is
213
   begin
214
      case Get_Tagged (P1) is                      -- Case expression is
215
                                                   -- inherited function.
216
         when 2      => P2 := (C540001_1.Bee, 'B');
217
         when others => P2 := (C540001_1.Sea, C540001_1.None);
218
      end case;
219
 
220
   end Assign_Tagged;
221
 
222
end C540001_5;
223
 
224
     --==================================================================--
225
 
226
with Report;
227
with C540001_1;
228
with C540001_2;
229
with C540001_3;
230
with C540001_4;
231
with C540001_5;
232
 
233
procedure C540001 is
234
   type Value is range 1 .. 5;
235
 
236
begin
237
   Report.Test ("C540001", "Check that an expression in a case statement " &
238
                "may be of a generic formal type.  Check that a function " &
239
                "call may be used as a case statement expression.  Check " &
240
                "that a call to a generic formal function may be used as " &
241
                "a case statement expression.  Check that a call to an "   &
242
                "inherited function may be used as a case statement "      &
243
                "expression");
244
 
245
   Generic_Formal_Object_Subtest:
246
   begin
247
      declare
248
         One  : Value := 1;
249
         package One_Pck is new C540001_2 (Value, One);
250
         use One_Pck;
251
         EObj : Enum;
252
      begin
253
         Assign_Enum (EObj);
254
         if EObj /= Alpha then
255
            Report.Failed ("Incorrect result for value of one in generic" &
256
                           "formal object subtest");
257
         end if;
258
      end;
259
 
260
      declare
261
         Five : Value := 5;
262
         package Five_Pck is new C540001_2 (Value, Five);
263
         use Five_Pck;
264
         EObj : Enum;
265
      begin
266
         Assign_Enum (EObj);
267
         if EObj /= Theta then
268
            Report.Failed ("Incorrect result for value of five in generic" &
269
                           "formal object subtest");
270
         end if;
271
      end;
272
 
273
   end Generic_Formal_Object_Subtest;
274
 
275
   Instantiated_Generic_Function_Subtest:
276
   declare
277
      type New_Enum_Type is new C540001_1.Enum_Type;
278
 
279
      function Get_Enum_Value (P : C540001_1.Small_Num)
280
        return New_Enum_Type is
281
      begin
282
         return New_Enum_Type'Val (P);
283
      end Get_Enum_Value;
284
 
285
      function Val_Func is new C540001_3
286
        (Formal_Enum_Type => New_Enum_Type,
287
         Formal_Func      => Get_Enum_Value);
288
 
289
      procedure Assign_Num (P : in out C540001_1.Small_Num) is
290
      begin
291
         case Val_Func (P) is                         -- Case expression is
292
                                                      -- instantiated generic
293
             when New_Enum_Type (C540001_1.Eh) |      -- function.
294
                  New_Enum_Type (C540001_1.Sea)   => P := 4;
295
             when New_Enum_Type (C540001_1.Bee)   => P := 7;
296
             when others                          => P := 9;
297
         end case;
298
 
299
      end Assign_Num;
300
 
301
      SNObj  : C540001_1.Small_Num;
302
 
303
   begin
304
      SNObj := 0;
305
      Assign_Num (SNObj);
306
      if SNObj /= 4 then
307
         Report.Failed ("Incorrect result for value of zero in call to " &
308
                        "generic function subtest");
309
      end if;
310
 
311
      SNObj := 3;
312
      Assign_Num (SNObj);
313
      if SNObj /= 9 then
314
         Report.Failed ("Incorrect result for value of three in call to " &
315
                        "generic function subtest");
316
      end if;
317
 
318
   end Instantiated_Generic_Function_Subtest;
319
 
320
   -- When a function call, a renaming of a function, or a call to an
321
   -- inherited function is used in the case expressions, the choices
322
   -- of the case statement only need to cover the values in the result
323
   -- of the function.
324
 
325
   Function_Call_Subtest:
326
   declare
327
      MObj : C540001_1.Mixed := 'B';
328
      BObj : Boolean         := True;
329
      use type C540001_1.Mixed;
330
   begin
331
      C540001_1.Assign_Mixed (BObj, MObj);
332
      if MObj /= C540001_1.None then
333
         Report.Failed ("Incorrect result for value of true in function" &
334
                        "call subtest");
335
         end if;
336
 
337
      BObj := False;
338
      C540001_1.Assign_Mixed (BObj, MObj);
339
      if MObj /= C540001_1.'A' then
340
         Report.Failed ("Incorrect result for value of false in function" &
341
                        "call subtest");
342
      end if;
343
 
344
   end Function_Call_Subtest;
345
 
346
   Function_Renaming_Subtest:
347
   declare
348
      use C540001_1;
349
      function Rename_Get_Small_Int (P : Boolean)
350
        return Small_Int renames Get_Small_Int;
351
      MObj : Mixed   := None;
352
      BObj : Boolean := False;
353
   begin
354
      case Rename_Get_Small_Int (BObj) is
355
          when 1 => MObj := 'A';
356
          when 2 => MObj := 'B';
357
          -- No others needed.
358
      end case;
359
 
360
      if MObj /= 'B' then
361
         Report.Failed ("Incorrect result for value of false in function" &
362
                        "renaming subtest");
363
      end if;
364
 
365
   end Function_Renaming_Subtest;
366
 
367
   Call_To_Generic_Formal_Function_Subtest:
368
   declare
369
      type New_Small_Int is new C540001_1.Small_Int;
370
 
371
      function Get_Int_Value return New_Small_Int is
372
      begin
373
         return New_Small_Int'First;
374
      end Get_Int_Value;
375
 
376
      package Int_Pck is new C540001_4
377
        (Formal_Int_Type => New_Small_Int,
378
         Formal_Func     => Get_Int_Value);
379
 
380
      use type C540001_1.Mixed;
381
      MObj : C540001_1.Mixed := C540001_1.None;
382
 
383
   begin
384
      Int_Pck.Gen_Assign_Mixed (MObj);
385
      if MObj /= C540001_1.'A' then
386
         Report.Failed ("Incorrect result in call to generic formal " &
387
                        "function subtest");
388
      end if;
389
 
390
   end Call_To_Generic_Formal_Function_Subtest;
391
 
392
   Call_To_Inherited_Function_Subtest:
393
   declare
394
      NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh,
395
                                        C2 => C540001_1.'A');
396
      NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C');
397
      use type C540001_1.Mixed;
398
      use type C540001_1.Enum_Type;
399
   begin
400
      C540001_5.Assign_Tagged (NTObj1, NTObj2);
401
      if NTObj2.C1 /= C540001_1.Bee or
402
         NTObj2.C2 /= C540001_1.'B' then
403
         Report.Failed ("Incorrect result in inherited function subtest");
404
      end if;
405
 
406
   end Call_To_Inherited_Function_Subtest;
407
 
408
   Report.Result;
409
 
410
end C540001;

powered by: WebSVN 2.1.0

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