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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_case.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S E M _ C A S E                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1996-2010, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Einfo;    use Einfo;
28
with Errout;   use Errout;
29
with Namet;    use Namet;
30
with Nlists;   use Nlists;
31
with Nmake;    use Nmake;
32
with Opt;      use Opt;
33
with Sem;      use Sem;
34
with Sem_Aux;  use Sem_Aux;
35
with Sem_Eval; use Sem_Eval;
36
with Sem_Res;  use Sem_Res;
37
with Sem_Util; use Sem_Util;
38
with Sem_Type; use Sem_Type;
39
with Snames;   use Snames;
40
with Stand;    use Stand;
41
with Sinfo;    use Sinfo;
42
with Tbuild;   use Tbuild;
43
with Uintp;    use Uintp;
44
 
45
with Ada.Unchecked_Deallocation;
46
 
47
with GNAT.Heap_Sort_G;
48
 
49
package body Sem_Case is
50
 
51
   type Choice_Bounds is record
52
     Lo   : Node_Id;
53
     Hi   : Node_Id;
54
     Node : Node_Id;
55
   end record;
56
   --  Represent one choice bounds entry with Lo and Hi values, Node points
57
   --  to the choice node itself.
58
 
59
   type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
60
   --  Table type used to sort the choices present in a case statement, array
61
   --  aggregate or record variant. The actual entries are stored in 1 .. Last,
62
   --  but we have a 0 entry for convenience in sorting.
63
 
64
   -----------------------
65
   -- Local Subprograms --
66
   -----------------------
67
 
68
   procedure Check_Choices
69
     (Choice_Table   : in out Choice_Table_Type;
70
      Bounds_Type    : Entity_Id;
71
      Subtyp         : Entity_Id;
72
      Others_Present : Boolean;
73
      Case_Node      : Node_Id);
74
   --  This is the procedure which verifies that a set of case alternatives
75
   --  or record variant choices has no duplicates, and covers the range
76
   --  specified by Bounds_Type. Choice_Table contains the discrete choices
77
   --  to check. These must start at position 1.
78
   --
79
   --  Furthermore Choice_Table (0) must exist. This element is used by
80
   --  the sorting algorithm as a temporary. Others_Present is a flag
81
   --  indicating whether or not an Others choice is present. Finally
82
   --  Msg_Sloc gives the source location of the construct containing the
83
   --  choices in the Choice_Table.
84
   --
85
   --  Bounds_Type is the type whose range must be covered by the alternatives
86
   --
87
   --  Subtyp is the subtype of the expression. If its bounds are non-static
88
   --  the alternatives must cover its base type.
89
 
90
   function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
91
   --  Given a Pos value of enumeration type Ctype, returns the name
92
   --  ID of an appropriate string to be used in error message output.
93
 
94
   procedure Expand_Others_Choice
95
     (Case_Table     : Choice_Table_Type;
96
      Others_Choice  : Node_Id;
97
      Choice_Type    : Entity_Id);
98
   --  The case table is the table generated by a call to Analyze_Choices
99
   --  (with just 1 .. Last_Choice entries present). Others_Choice is a
100
   --  pointer to the N_Others_Choice node (this routine is only called if
101
   --  an others choice is present), and Choice_Type is the discrete type
102
   --  of the bounds. The effect of this call is to analyze the cases and
103
   --  determine the set of values covered by others. This choice list is
104
   --  set in the Others_Discrete_Choices field of the N_Others_Choice node.
105
 
106
   -------------------
107
   -- Check_Choices --
108
   -------------------
109
 
110
   procedure Check_Choices
111
     (Choice_Table   : in out Choice_Table_Type;
112
      Bounds_Type    : Entity_Id;
113
      Subtyp         : Entity_Id;
114
      Others_Present : Boolean;
115
      Case_Node      : Node_Id)
116
   is
117
      procedure Explain_Non_Static_Bound;
118
      --  Called when we find a non-static bound, requiring the base type to
119
      --  be covered. Provides where possible a helpful explanation of why the
120
      --  bounds are non-static, since this is not always obvious.
121
 
122
      function Lt_Choice (C1, C2 : Natural) return Boolean;
123
      --  Comparison routine for comparing Choice_Table entries. Use the lower
124
      --  bound of each Choice as the key.
125
 
126
      procedure Move_Choice (From : Natural; To : Natural);
127
      --  Move routine for sorting the Choice_Table
128
 
129
      package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);
130
 
131
      procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
132
      procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
133
      procedure Issue_Msg (Value1 : Uint;    Value2 : Node_Id);
134
      procedure Issue_Msg (Value1 : Uint;    Value2 : Uint);
135
      --  Issue an error message indicating that there are missing choices,
136
      --  followed by the image of the missing choices themselves which lie
137
      --  between Value1 and Value2 inclusive.
138
 
139
      ---------------
140
      -- Issue_Msg --
141
      ---------------
142
 
143
      procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
144
      begin
145
         Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
146
      end Issue_Msg;
147
 
148
      procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
149
      begin
150
         Issue_Msg (Expr_Value (Value1), Value2);
151
      end Issue_Msg;
152
 
153
      procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
154
      begin
155
         Issue_Msg (Value1, Expr_Value (Value2));
156
      end Issue_Msg;
157
 
158
      procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
159
         Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
160
 
161
      begin
162
         --  In some situations, we call this with a null range, and
163
         --  obviously we don't want to complain in this case!
164
 
165
         if Value1 > Value2 then
166
            return;
167
         end if;
168
 
169
         --  Case of only one value that is missing
170
 
171
         if Value1 = Value2 then
172
            if Is_Integer_Type (Bounds_Type) then
173
               Error_Msg_Uint_1 := Value1;
174
               Error_Msg ("missing case value: ^!", Msg_Sloc);
175
            else
176
               Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
177
               Error_Msg ("missing case value: %!", Msg_Sloc);
178
            end if;
179
 
180
         --  More than one choice value, so print range of values
181
 
182
         else
183
            if Is_Integer_Type (Bounds_Type) then
184
               Error_Msg_Uint_1 := Value1;
185
               Error_Msg_Uint_2 := Value2;
186
               Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
187
            else
188
               Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
189
               Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
190
               Error_Msg ("missing case values: % .. %!", Msg_Sloc);
191
            end if;
192
         end if;
193
      end Issue_Msg;
194
 
195
      ---------------
196
      -- Lt_Choice --
197
      ---------------
198
 
199
      function Lt_Choice (C1, C2 : Natural) return Boolean is
200
      begin
201
         return
202
           Expr_Value (Choice_Table (Nat (C1)).Lo)
203
             <
204
           Expr_Value (Choice_Table (Nat (C2)).Lo);
205
      end Lt_Choice;
206
 
207
      -----------------
208
      -- Move_Choice --
209
      -----------------
210
 
211
      procedure Move_Choice (From : Natural; To : Natural) is
212
      begin
213
         Choice_Table (Nat (To)) := Choice_Table (Nat (From));
214
      end Move_Choice;
215
 
216
      ------------------------------
217
      -- Explain_Non_Static_Bound --
218
      ------------------------------
219
 
220
      procedure Explain_Non_Static_Bound is
221
         Expr : Node_Id;
222
 
223
      begin
224
         if Nkind (Case_Node) = N_Variant_Part then
225
            Expr := Name (Case_Node);
226
         else
227
            Expr := Expression (Case_Node);
228
         end if;
229
 
230
         if Bounds_Type /= Subtyp then
231
 
232
            --  If the case is a variant part, the expression is given by
233
            --  the discriminant itself, and the bounds are the culprits.
234
 
235
            if Nkind (Case_Node) = N_Variant_Part then
236
               Error_Msg_NE
237
                 ("bounds of & are not static," &
238
                     " alternatives must cover base type", Expr, Expr);
239
 
240
            --  If this is a case statement, the expression may be
241
            --  non-static or else the subtype may be at fault.
242
 
243
            elsif Is_Entity_Name (Expr) then
244
               Error_Msg_NE
245
                 ("bounds of & are not static," &
246
                    " alternatives must cover base type", Expr, Expr);
247
 
248
            else
249
               Error_Msg_N
250
                 ("subtype of expression is not static,"
251
                  & " alternatives must cover base type!", Expr);
252
            end if;
253
 
254
         --  Otherwise the expression is not static, even if the bounds of the
255
         --  type are, or else there are missing alternatives. If both, the
256
         --  additional information may be redundant but harmless.
257
 
258
         elsif not Is_Entity_Name (Expr) then
259
            Error_Msg_N
260
              ("subtype of expression is not static, "
261
               & "alternatives must cover base type!", Expr);
262
         end if;
263
      end Explain_Non_Static_Bound;
264
 
265
      --  Variables local to Check_Choices
266
 
267
      Choice    : Node_Id;
268
      Bounds_Lo : constant Node_Id := Type_Low_Bound  (Bounds_Type);
269
      Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
270
 
271
      Prev_Choice : Node_Id;
272
 
273
      Hi      : Uint;
274
      Lo      : Uint;
275
      Prev_Hi : Uint;
276
 
277
   --  Start of processing for Check_Choices
278
 
279
   begin
280
      --  Choice_Table must start at 0 which is an unused location used
281
      --  by the sorting algorithm. However the first valid position for
282
      --  a discrete choice is 1.
283
 
284
      pragma Assert (Choice_Table'First = 0);
285
 
286
      if Choice_Table'Last = 0 then
287
         if not Others_Present then
288
            Issue_Msg (Bounds_Lo, Bounds_Hi);
289
         end if;
290
 
291
         return;
292
      end if;
293
 
294
      Sorting.Sort (Positive (Choice_Table'Last));
295
 
296
      Lo      := Expr_Value (Choice_Table (1).Lo);
297
      Hi      := Expr_Value (Choice_Table (1).Hi);
298
      Prev_Hi := Hi;
299
 
300
      if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
301
         Issue_Msg (Bounds_Lo, Lo - 1);
302
 
303
         --  If values are missing outside of the subtype, add explanation.
304
         --  No additional message if only one value is missing.
305
 
306
         if Expr_Value (Bounds_Lo) < Lo - 1 then
307
            Explain_Non_Static_Bound;
308
         end if;
309
      end if;
310
 
311
      for J in 2 .. Choice_Table'Last loop
312
         Lo := Expr_Value (Choice_Table (J).Lo);
313
         Hi := Expr_Value (Choice_Table (J).Hi);
314
 
315
         if Lo <= Prev_Hi then
316
            Choice := Choice_Table (J).Node;
317
 
318
            --  Find first previous choice that overlaps
319
 
320
            for K in 1 .. J - 1 loop
321
               if Lo <= Expr_Value (Choice_Table (K).Hi) then
322
                  Prev_Choice := Choice_Table (K).Node;
323
                  exit;
324
               end if;
325
            end loop;
326
 
327
            if Sloc (Prev_Choice) <= Sloc (Choice) then
328
               Error_Msg_Sloc := Sloc (Prev_Choice);
329
               Error_Msg_N ("duplication of choice value#", Choice);
330
            else
331
               Error_Msg_Sloc := Sloc (Choice);
332
               Error_Msg_N ("duplication of choice value#", Prev_Choice);
333
            end if;
334
 
335
         elsif not Others_Present and then Lo /= Prev_Hi + 1 then
336
            Issue_Msg (Prev_Hi + 1, Lo - 1);
337
         end if;
338
 
339
         if Hi > Prev_Hi then
340
            Prev_Hi := Hi;
341
         end if;
342
      end loop;
343
 
344
      if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
345
         Issue_Msg (Hi + 1, Bounds_Hi);
346
 
347
         if Expr_Value (Bounds_Hi) > Hi + 1 then
348
            Explain_Non_Static_Bound;
349
         end if;
350
      end if;
351
   end Check_Choices;
352
 
353
   ------------------
354
   -- Choice_Image --
355
   ------------------
356
 
357
   function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
358
      Rtp : constant Entity_Id := Root_Type (Ctype);
359
      Lit : Entity_Id;
360
      C   : Int;
361
 
362
   begin
363
      --  For character, or wide [wide] character. If 7-bit ASCII graphic
364
      --  range, then build and return appropriate character literal name
365
 
366
      if Is_Standard_Character_Type (Ctype) then
367
         C := UI_To_Int (Value);
368
 
369
         if C in 16#20# .. 16#7E# then
370
            Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
371
            return Name_Find;
372
         end if;
373
 
374
      --  For user defined enumeration type, find enum/char literal
375
 
376
      else
377
         Lit := First_Literal (Rtp);
378
 
379
         for J in 1 .. UI_To_Int (Value) loop
380
            Next_Literal (Lit);
381
         end loop;
382
 
383
         --  If enumeration literal, just return its value
384
 
385
         if Nkind (Lit) = N_Defining_Identifier then
386
            return Chars (Lit);
387
 
388
         --  For character literal, get the name and use it if it is
389
         --  for a 7-bit ASCII graphic character in 16#20#..16#7E#.
390
 
391
         else
392
            Get_Decoded_Name_String (Chars (Lit));
393
 
394
            if Name_Len = 3
395
              and then Name_Buffer (2) in
396
                Character'Val (16#20#) .. Character'Val (16#7E#)
397
            then
398
               return Chars (Lit);
399
            end if;
400
         end if;
401
      end if;
402
 
403
      --  If we fall through, we have a character literal which is not in
404
      --  the 7-bit ASCII graphic set. For such cases, we construct the
405
      --  name "type'val(nnn)" where type is the choice type, and nnn is
406
      --  the pos value passed as an argument to Choice_Image.
407
 
408
      Get_Name_String (Chars (First_Subtype (Ctype)));
409
 
410
      Add_Str_To_Name_Buffer ("'val(");
411
      UI_Image (Value);
412
      Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
413
      Add_Char_To_Name_Buffer (')');
414
      return Name_Find;
415
   end Choice_Image;
416
 
417
   --------------------------
418
   -- Expand_Others_Choice --
419
   --------------------------
420
 
421
   procedure Expand_Others_Choice
422
     (Case_Table    : Choice_Table_Type;
423
      Others_Choice : Node_Id;
424
      Choice_Type   : Entity_Id)
425
   is
426
      Loc         : constant Source_Ptr := Sloc (Others_Choice);
427
      Choice_List : constant List_Id    := New_List;
428
      Choice      : Node_Id;
429
      Exp_Lo      : Node_Id;
430
      Exp_Hi      : Node_Id;
431
      Hi          : Uint;
432
      Lo          : Uint;
433
      Previous_Hi : Uint;
434
 
435
      function Build_Choice (Value1, Value2 : Uint) return Node_Id;
436
      --  Builds a node representing the missing choices given by the
437
      --  Value1 and Value2. A N_Range node is built if there is more than
438
      --  one literal value missing. Otherwise a single N_Integer_Literal,
439
      --  N_Identifier or N_Character_Literal is built depending on what
440
      --  Choice_Type is.
441
 
442
      function Lit_Of (Value : Uint) return Node_Id;
443
      --  Returns the Node_Id for the enumeration literal corresponding to the
444
      --  position given by Value within the enumeration type Choice_Type.
445
 
446
      ------------------
447
      -- Build_Choice --
448
      ------------------
449
 
450
      function Build_Choice (Value1, Value2 : Uint) return Node_Id is
451
         Lit_Node : Node_Id;
452
         Lo, Hi   : Node_Id;
453
 
454
      begin
455
         --  If there is only one choice value missing between Value1 and
456
         --  Value2, build an integer or enumeration literal to represent it.
457
 
458
         if (Value2 - Value1) = 0 then
459
            if Is_Integer_Type (Choice_Type) then
460
               Lit_Node := Make_Integer_Literal (Loc, Value1);
461
               Set_Etype (Lit_Node, Choice_Type);
462
            else
463
               Lit_Node := Lit_Of (Value1);
464
            end if;
465
 
466
         --  Otherwise is more that one choice value that is missing between
467
         --  Value1 and Value2, therefore build a N_Range node of either
468
         --  integer or enumeration literals.
469
 
470
         else
471
            if Is_Integer_Type (Choice_Type) then
472
               Lo := Make_Integer_Literal (Loc, Value1);
473
               Set_Etype (Lo, Choice_Type);
474
               Hi := Make_Integer_Literal (Loc, Value2);
475
               Set_Etype (Hi, Choice_Type);
476
               Lit_Node :=
477
                 Make_Range (Loc,
478
                   Low_Bound  => Lo,
479
                   High_Bound => Hi);
480
 
481
            else
482
               Lit_Node :=
483
                 Make_Range (Loc,
484
                   Low_Bound  => Lit_Of (Value1),
485
                   High_Bound => Lit_Of (Value2));
486
            end if;
487
         end if;
488
 
489
         return Lit_Node;
490
      end Build_Choice;
491
 
492
      ------------
493
      -- Lit_Of --
494
      ------------
495
 
496
      function Lit_Of (Value : Uint) return Node_Id is
497
         Lit : Entity_Id;
498
 
499
      begin
500
         --  In the case where the literal is of type Character, there needs
501
         --  to be some special handling since there is no explicit chain
502
         --  of literals to search. Instead, a N_Character_Literal node
503
         --  is created with the appropriate Char_Code and Chars fields.
504
 
505
         if Is_Standard_Character_Type (Choice_Type) then
506
            Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
507
            Lit := New_Node (N_Character_Literal, Loc);
508
            Set_Chars (Lit, Name_Find);
509
            Set_Char_Literal_Value (Lit, Value);
510
            Set_Etype (Lit, Choice_Type);
511
            Set_Is_Static_Expression (Lit, True);
512
            return Lit;
513
 
514
         --  Otherwise, iterate through the literals list of Choice_Type
515
         --  "Value" number of times until the desired literal is reached
516
         --  and then return an occurrence of it.
517
 
518
         else
519
            Lit := First_Literal (Choice_Type);
520
            for J in 1 .. UI_To_Int (Value) loop
521
               Next_Literal (Lit);
522
            end loop;
523
 
524
            return New_Occurrence_Of (Lit, Loc);
525
         end if;
526
      end Lit_Of;
527
 
528
   --  Start of processing for Expand_Others_Choice
529
 
530
   begin
531
      if Case_Table'Last = 0 then
532
 
533
         --  Special case: only an others case is present.
534
         --  The others case covers the full range of the type.
535
 
536
         if Is_Static_Subtype (Choice_Type) then
537
            Choice := New_Occurrence_Of (Choice_Type, Loc);
538
         else
539
            Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
540
         end if;
541
 
542
         Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
543
         return;
544
      end if;
545
 
546
      --  Establish the bound values for the choice depending upon whether
547
      --  the type of the case statement is static or not.
548
 
549
      if Is_OK_Static_Subtype (Choice_Type) then
550
         Exp_Lo := Type_Low_Bound (Choice_Type);
551
         Exp_Hi := Type_High_Bound (Choice_Type);
552
      else
553
         Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
554
         Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
555
      end if;
556
 
557
      Lo := Expr_Value (Case_Table (1).Lo);
558
      Hi := Expr_Value (Case_Table (1).Hi);
559
      Previous_Hi := Expr_Value (Case_Table (1).Hi);
560
 
561
      --  Build the node for any missing choices that are smaller than any
562
      --  explicit choices given in the case.
563
 
564
      if Expr_Value (Exp_Lo) < Lo then
565
         Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
566
      end if;
567
 
568
      --  Build the nodes representing any missing choices that lie between
569
      --  the explicit ones given in the case.
570
 
571
      for J in 2 .. Case_Table'Last loop
572
         Lo := Expr_Value (Case_Table (J).Lo);
573
         Hi := Expr_Value (Case_Table (J).Hi);
574
 
575
         if Lo /= (Previous_Hi + 1) then
576
            Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
577
         end if;
578
 
579
         Previous_Hi := Hi;
580
      end loop;
581
 
582
      --  Build the node for any missing choices that are greater than any
583
      --  explicit choices given in the case.
584
 
585
      if Expr_Value (Exp_Hi) > Hi then
586
         Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
587
      end if;
588
 
589
      Set_Others_Discrete_Choices (Others_Choice, Choice_List);
590
 
591
      --  Warn on null others list if warning option set
592
 
593
      if Warn_On_Redundant_Constructs
594
        and then Comes_From_Source (Others_Choice)
595
        and then Is_Empty_List (Choice_List)
596
      then
597
         Error_Msg_N ("?OTHERS choice is redundant", Others_Choice);
598
         Error_Msg_N ("\previous choices cover all values", Others_Choice);
599
      end if;
600
   end Expand_Others_Choice;
601
 
602
   -----------
603
   -- No_OP --
604
   -----------
605
 
606
   procedure No_OP (C : Node_Id) is
607
      pragma Warnings (Off, C);
608
   begin
609
      null;
610
   end No_OP;
611
 
612
   --------------------------------
613
   -- Generic_Choices_Processing --
614
   --------------------------------
615
 
616
   package body Generic_Choices_Processing is
617
 
618
      --  The following type is used to gather the entries for the choice
619
      --  table, so that we can then allocate the right length.
620
 
621
      type Link;
622
      type Link_Ptr is access all Link;
623
 
624
      type Link is record
625
         Val : Choice_Bounds;
626
         Nxt : Link_Ptr;
627
      end record;
628
 
629
      procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
630
 
631
      ---------------------
632
      -- Analyze_Choices --
633
      ---------------------
634
 
635
      procedure Analyze_Choices
636
        (N              : Node_Id;
637
         Subtyp         : Entity_Id;
638
         Raises_CE      : out Boolean;
639
         Others_Present : out Boolean)
640
      is
641
         E : Entity_Id;
642
 
643
         Enode : Node_Id;
644
         --  This is where we post error messages for bounds out of range
645
 
646
         Choice_List : Link_Ptr := null;
647
         --  Gather list of choices
648
 
649
         Num_Choices : Nat := 0;
650
         --  Number of entries in Choice_List
651
 
652
         Choice_Type : constant Entity_Id := Base_Type (Subtyp);
653
         --  The actual type against which the discrete choices are resolved.
654
         --  Note that this type is always the base type not the subtype of the
655
         --  ruling expression, index or discriminant.
656
 
657
         Bounds_Type : Entity_Id;
658
         --  The type from which are derived the bounds of the values covered
659
         --  by the discrete choices (see 3.8.1 (4)). If a discrete choice
660
         --  specifies a value outside of these bounds we have an error.
661
 
662
         Bounds_Lo : Uint;
663
         Bounds_Hi : Uint;
664
         --  The actual bounds of the above type
665
 
666
         Expected_Type : Entity_Id;
667
         --  The expected type of each choice. Equal to Choice_Type, except if
668
         --  the expression is universal, in which case the choices can be of
669
         --  any integer type.
670
 
671
         Alt : Node_Id;
672
         --  A case statement alternative or a variant in a record type
673
         --  declaration.
674
 
675
         Choice : Node_Id;
676
         Kind   : Node_Kind;
677
         --  The node kind of the current Choice
678
 
679
         Delete_Choice : Boolean;
680
         --  Set to True to delete the current choice
681
 
682
         Others_Choice : Node_Id := Empty;
683
         --  Remember others choice if it is present (empty otherwise)
684
 
685
         procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
686
         --  Checks the validity of the bounds of a choice. When the bounds
687
         --  are static and no error occurred the bounds are collected for
688
         --  later entry into the choices table so that they can be sorted
689
         --  later on.
690
 
691
         -----------
692
         -- Check --
693
         -----------
694
 
695
         procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
696
            Lo_Val : Uint;
697
            Hi_Val : Uint;
698
 
699
         begin
700
            --  First check if an error was already detected on either bounds
701
 
702
            if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
703
               return;
704
 
705
            --  Do not insert non static choices in the table to be sorted
706
 
707
            elsif not Is_Static_Expression (Lo)
708
              or else not Is_Static_Expression (Hi)
709
            then
710
               Process_Non_Static_Choice (Choice);
711
               return;
712
 
713
            --  Ignore range which raise constraint error
714
 
715
            elsif Raises_Constraint_Error (Lo)
716
              or else Raises_Constraint_Error (Hi)
717
            then
718
               Raises_CE := True;
719
               return;
720
 
721
            --  Otherwise we have an OK static choice
722
 
723
            else
724
               Lo_Val := Expr_Value (Lo);
725
               Hi_Val := Expr_Value (Hi);
726
 
727
               --  Do not insert null ranges in the choices table
728
 
729
               if Lo_Val > Hi_Val then
730
                  Process_Empty_Choice (Choice);
731
                  return;
732
               end if;
733
            end if;
734
 
735
            --  Check for low bound out of range
736
 
737
            if Lo_Val < Bounds_Lo then
738
 
739
               --  If the choice is an entity name, then it is a type, and we
740
               --  want to post the message on the reference to this entity.
741
               --  Otherwise post it on the lower bound of the range.
742
 
743
               if Is_Entity_Name (Choice) then
744
                  Enode := Choice;
745
               else
746
                  Enode := Lo;
747
               end if;
748
 
749
               --  Specialize message for integer/enum type
750
 
751
               if Is_Integer_Type (Bounds_Type) then
752
                  Error_Msg_Uint_1 := Bounds_Lo;
753
                  Error_Msg_N ("minimum allowed choice value is^", Enode);
754
               else
755
                  Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
756
                  Error_Msg_N ("minimum allowed choice value is%", Enode);
757
               end if;
758
            end if;
759
 
760
            --  Check for high bound out of range
761
 
762
            if Hi_Val > Bounds_Hi then
763
 
764
               --  If the choice is an entity name, then it is a type, and we
765
               --  want to post the message on the reference to this entity.
766
               --  Otherwise post it on the upper bound of the range.
767
 
768
               if Is_Entity_Name (Choice) then
769
                  Enode := Choice;
770
               else
771
                  Enode := Hi;
772
               end if;
773
 
774
               --  Specialize message for integer/enum type
775
 
776
               if Is_Integer_Type (Bounds_Type) then
777
                  Error_Msg_Uint_1 := Bounds_Hi;
778
                  Error_Msg_N ("maximum allowed choice value is^", Enode);
779
               else
780
                  Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
781
                  Error_Msg_N ("maximum allowed choice value is%", Enode);
782
               end if;
783
            end if;
784
 
785
            --  Collect bounds in the list
786
 
787
            --  Note: we still store the bounds, even if they are out of range,
788
            --  since this may prevent unnecessary cascaded errors for values
789
            --  that are covered by such an excessive range.
790
 
791
            Choice_List :=
792
              new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
793
            Num_Choices := Num_Choices + 1;
794
         end Check;
795
 
796
      --  Start of processing for Analyze_Choices
797
 
798
      begin
799
         Raises_CE      := False;
800
         Others_Present := False;
801
 
802
         --  If Subtyp is not a static subtype Ada 95 requires then we use the
803
         --  bounds of its base type to determine the values covered by the
804
         --  discrete choices.
805
 
806
         if Is_OK_Static_Subtype (Subtyp) then
807
            Bounds_Type := Subtyp;
808
         else
809
            Bounds_Type := Choice_Type;
810
         end if;
811
 
812
         --  Obtain static bounds of type, unless this is a generic formal
813
         --  discrete type for which all choices will be non-static.
814
 
815
         if not Is_Generic_Type (Root_Type (Bounds_Type))
816
           or else Ekind (Bounds_Type) /= E_Enumeration_Type
817
         then
818
            Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
819
            Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
820
         end if;
821
 
822
         if Choice_Type = Universal_Integer then
823
            Expected_Type := Any_Integer;
824
         else
825
            Expected_Type := Choice_Type;
826
         end if;
827
 
828
         --  Now loop through the case alternatives or record variants
829
 
830
         Alt := First (Get_Alternatives (N));
831
         while Present (Alt) loop
832
 
833
            --  If pragma, just analyze it
834
 
835
            if Nkind (Alt) = N_Pragma then
836
               Analyze (Alt);
837
 
838
            --  Otherwise check each choice against its base type
839
 
840
            else
841
               Choice := First (Get_Choices (Alt));
842
               while Present (Choice) loop
843
                  Delete_Choice := False;
844
                  Analyze (Choice);
845
                  Kind := Nkind (Choice);
846
 
847
                  --  Choice is a Range
848
 
849
                  if Kind = N_Range
850
                    or else (Kind = N_Attribute_Reference
851
                              and then Attribute_Name (Choice) = Name_Range)
852
                  then
853
                     Resolve (Choice, Expected_Type);
854
                     Check (Choice, Low_Bound (Choice), High_Bound (Choice));
855
 
856
                  --  Choice is a subtype name
857
 
858
                  elsif Is_Entity_Name (Choice)
859
                    and then Is_Type (Entity (Choice))
860
                  then
861
                     if not Covers (Expected_Type, Etype (Choice)) then
862
                        Wrong_Type (Choice, Choice_Type);
863
 
864
                     else
865
                        E := Entity (Choice);
866
 
867
                        --  Case of predicated subtype
868
 
869
                        if Has_Predicates (E) then
870
 
871
                           --  Use of non-static predicate is an error
872
 
873
                           if not Is_Discrete_Type (E)
874
                             or else No (Static_Predicate (E))
875
                           then
876
                              Bad_Predicated_Subtype_Use
877
                                ("cannot use subtype& with non-static "
878
                                 & "predicate as case alternative", Choice, E);
879
 
880
                              --  Static predicate case
881
 
882
                           else
883
                              declare
884
                                 Copy : constant List_Id := Empty_List;
885
                                 P    : Node_Id;
886
                                 C    : Node_Id;
887
 
888
                              begin
889
                                 --  Loop through entries in predicate list,
890
                                 --  converting to choices. Note that if the
891
                                 --  list is empty, corresponding to a False
892
                                 --  predicate, then no choices are inserted.
893
 
894
                                 P := First (Static_Predicate (E));
895
                                 while Present (P) loop
896
                                    C := New_Copy (P);
897
                                    Set_Sloc (C, Sloc (Choice));
898
                                    Append_To (Copy, C);
899
                                    Next (P);
900
                                 end loop;
901
 
902
                                 Insert_List_After (Choice, Copy);
903
                                 Delete_Choice := True;
904
                              end;
905
                           end if;
906
 
907
                        --  Not predicated subtype case
908
 
909
                        elsif not Is_Static_Subtype (E) then
910
                           Process_Non_Static_Choice (Choice);
911
                        else
912
                           Check
913
                             (Choice, Type_Low_Bound (E), Type_High_Bound (E));
914
                        end if;
915
                     end if;
916
 
917
                  --  Choice is a subtype indication
918
 
919
                  elsif Kind = N_Subtype_Indication then
920
                     Resolve_Discrete_Subtype_Indication
921
                       (Choice, Expected_Type);
922
 
923
                     --  Here for other than predicated subtype case
924
 
925
                     if Etype (Choice) /= Any_Type then
926
                        declare
927
                           C : constant Node_Id := Constraint (Choice);
928
                           R : constant Node_Id := Range_Expression (C);
929
                           L : constant Node_Id := Low_Bound (R);
930
                           H : constant Node_Id := High_Bound (R);
931
 
932
                        begin
933
                           E := Entity (Subtype_Mark (Choice));
934
 
935
                           if not Is_Static_Subtype (E) then
936
                              Process_Non_Static_Choice (Choice);
937
 
938
                           else
939
                              if Is_OK_Static_Expression (L)
940
                                and then Is_OK_Static_Expression (H)
941
                              then
942
                                 if Expr_Value (L) > Expr_Value (H) then
943
                                    Process_Empty_Choice (Choice);
944
                                 else
945
                                    if Is_Out_Of_Range (L, E) then
946
                                       Apply_Compile_Time_Constraint_Error
947
                                         (L, "static value out of range",
948
                                          CE_Range_Check_Failed);
949
                                    end if;
950
 
951
                                    if Is_Out_Of_Range (H, E) then
952
                                       Apply_Compile_Time_Constraint_Error
953
                                         (H, "static value out of range",
954
                                          CE_Range_Check_Failed);
955
                                    end if;
956
                                 end if;
957
                              end if;
958
 
959
                              Check (Choice, L, H);
960
                           end if;
961
                        end;
962
                     end if;
963
 
964
                  --  The others choice is only allowed for the last
965
                  --  alternative and as its only choice.
966
 
967
                  elsif Kind = N_Others_Choice then
968
                     if not (Choice = First (Get_Choices (Alt))
969
                             and then Choice = Last (Get_Choices (Alt))
970
                             and then Alt = Last (Get_Alternatives (N)))
971
                     then
972
                        Error_Msg_N
973
                          ("the choice OTHERS must appear alone and last",
974
                           Choice);
975
                        return;
976
                     end if;
977
 
978
                     Others_Present := True;
979
                     Others_Choice  := Choice;
980
 
981
                  --  Only other possibility is an expression
982
 
983
                  else
984
                     Resolve (Choice, Expected_Type);
985
                     Check (Choice, Choice, Choice);
986
                  end if;
987
 
988
                  --  Move to next choice, deleting the current one if the
989
                  --  flag requesting this deletion is set True.
990
 
991
                  declare
992
                     C : constant Node_Id := Choice;
993
                  begin
994
                     Next (Choice);
995
 
996
                     if Delete_Choice then
997
                        Remove (C);
998
                     end if;
999
                  end;
1000
               end loop;
1001
 
1002
               Process_Associated_Node (Alt);
1003
            end if;
1004
 
1005
            Next (Alt);
1006
         end loop;
1007
 
1008
         --  Now we can create the Choice_Table, since we know how long
1009
         --  it needs to be so we can allocate exactly the right length.
1010
 
1011
         declare
1012
            Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1013
 
1014
         begin
1015
            --  Now copy the items we collected in the linked list into this
1016
            --  newly allocated table (leave entry 0 unused for sorting).
1017
 
1018
            declare
1019
               T : Link_Ptr;
1020
            begin
1021
               for J in 1 .. Num_Choices loop
1022
                  T := Choice_List;
1023
                  Choice_List := T.Nxt;
1024
                  Choice_Table (J) := T.Val;
1025
                  Free (T);
1026
               end loop;
1027
            end;
1028
 
1029
            Check_Choices
1030
              (Choice_Table,
1031
               Bounds_Type,
1032
               Subtyp,
1033
               Others_Present or else (Choice_Type = Universal_Integer),
1034
               N);
1035
 
1036
            --  If no others choice we are all done, otherwise we have one more
1037
            --  step, which is to set the Others_Discrete_Choices field of the
1038
            --  others choice (to contain all otherwise unspecified choices).
1039
            --  Skip this if CE is known to be raised.
1040
 
1041
            if Others_Present and not Raises_CE then
1042
               Expand_Others_Choice
1043
                 (Case_Table    => Choice_Table,
1044
                  Others_Choice => Others_Choice,
1045
                  Choice_Type   => Bounds_Type);
1046
            end if;
1047
         end;
1048
      end Analyze_Choices;
1049
 
1050
   end Generic_Choices_Processing;
1051
 
1052
end Sem_Case;

powered by: WebSVN 2.1.0

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