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