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