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             Prev_Choice := Choice_Table (J - 1).Node;
 317             Choice      := Choice_Table (J).Node;
 318
 319             if Sloc (Prev_Choice) <= Sloc (Choice) then
 320                Error_Msg_Sloc := Sloc (Prev_Choice);
 321                Error_Msg_N ("duplication of choice value#", Choice);
 322             else
 323                Error_Msg_Sloc := Sloc (Choice);
 324                Error_Msg_N ("duplication of choice value#", Prev_Choice);
 325             end if;
 326
 327          elsif not Others_Present and then Lo /= Prev_Hi + 1 then
 328             Issue_Msg (Prev_Hi + 1, Lo - 1);
 329          end if;
 330
 331          if Hi > Prev_Hi then
 332             Prev_Hi := Hi;
 333          end if;
 334       end loop;
 335
 336       if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
 337          Issue_Msg (Hi + 1, Bounds_Hi);
 338
 339          if Expr_Value (Bounds_Hi) > Hi + 1 then
 340             Explain_Non_Static_Bound;
 341          end if;
 342       end if;
 343    end Check_Choices;
 344
 345    ------------------
 346    -- Choice_Image --
 347    ------------------
 348
 349    function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
 350       Rtp : constant Entity_Id := Root_Type (Ctype);
 351       Lit : Entity_Id;
 352       C   : Int;
 353
 354    begin
 355       --  For character, or wide [wide] character. If 7-bit ASCII graphic
 356       --  range, then build and return appropriate character literal name
 357
 358       if Is_Standard_Character_Type (Ctype) then
 359          C := UI_To_Int (Value);
 360
 361          if C in 16#20# .. 16#7E# then
 362             Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
 363             return Name_Find;
 364          end if;
 365
 366       --  For user defined enumeration type, find enum/char literal
 367
 368       else
 369          Lit := First_Literal (Rtp);
 370
 371          for J in 1 .. UI_To_Int (Value) loop
 372             Next_Literal (Lit);
 373          end loop;
 374
 375          --  If enumeration literal, just return its value
 376
 377          if Nkind (Lit) = N_Defining_Identifier then
 378             return Chars (Lit);
 379
 380          --  For character literal, get the name and use it if it is
 381          --  for a 7-bit ASCII graphic character in 16#20#..16#7E#.
 382
 383          else
 384             Get_Decoded_Name_String (Chars (Lit));
 385
 386             if Name_Len = 3
 387               and then Name_Buffer (2) in
 388                 Character'Val (16#20#) .. Character'Val (16#7E#)
 389             then
 390                return Chars (Lit);
 391             end if;
 392          end if;
 393       end if;
 394
 395       --  If we fall through, we have a character literal which is not in
 396       --  the 7-bit ASCII graphic set. For such cases, we construct the
 397       --  name "type'val(nnn)" where type is the choice type, and nnn is
 398       --  the pos value passed as an argument to Choice_Image.
 399
 400       Get_Name_String (Chars (First_Subtype (Ctype)));
 401
 402       Add_Str_To_Name_Buffer ("'val(");
 403       UI_Image (Value);
 404       Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 405       Add_Char_To_Name_Buffer (')');
 406       return Name_Find;
 407    end Choice_Image;
 408
 409    --------------------------
 410    -- Expand_Others_Choice --
 411    --------------------------
 412
 413    procedure Expand_Others_Choice
 414      (Case_Table    : Choice_Table_Type;
 415       Others_Choice : Node_Id;
 416       Choice_Type   : Entity_Id)
 417    is
 418       Loc         : constant Source_Ptr := Sloc (Others_Choice);
 419       Choice_List : constant List_Id    := New_List;
 420       Choice      : Node_Id;
 421       Exp_Lo      : Node_Id;
 422       Exp_Hi      : Node_Id;
 423       Hi          : Uint;
 424       Lo          : Uint;
 425       Previous_Hi : Uint;
 426
 427       function Build_Choice (Value1, Value2 : Uint) return Node_Id;
 428       --  Builds a node representing the missing choices given by the
 429       --  Value1 and Value2. A N_Range node is built if there is more than
 430       --  one literal value missing. Otherwise a single N_Integer_Literal,
 431       --  N_Identifier or N_Character_Literal is built depending on what
 432       --  Choice_Type is.
 433
 434       function Lit_Of (Value : Uint) return Node_Id;
 435       --  Returns the Node_Id for the enumeration literal corresponding to the
 436       --  position given by Value within the enumeration type Choice_Type.
 437
 438       ------------------
 439       -- Build_Choice --
 440       ------------------
 441
 442       function Build_Choice (Value1, Value2 : Uint) return Node_Id is
 443          Lit_Node : Node_Id;
 444          Lo, Hi   : Node_Id;
 445
 446       begin
 447          --  If there is only one choice value missing between Value1 and
 448          --  Value2, build an integer or enumeration literal to represent it.
 449
 450          if (Value2 - Value1) = 0 then
 451             if Is_Integer_Type (Choice_Type) then
 452                Lit_Node := Make_Integer_Literal (Loc, Value1);
 453                Set_Etype (Lit_Node, Choice_Type);
 454             else
 455                Lit_Node := Lit_Of (Value1);
 456             end if;
 457
 458          --  Otherwise is more that one choice value that is missing between
 459          --  Value1 and Value2, therefore build a N_Range node of either
 460          --  integer or enumeration literals.
 461
 462          else
 463             if Is_Integer_Type (Choice_Type) then
 464                Lo := Make_Integer_Literal (Loc, Value1);
 465                Set_Etype (Lo, Choice_Type);
 466                Hi := Make_Integer_Literal (Loc, Value2);
 467                Set_Etype (Hi, Choice_Type);
 468                Lit_Node :=
 469                  Make_Range (Loc,
 470                    Low_Bound  => Lo,
 471                    High_Bound => Hi);
 472
 473             else
 474                Lit_Node :=
 475                  Make_Range (Loc,
 476                    Low_Bound  => Lit_Of (Value1),
 477                    High_Bound => Lit_Of (Value2));
 478             end if;
 479          end if;
 480
 481          return Lit_Node;
 482       end Build_Choice;
 483
 484       ------------
 485       -- Lit_Of --
 486       ------------
 487
 488       function Lit_Of (Value : Uint) return Node_Id is
 489          Lit : Entity_Id;
 490
 491       begin
 492          --  In the case where the literal is of type Character, there needs
 493          --  to be some special handling since there is no explicit chain
 494          --  of literals to search. Instead, a N_Character_Literal node
 495          --  is created with the appropriate Char_Code and Chars fields.
 496
 497          if Is_Standard_Character_Type (Choice_Type) then
 498             Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
 499             Lit := New_Node (N_Character_Literal, Loc);
 500             Set_Chars (Lit, Name_Find);
 501             Set_Char_Literal_Value (Lit, Value);
 502             Set_Etype (Lit, Choice_Type);
 503             Set_Is_Static_Expression (Lit, True);
 504             return Lit;
 505
 506          --  Otherwise, iterate through the literals list of Choice_Type
 507          --  "Value" number of times until the desired literal is reached
 508          --  and then return an occurrence of it.
 509
 510          else
 511             Lit := First_Literal (Choice_Type);
 512             for J in 1 .. UI_To_Int (Value) loop
 513                Next_Literal (Lit);
 514             end loop;
 515
 516             return New_Occurrence_Of (Lit, Loc);
 517          end if;
 518       end Lit_Of;
 519
 520    --  Start of processing for Expand_Others_Choice
 521
 522    begin
 523       if Case_Table'Last = 0 then
 524
 525          --  Special case: only an others case is present.
 526          --  The others case covers the full range of the type.
 527
 528          if Is_Static_Subtype (Choice_Type) then
 529             Choice := New_Occurrence_Of (Choice_Type, Loc);
 530          else
 531             Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
 532          end if;
 533
 534          Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
 535          return;
 536       end if;
 537
 538       --  Establish the bound values for the choice depending upon whether
 539       --  the type of the case statement is static or not.
 540
 541       if Is_OK_Static_Subtype (Choice_Type) then
 542          Exp_Lo := Type_Low_Bound (Choice_Type);
 543          Exp_Hi := Type_High_Bound (Choice_Type);
 544       else
 545          Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
 546          Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
 547       end if;
 548
 549       Lo := Expr_Value (Case_Table (1).Lo);
 550       Hi := Expr_Value (Case_Table (1).Hi);
 551       Previous_Hi := Expr_Value (Case_Table (1).Hi);
 552
 553       --  Build the node for any missing choices that are smaller than any
 554       --  explicit choices given in the case.
 555
 556       if Expr_Value (Exp_Lo) < Lo then
 557          Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
 558       end if;
 559
 560       --  Build the nodes representing any missing choices that lie between
 561       --  the explicit ones given in the case.
 562
 563       for J in 2 .. Case_Table'Last loop
 564          Lo := Expr_Value (Case_Table (J).Lo);
 565          Hi := Expr_Value (Case_Table (J).Hi);
 566
 567          if Lo /= (Previous_Hi + 1) then
 568             Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
 569          end if;
 570
 571          Previous_Hi := Hi;
 572       end loop;
 573
 574       --  Build the node for any missing choices that are greater than any
 575       --  explicit choices given in the case.
 576
 577       if Expr_Value (Exp_Hi) > Hi then
 578          Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
 579       end if;
 580
 581       Set_Others_Discrete_Choices (Others_Choice, Choice_List);
 582
 583       --  Warn on null others list if warning option set
 584
 585       if Warn_On_Redundant_Constructs
 586         and then Comes_From_Source (Others_Choice)
 587         and then Is_Empty_List (Choice_List)
 588       then
 589          Error_Msg_N ("?OTHERS choice is redundant", Others_Choice);
 590          Error_Msg_N ("\previous choices cover all values", Others_Choice);
 591       end if;
 592    end Expand_Others_Choice;
 593
 594    -----------
 595    -- No_OP --
 596    -----------
 597
 598    procedure No_OP (C : Node_Id) is
 599       pragma Warnings (Off, C);
 600    begin
 601       null;
 602    end No_OP;
 603
 604    --------------------------------
 605    -- Generic_Choices_Processing --
 606    --------------------------------
 607
 608    package body Generic_Choices_Processing is
 609
 610       --  The following type is used to gather the entries for the choice
 611       --  table, so that we can then allocate the right length.
 612
 613       type Link;
 614       type Link_Ptr is access all Link;
 615
 616       type Link is record
 617          Val : Choice_Bounds;
 618          Nxt : Link_Ptr;
 619       end record;
 620
 621       procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
 622
 623       ---------------------
 624       -- Analyze_Choices --
 625       ---------------------
 626
 627       procedure Analyze_Choices
 628         (N              : Node_Id;
 629          Subtyp         : Entity_Id;
 630          Raises_CE      : out Boolean;
 631          Others_Present : out Boolean)
 632       is
 633          E : Entity_Id;
 634
 635          Enode : Node_Id;
 636          --  This is where we post error messages for bounds out of range
 637
 638          Choice_List : Link_Ptr := null;
 639          --  Gather list of choices
 640
 641          Num_Choices : Nat := 0;
 642          --  Number of entries in Choice_List
 643
 644          Choice_Type : constant Entity_Id := Base_Type (Subtyp);
 645          --  The actual type against which the discrete choices are resolved.
 646          --  Note that this type is always the base type not the subtype of the
 647          --  ruling expression, index or discriminant.
 648
 649          Bounds_Type : Entity_Id;
 650          --  The type from which are derived the bounds of the values covered
 651          --  by the discrete choices (see 3.8.1 (4)). If a discrete choice
 652          --  specifies a value outside of these bounds we have an error.
 653
 654          Bounds_Lo : Uint;
 655          Bounds_Hi : Uint;
 656          --  The actual bounds of the above type
 657
 658          Expected_Type : Entity_Id;
 659          --  The expected type of each choice. Equal to Choice_Type, except if
 660          --  the expression is universal, in which case the choices can be of
 661          --  any integer type.
 662
 663          Alt : Node_Id;
 664          --  A case statement alternative or a variant in a record type
 665          --  declaration.
 666
 667          Choice : Node_Id;
 668          Kind   : Node_Kind;
 669          --  The node kind of the current Choice
 670
 671          Delete_Choice : Boolean;
 672          --  Set to True to delete the current choice
 673
 674          Others_Choice : Node_Id := Empty;
 675          --  Remember others choice if it is present (empty otherwise)
 676
 677          procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
 678          --  Checks the validity of the bounds of a choice. When the bounds
 679          --  are static and no error occurred the bounds are collected for
 680          --  later entry into the choices table so that they can be sorted
 681          --  later on.
 682
 683          -----------
 684          -- Check --
 685          -----------
 686
 687          procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
 688             Lo_Val : Uint;
 689             Hi_Val : Uint;
 690
 691          begin
 692             --  First check if an error was already detected on either bounds
 693
 694             if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
 695                return;
 696
 697             --  Do not insert non static choices in the table to be sorted
 698
 699             elsif not Is_Static_Expression (Lo)
 700               or else not Is_Static_Expression (Hi)
 701             then
 702                Process_Non_Static_Choice (Choice);
 703                return;
 704
 705             --  Ignore range which raise constraint error
 706
 707             elsif Raises_Constraint_Error (Lo)
 708               or else Raises_Constraint_Error (Hi)
 709             then
 710                Raises_CE := True;
 711                return;
 712
 713             --  Otherwise we have an OK static choice
 714
 715             else
 716                Lo_Val := Expr_Value (Lo);
 717                Hi_Val := Expr_Value (Hi);
 718
 719                --  Do not insert null ranges in the choices table
 720
 721                if Lo_Val > Hi_Val then
 722                   Process_Empty_Choice (Choice);
 723                   return;
 724                end if;
 725             end if;
 726
 727             --  Check for low bound out of range
 728
 729             if Lo_Val < Bounds_Lo then
 730
 731                --  If the choice is an entity name, then it is a type, and we
 732                --  want to post the message on the reference to this entity.
 733                --  Otherwise post it on the lower bound of the range.
 734
 735                if Is_Entity_Name (Choice) then
 736                   Enode := Choice;
 737                else
 738                   Enode := Lo;
 739                end if;
 740
 741                --  Specialize message for integer/enum type
 742
 743                if Is_Integer_Type (Bounds_Type) then
 744                   Error_Msg_Uint_1 := Bounds_Lo;
 745                   Error_Msg_N ("minimum allowed choice value is^", Enode);
 746                else
 747                   Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
 748                   Error_Msg_N ("minimum allowed choice value is%", Enode);
 749                end if;
 750             end if;
 751
 752             --  Check for high bound out of range
 753
 754             if Hi_Val > Bounds_Hi then
 755
 756                --  If the choice is an entity name, then it is a type, and we
 757                --  want to post the message on the reference to this entity.
 758                --  Otherwise post it on the upper bound of the range.
 759
 760                if Is_Entity_Name (Choice) then
 761                   Enode := Choice;
 762                else
 763                   Enode := Hi;
 764                end if;
 765
 766                --  Specialize message for integer/enum type
 767
 768                if Is_Integer_Type (Bounds_Type) then
 769                   Error_Msg_Uint_1 := Bounds_Hi;
 770                   Error_Msg_N ("maximum allowed choice value is^", Enode);
 771                else
 772                   Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
 773                   Error_Msg_N ("maximum allowed choice value is%", Enode);
 774                end if;
 775             end if;
 776
 777             --  Collect bounds in the list
 778
 779             --  Note: we still store the bounds, even if they are out of range,
 780             --  since this may prevent unnecessary cascaded errors for values
 781             --  that are covered by such an excessive range.
 782
 783             Choice_List :=
 784               new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
 785             Num_Choices := Num_Choices + 1;
 786          end Check;
 787
 788       --  Start of processing for Analyze_Choices
 789
 790       begin
 791          Raises_CE      := False;
 792          Others_Present := False;
 793
 794          --  If Subtyp is not a static subtype Ada 95 requires then we use the
 795          --  bounds of its base type to determine the values covered by the
 796          --  discrete choices.
 797
 798          if Is_OK_Static_Subtype (Subtyp) then
 799             Bounds_Type := Subtyp;
 800          else
 801             Bounds_Type := Choice_Type;
 802          end if;
 803
 804          --  Obtain static bounds of type, unless this is a generic formal
 805          --  discrete type for which all choices will be non-static.
 806
 807          if not Is_Generic_Type (Root_Type (Bounds_Type))
 808            or else Ekind (Bounds_Type) /= E_Enumeration_Type
 809          then
 810             Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
 811             Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
 812          end if;
 813
 814          if Choice_Type = Universal_Integer then
 815             Expected_Type := Any_Integer;
 816          else
 817             Expected_Type := Choice_Type;
 818          end if;
 819
 820          --  Now loop through the case alternatives or record variants
 821
 822          Alt := First (Get_Alternatives (N));
 823          while Present (Alt) loop
 824
 825             --  If pragma, just analyze it
 826
 827             if Nkind (Alt) = N_Pragma then
 828                Analyze (Alt);
 829
 830             --  Otherwise check each choice against its base type
 831
 832             else
 833                Choice := First (Get_Choices (Alt));
 834                while Present (Choice) loop
 835                   Delete_Choice := False;
 836                   Analyze (Choice);
 837                   Kind := Nkind (Choice);
 838
 839                   --  Choice is a Range
 840
 841                   if Kind = N_Range
 842                     or else (Kind = N_Attribute_Reference
 843                               and then Attribute_Name (Choice) = Name_Range)
 844                   then
 845                      Resolve (Choice, Expected_Type);
 846                      Check (Choice, Low_Bound (Choice), High_Bound (Choice));
 847
 848                   --  Choice is a subtype name
 849
 850                   elsif Is_Entity_Name (Choice)
 851                     and then Is_Type (Entity (Choice))
 852                   then
 853                      if not Covers (Expected_Type, Etype (Choice)) then
 854                         Wrong_Type (Choice, Choice_Type);
 855
 856                      else
 857                         E := Entity (Choice);
 858
 859                         --  Case of predicated subtype
 860
 861                         if Has_Predicates (E) then
 862
 863                            --  Use of non-static predicate is an error
 864
 865                            if not Is_Discrete_Type (E)
 866                              or else No (Static_Predicate (E))
 867                            then
 868                               Bad_Predicated_Subtype_Use
 869                                 ("cannot use subtype& with non-static "
 870                                  & "predicate as case alternative", Choice, E);
 871
 872                               --  Static predicate case
 873
 874                            else
 875                               declare
 876                                  Copy : constant List_Id := Empty_List;
 877                                  P    : Node_Id;
 878                                  C    : Node_Id;
 879
 880                               begin
 881                                  --  Loop through entries in predicate list,
 882                                  --  converting to choices. Note that if the
 883                                  --  list is empty, corresponding to a False
 884                                  --  predicate, then no choices are inserted.
 885
 886                                  P := First (Static_Predicate (E));
 887                                  while Present (P) loop
 888                                     C := New_Copy (P);
 889                                     Set_Sloc (C, Sloc (Choice));
 890                                     Append_To (Copy, C);
 891                                     Next (P);
 892                                  end loop;
 893
 894                                  Insert_List_After (Choice, Copy);
 895                                  Delete_Choice := True;
 896                               end;
 897                            end if;
 898
 899                         --  Not predicated subtype case
 900
 901                         elsif not Is_Static_Subtype (E) then
 902                            Process_Non_Static_Choice (Choice);
 903                         else
 904                            Check
 905                              (Choice, Type_Low_Bound (E), Type_High_Bound (E));
 906                         end if;
 907                      end if;
 908
 909                   --  Choice is a subtype indication
 910
 911                   elsif Kind = N_Subtype_Indication then
 912                      Resolve_Discrete_Subtype_Indication
 913                        (Choice, Expected_Type);
 914
 915                      --  Here for other than predicated subtype case
 916
 917                      if Etype (Choice) /= Any_Type then
 918                         declare
 919                            C : constant Node_Id := Constraint (Choice);
 920                            R : constant Node_Id := Range_Expression (C);
 921                            L : constant Node_Id := Low_Bound (R);
 922                            H : constant Node_Id := High_Bound (R);
 923
 924                         begin
 925                            E := Entity (Subtype_Mark (Choice));
 926
 927                            if not Is_Static_Subtype (E) then
 928                               Process_Non_Static_Choice (Choice);
 929
 930                            else
 931                               if Is_OK_Static_Expression (L)
 932                                 and then Is_OK_Static_Expression (H)
 933                               then
 934                                  if Expr_Value (L) > Expr_Value (H) then
 935                                     Process_Empty_Choice (Choice);
 936                                  else
 937                                     if Is_Out_Of_Range (L, E) then
 938                                        Apply_Compile_Time_Constraint_Error
 939                                          (L, "static value out of range",
 940                                           CE_Range_Check_Failed);
 941                                     end if;
 942
 943                                     if Is_Out_Of_Range (H, E) then
 944                                        Apply_Compile_Time_Constraint_Error
 945                                          (H, "static value out of range",
 946                                           CE_Range_Check_Failed);
 947                                     end if;
 948                                  end if;
 949                               end if;
 950
 951                               Check (Choice, L, H);
 952                            end if;
 953                         end;
 954                      end if;
 955
 956                   --  The others choice is only allowed for the last
 957                   --  alternative and as its only choice.
 958
 959                   elsif Kind = N_Others_Choice then
 960                      if not (Choice = First (Get_Choices (Alt))
 961                              and then Choice = Last (Get_Choices (Alt))
 962                              and then Alt = Last (Get_Alternatives (N)))
 963                      then
 964                         Error_Msg_N
 965                           ("the choice OTHERS must appear alone and last",
 966                            Choice);
 967                         return;
 968                      end if;
 969
 970                      Others_Present := True;
 971                      Others_Choice  := Choice;
 972
 973                   --  Only other possibility is an expression
 974
 975                   else
 976                      Resolve (Choice, Expected_Type);
 977                      Check (Choice, Choice, Choice);
 978                   end if;
 979
 980                   --  Move to next choice, deleting the current one if the
 981                   --  flag requesting this deletion is set True.
 982
 983                   declare
 984                      C : constant Node_Id := Choice;
 985                   begin
 986                      Next (Choice);
 987
 988                      if Delete_Choice then
 989                         Remove (C);
 990                      end if;
 991                   end;
 992                end loop;
 993
 994                Process_Associated_Node (Alt);
 995             end if;
 996
 997             Next (Alt);
 998          end loop;
 999
1000          --  Now we can create the Choice_Table, since we know how long
1001          --  it needs to be so we can allocate exactly the right length.
1002
1003          declare
1004             Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1005
1006          begin
1007             --  Now copy the items we collected in the linked list into this
1008             --  newly allocated table (leave entry 0 unused for sorting).
1009
1010             declare
1011                T : Link_Ptr;
1012             begin
1013                for J in 1 .. Num_Choices loop
1014                   T := Choice_List;
1015                   Choice_List := T.Nxt;
1016                   Choice_Table (J) := T.Val;
1017                   Free (T);
1018                end loop;
1019             end;
1020
1021             Check_Choices
1022               (Choice_Table,
1023                Bounds_Type,
1024                Subtyp,
1025                Others_Present or else (Choice_Type = Universal_Integer),
1026                N);
1027
1028             --  If no others choice we are all done, otherwise we have one more
1029             --  step, which is to set the Others_Discrete_Choices field of the
1030             --  others choice (to contain all otherwise unspecified choices).
1031             --  Skip this if CE is known to be raised.
1032
1033             if Others_Present and not Raises_CE then
1034                Expand_Others_Choice
1035                  (Case_Table    => Choice_Table,
1036                   Others_Choice => Others_Choice,
1037                   Choice_Type   => Bounds_Type);
1038             end if;
1039          end;
1040       end Analyze_Choices;
1041
1042    end Generic_Choices_Processing;
1043
1044 end Sem_Case;