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