summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c5/c540001.a
blob: b7dbdd6e97ff4c6b001a5ba43fe719c28e154ff6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
-- C540001.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that an expression in a case statement may be of a generic formal
--      type.  Check that a function call may be used as a case statement 
--      expression.  Check that a call to a generic formal function may be 
--      used as a case statement expression.  Check that a call to an inherited
--      function may be used as a case statement expression even if its result
--      type does not correspond to any nameable subtype.
--
-- TEST DESCRIPTION:
--      This transition test creates examples where expressions in a case
--      statement can be a generic formal object and a call to a generic formal
--      function.  This test also creates examples when either a function call,
--      a renaming of a function, or a call to an inherited function is used
--      in the case expressions, the choices of the case statement only need 
--      to cover the values in the result of the function.
--
--      Inspired by B54A08A.ADA.
--
--
-- CHANGE HISTORY:
--      12 Feb 96   SAIC    Initial version for ACVC 2.1.
--
--!

package C540001_0 is 
   type Int is range 1 .. 2;

end C540001_0;

     --==================================================================--

with C540001_0;
package C540001_1 is 
   type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3.
   type Mixed     is ('A','B', 'C', None); 
   subtype Small_Num is Natural range 0 .. 10;
   type Small_Int is range 1 .. 2;
   function Get_Small_Int (P : Boolean) return Small_Int;
   procedure Assign_Mixed (P1 : in     Boolean;
                           P2 :    out Mixed);

   type Tagged_Type is tagged
     record
        C1 : Enum_Type;
     end record;
   function Get_Tagged (P : Tagged_Type) return C540001_0.Int;

end C540001_1;

     --==================================================================--

package body C540001_1 is 
   function Get_Small_Int (P : Boolean) return Small_Int is
   begin
      if P then
         return Small_Int'First;
      else
         return Small_Int'Last; 
      end if;
   end Get_Small_Int;

   ---------------------------------------------------------------------
   procedure Assign_Mixed (P1 : in     Boolean;
                           P2 :    out Mixed) is
   begin
      case Get_Small_Int (P1) is          -- Function call as expression
           when 1  => P2 := None;         -- in case statement.
           when 2  => P2 := 'A';
           -- No others needed.
      end case;

   end Assign_Mixed;

   ---------------------------------------------------------------------
   function Get_Tagged (P : Tagged_Type) return C540001_0.Int is
   begin
      return C540001_0.Int'Last;
   end Get_Tagged;

end C540001_1;

     --==================================================================--

generic               

   type Formal_Scalar is range <>;  

   FSO : Formal_Scalar;

package C540001_2 is              

   type Enum is (Alpha, Beta, Theta);

   procedure Assign_Enum (ET : out Enum);

end C540001_2;

     --==================================================================--

package body C540001_2 is              

   procedure Assign_Enum (ET : out Enum) is
   begin
      case FSO is                         -- Type of expression in case
           when 1      => ET := Alpha;    -- statement is generic formal type.
           when 2      => ET := Beta;
           when others => ET := Theta;
      end case;

   end Assign_Enum;

end C540001_2;

     --==================================================================--

with C540001_1;
generic               

   type Formal_Enum_Type is new C540001_1.Enum_Type;

   with function Formal_Func (P : C540001_1.Small_Num) 
     return Formal_Enum_Type is <>;

function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type;

     --==================================================================--

function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is

begin
   return Formal_Func (P);
end C540001_3;

     --==================================================================--

with C540001_1;
generic               

   type Formal_Int_Type is new C540001_1.Small_Int;

   with function Formal_Func return Formal_Int_Type;

package C540001_4 is

   procedure Gen_Assign_Mixed (P : out C540001_1.Mixed);

end C540001_4;

     --==================================================================--

package body C540001_4 is

   procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is
   begin
      case Formal_Func is                          -- Case expression is
         when 1      => P := C540001_1.'A';        -- generic function.
         when others => P := C540001_1.'B';
      end case;

   end Gen_Assign_Mixed;

end C540001_4;

     --==================================================================--

with C540001_1;
package C540001_5 is
   type New_Tagged is new C540001_1.Tagged_Type with
      record
         C2 : C540001_1.Mixed;
      end record;

    -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int;
    -- Note that the return type of the inherited function is not
    -- nameable here.

   procedure Assign_Tagged (P1 : in     New_Tagged;
                            P2 :    out New_Tagged);

end C540001_5;

     --==================================================================--

package body C540001_5 is

   procedure Assign_Tagged (P1 : in     New_Tagged;
                            P2 :    out New_Tagged) is
   begin
      case Get_Tagged (P1) is                      -- Case expression is
                                                   -- inherited function.
         when 2      => P2 := (C540001_1.Bee, 'B');       
         when others => P2 := (C540001_1.Sea, C540001_1.None);
      end case;

   end Assign_Tagged;

end C540001_5;

     --==================================================================--

with Report;
with C540001_1;
with C540001_2;
with C540001_3;
with C540001_4;
with C540001_5;

procedure C540001 is
   type Value is range 1 .. 5;

begin
   Report.Test ("C540001", "Check that an expression in a case statement " &
                "may be of a generic formal type.  Check that a function " &
                "call may be used as a case statement expression.  Check " &
                "that a call to a generic formal function may be used as " &
                "a case statement expression.  Check that a call to an "   &
                "inherited function may be used as a case statement "      &
                "expression");

   Generic_Formal_Object_Subtest:
   begin
      declare
         One  : Value := 1;
         package One_Pck is new C540001_2 (Value, One);
         use One_Pck;
         EObj : Enum;
      begin
         Assign_Enum (EObj);
         if EObj /= Alpha then
            Report.Failed ("Incorrect result for value of one in generic" &
                           "formal object subtest");
         end if;
      end;

      declare
         Five : Value := 5;
         package Five_Pck is new C540001_2 (Value, Five);
         use Five_Pck;
         EObj : Enum;
      begin
         Assign_Enum (EObj);
         if EObj /= Theta then
            Report.Failed ("Incorrect result for value of five in generic" &
                           "formal object subtest");
         end if;
      end;

   end Generic_Formal_Object_Subtest;

   Instantiated_Generic_Function_Subtest:
   declare
      type New_Enum_Type is new C540001_1.Enum_Type;

      function Get_Enum_Value (P : C540001_1.Small_Num) 
        return New_Enum_Type is
      begin
         return New_Enum_Type'Val (P);
      end Get_Enum_Value;

      function Val_Func is new C540001_3 
        (Formal_Enum_Type => New_Enum_Type, 
         Formal_Func      => Get_Enum_Value);

      procedure Assign_Num (P : in out C540001_1.Small_Num) is
      begin
         case Val_Func (P) is                         -- Case expression is
                                                      -- instantiated generic
             when New_Enum_Type (C540001_1.Eh) |      -- function.
                  New_Enum_Type (C540001_1.Sea)   => P := 4;
             when New_Enum_Type (C540001_1.Bee)   => P := 7;
             when others                          => P := 9;
         end case;

      end Assign_Num;

      SNObj  : C540001_1.Small_Num;

   begin
      SNObj := 0;
      Assign_Num (SNObj);       
      if SNObj /= 4 then
         Report.Failed ("Incorrect result for value of zero in call to " &
                        "generic function subtest");
      end if;

      SNObj := 3;
      Assign_Num (SNObj);       
      if SNObj /= 9 then
         Report.Failed ("Incorrect result for value of three in call to " &
                        "generic function subtest");
      end if;

   end Instantiated_Generic_Function_Subtest;

   -- When a function call, a renaming of a function, or a call to an 
   -- inherited function is used in the case expressions, the choices 
   -- of the case statement only need to cover the values in the result 
   -- of the function.

   Function_Call_Subtest:
   declare
      MObj : C540001_1.Mixed := 'B';
      BObj : Boolean         := True;
      use type C540001_1.Mixed;
   begin
      C540001_1.Assign_Mixed (BObj, MObj);
      if MObj /= C540001_1.None then
         Report.Failed ("Incorrect result for value of true in function" &
                        "call subtest");
         end if;

      BObj := False;
      C540001_1.Assign_Mixed (BObj, MObj);
      if MObj /= C540001_1.'A' then
         Report.Failed ("Incorrect result for value of false in function" &
                        "call subtest");
      end if;

   end Function_Call_Subtest;

   Function_Renaming_Subtest:
   declare
      use C540001_1;
      function Rename_Get_Small_Int (P : Boolean) 
        return Small_Int renames Get_Small_Int;
      MObj : Mixed   := None;
      BObj : Boolean := False;
   begin
      case Rename_Get_Small_Int (BObj) is
          when 1 => MObj := 'A';
          when 2 => MObj := 'B';
          -- No others needed.
      end case;

      if MObj /= 'B' then
         Report.Failed ("Incorrect result for value of false in function" &
                        "renaming subtest");
      end if;

   end Function_Renaming_Subtest;

   Call_To_Generic_Formal_Function_Subtest:
   declare
      type New_Small_Int is new C540001_1.Small_Int;

      function Get_Int_Value return New_Small_Int is
      begin
         return New_Small_Int'First;
      end Get_Int_Value;

      package Int_Pck is new C540001_4 
        (Formal_Int_Type => New_Small_Int, 
         Formal_Func     => Get_Int_Value);

      use type C540001_1.Mixed;
      MObj : C540001_1.Mixed := C540001_1.None; 

   begin
      Int_Pck.Gen_Assign_Mixed (MObj); 
      if MObj /= C540001_1.'A' then
         Report.Failed ("Incorrect result in call to generic formal " &
                        "function subtest");
      end if;

   end Call_To_Generic_Formal_Function_Subtest;

   Call_To_Inherited_Function_Subtest:
   declare
      NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh,
                                        C2 => C540001_1.'A');
      NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C');
      use type C540001_1.Mixed;
      use type C540001_1.Enum_Type;
   begin
      C540001_5.Assign_Tagged (NTObj1, NTObj2);
      if NTObj2.C1 /= C540001_1.Bee or  
         NTObj2.C2 /= C540001_1.'B' then
         Report.Failed ("Incorrect result in inherited function subtest");
      end if;

   end Call_To_Inherited_Function_Subtest;

   Report.Result;

end C540001;