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