gcc/ada/sem_case.adb

   1 ------------------------------------------------------------------------------
   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;