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-2003 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, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, 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 27with Atree; use Atree; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Namet; use Namet; 31with Nlists; use Nlists; 32with Nmake; use Nmake; 33with Opt; use Opt; 34with Sem; use Sem; 35with Sem_Eval; use Sem_Eval; 36with Sem_Res; use Sem_Res; 37with Sem_Util; use Sem_Util; 38with Sem_Type; use Sem_Type; 39with Snames; use Snames; 40with Stand; use Stand; 41with Sinfo; use Sinfo; 42with Tbuild; use Tbuild; 43with Uintp; use Uintp; 44 45with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; 46 47package 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. 103 -- Use the lower 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 character. If we are in 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 then 276 C := UI_To_Int (Value); 277 278 if C in 16#20# .. 16#7E# then 279 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 280 return Name_Find; 281 end if; 282 283 -- For user defined enumeration type, find enum/char literal 284 285 else 286 Lit := First_Literal (Rtp); 287 288 for J in 1 .. UI_To_Int (Value) loop 289 Next_Literal (Lit); 290 end loop; 291 292 -- If enumeration literal, just return its value 293 294 if Nkind (Lit) = N_Defining_Identifier then 295 return Chars (Lit); 296 297 -- For character literal, get the name and use it if it is 298 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. 299 300 else 301 Get_Decoded_Name_String (Chars (Lit)); 302 303 if Name_Len = 3 304 and then Name_Buffer (2) in 305 Character'Val (16#20#) .. Character'Val (16#7E#) 306 then 307 return Chars (Lit); 308 end if; 309 end if; 310 end if; 311 312 -- If we fall through, we have a character literal which is not in 313 -- the 7-bit ASCII graphic set. For such cases, we construct the 314 -- name "type'val(nnn)" where type is the choice type, and nnn is 315 -- the pos value passed as an argument to Choice_Image. 316 317 Get_Name_String (Chars (First_Subtype (Ctype))); 318 Name_Len := Name_Len + 1; 319 Name_Buffer (Name_Len) := '''; 320 Name_Len := Name_Len + 1; 321 Name_Buffer (Name_Len) := 'v'; 322 Name_Len := Name_Len + 1; 323 Name_Buffer (Name_Len) := 'a'; 324 Name_Len := Name_Len + 1; 325 Name_Buffer (Name_Len) := 'l'; 326 Name_Len := Name_Len + 1; 327 Name_Buffer (Name_Len) := '('; 328 329 UI_Image (Value); 330 331 for J in 1 .. UI_Image_Length loop 332 Name_Len := Name_Len + 1; 333 Name_Buffer (Name_Len) := UI_Image_Buffer (J); 334 end loop; 335 336 Name_Len := Name_Len + 1; 337 Name_Buffer (Name_Len) := ')'; 338 return Name_Find; 339 end Choice_Image; 340 341 -------------------------- 342 -- Expand_Others_Choice -- 343 -------------------------- 344 345 procedure Expand_Others_Choice 346 (Case_Table : Choice_Table_Type; 347 Others_Choice : Node_Id; 348 Choice_Type : Entity_Id) 349 is 350 Loc : constant Source_Ptr := Sloc (Others_Choice); 351 Choice_List : constant List_Id := New_List; 352 Choice : Node_Id; 353 Exp_Lo : Node_Id; 354 Exp_Hi : Node_Id; 355 Hi : Uint; 356 Lo : Uint; 357 Previous_Hi : Uint; 358 359 function Build_Choice (Value1, Value2 : Uint) return Node_Id; 360 -- Builds a node representing the missing choices given by the 361 -- Value1 and Value2. A N_Range node is built if there is more than 362 -- one literal value missing. Otherwise a single N_Integer_Literal, 363 -- N_Identifier or N_Character_Literal is built depending on what 364 -- Choice_Type is. 365 366 function Lit_Of (Value : Uint) return Node_Id; 367 -- Returns the Node_Id for the enumeration literal corresponding to the 368 -- position given by Value within the enumeration type Choice_Type. 369 370 ------------------ 371 -- Build_Choice -- 372 ------------------ 373 374 function Build_Choice (Value1, Value2 : Uint) return Node_Id is 375 Lit_Node : Node_Id; 376 Lo, Hi : Node_Id; 377 378 begin 379 -- If there is only one choice value missing between Value1 and 380 -- Value2, build an integer or enumeration literal to represent it. 381 382 if (Value2 - Value1) = 0 then 383 if Is_Integer_Type (Choice_Type) then 384 Lit_Node := Make_Integer_Literal (Loc, Value1); 385 Set_Etype (Lit_Node, Choice_Type); 386 else 387 Lit_Node := Lit_Of (Value1); 388 end if; 389 390 -- Otherwise is more that one choice value that is missing between 391 -- Value1 and Value2, therefore build a N_Range node of either 392 -- integer or enumeration literals. 393 394 else 395 if Is_Integer_Type (Choice_Type) then 396 Lo := Make_Integer_Literal (Loc, Value1); 397 Set_Etype (Lo, Choice_Type); 398 Hi := Make_Integer_Literal (Loc, Value2); 399 Set_Etype (Hi, Choice_Type); 400 Lit_Node := 401 Make_Range (Loc, 402 Low_Bound => Lo, 403 High_Bound => Hi); 404 405 else 406 Lit_Node := 407 Make_Range (Loc, 408 Low_Bound => Lit_Of (Value1), 409 High_Bound => Lit_Of (Value2)); 410 end if; 411 end if; 412 413 return Lit_Node; 414 end Build_Choice; 415 416 ------------ 417 -- Lit_Of -- 418 ------------ 419 420 function Lit_Of (Value : Uint) return Node_Id is 421 Lit : Entity_Id; 422 423 begin 424 -- In the case where the literal is of type Character, there needs 425 -- to be some special handling since there is no explicit chain 426 -- of literals to search. Instead, a N_Character_Literal node 427 -- is created with the appropriate Char_Code and Chars fields. 428 429 if Root_Type (Choice_Type) = Standard_Character 430 or else 431 Root_Type (Choice_Type) = Standard_Wide_Character 432 then 433 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 434 Lit := New_Node (N_Character_Literal, Loc); 435 Set_Chars (Lit, Name_Find); 436 Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value))); 437 Set_Etype (Lit, Choice_Type); 438 Set_Is_Static_Expression (Lit, True); 439 return Lit; 440 441 -- Otherwise, iterate through the literals list of Choice_Type 442 -- "Value" number of times until the desired literal is reached 443 -- and then return an occurrence of it. 444 445 else 446 Lit := First_Literal (Choice_Type); 447 for J in 1 .. UI_To_Int (Value) loop 448 Next_Literal (Lit); 449 end loop; 450 451 return New_Occurrence_Of (Lit, Loc); 452 end if; 453 end Lit_Of; 454 455 -- Start of processing for Expand_Others_Choice 456 457 begin 458 if Case_Table'Length = 0 then 459 460 -- Special case: only an others case is present. 461 -- The others case covers the full range of the type. 462 463 if Is_Static_Subtype (Choice_Type) then 464 Choice := New_Occurrence_Of (Choice_Type, Loc); 465 else 466 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); 467 end if; 468 469 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); 470 return; 471 end if; 472 473 -- Establish the bound values for the choice depending upon whether 474 -- the type of the case statement is static or not. 475 476 if Is_OK_Static_Subtype (Choice_Type) then 477 Exp_Lo := Type_Low_Bound (Choice_Type); 478 Exp_Hi := Type_High_Bound (Choice_Type); 479 else 480 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); 481 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); 482 end if; 483 484 Lo := Expr_Value (Case_Table (Case_Table'First).Lo); 485 Hi := Expr_Value (Case_Table (Case_Table'First).Hi); 486 Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi); 487 488 -- Build the node for any missing choices that are smaller than any 489 -- explicit choices given in the case. 490 491 if Expr_Value (Exp_Lo) < Lo then 492 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); 493 end if; 494 495 -- Build the nodes representing any missing choices that lie between 496 -- the explicit ones given in the case. 497 498 for J in Case_Table'First + 1 .. Case_Table'Last loop 499 Lo := Expr_Value (Case_Table (J).Lo); 500 Hi := Expr_Value (Case_Table (J).Hi); 501 502 if Lo /= (Previous_Hi + 1) then 503 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); 504 end if; 505 506 Previous_Hi := Hi; 507 end loop; 508 509 -- Build the node for any missing choices that are greater than any 510 -- explicit choices given in the case. 511 512 if Expr_Value (Exp_Hi) > Hi then 513 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); 514 end if; 515 516 Set_Others_Discrete_Choices (Others_Choice, Choice_List); 517 518 -- Warn on null others list if warning option set 519 520 if Warn_On_Redundant_Constructs 521 and then Comes_From_Source (Others_Choice) 522 and then Is_Empty_List (Choice_List) 523 then 524 Error_Msg_N ("?others choice is empty", Others_Choice); 525 end if; 526 end Expand_Others_Choice; 527 528 ----------- 529 -- No_OP -- 530 ----------- 531 532 procedure No_OP (C : Node_Id) is 533 pragma Warnings (Off, C); 534 535 begin 536 null; 537 end No_OP; 538 539 -------------------------------- 540 -- Generic_Choices_Processing -- 541 -------------------------------- 542 543 package body Generic_Choices_Processing is 544 545 --------------------- 546 -- Analyze_Choices -- 547 --------------------- 548 549 procedure Analyze_Choices 550 (N : Node_Id; 551 Subtyp : Entity_Id; 552 Choice_Table : out Choice_Table_Type; 553 Last_Choice : out Nat; 554 Raises_CE : out Boolean; 555 Others_Present : out Boolean) 556 is 557 E : Entity_Id; 558 559 Nb_Choices : constant Nat := Choice_Table'Length; 560 Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices); 561 562 Choice_Type : constant Entity_Id := Base_Type (Subtyp); 563 -- The actual type against which the discrete choices are 564 -- resolved. Note that this type is always the base type not the 565 -- subtype of the ruling expression, index or discriminant. 566 567 Bounds_Type : Entity_Id; 568 -- The type from which are derived the bounds of the values 569 -- covered by the discrete choices (see 3.8.1 (4)). If a discrete 570 -- choice specifies a value outside of these bounds we have an error. 571 572 Bounds_Lo : Uint; 573 Bounds_Hi : Uint; 574 -- The actual bounds of the above type. 575 576 Expected_Type : Entity_Id; 577 -- The expected type of each choice. Equal to Choice_Type, except 578 -- if the expression is universal, in which case the choices can 579 -- be of any integer type. 580 581 Alt : Node_Id; 582 -- A case statement alternative or a variant in a record type 583 -- declaration 584 585 Choice : Node_Id; 586 Kind : Node_Kind; 587 -- The node kind of the current Choice 588 589 Others_Choice : Node_Id := Empty; 590 -- Remember others choice if it is present (empty otherwise) 591 592 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); 593 -- Checks the validity of the bounds of a choice. When the bounds 594 -- are static and no error occurred the bounds are entered into 595 -- the choices table so that they can be sorted later on. 596 597 ----------- 598 -- Check -- 599 ----------- 600 601 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is 602 Lo_Val : Uint; 603 Hi_Val : Uint; 604 605 begin 606 -- First check if an error was already detected on either bounds 607 608 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then 609 return; 610 611 -- Do not insert non static choices in the table to be sorted 612 613 elsif not Is_Static_Expression (Lo) 614 or else not Is_Static_Expression (Hi) 615 then 616 Process_Non_Static_Choice (Choice); 617 return; 618 619 -- Ignore range which raise constraint error 620 621 elsif Raises_Constraint_Error (Lo) 622 or else Raises_Constraint_Error (Hi) 623 then 624 Raises_CE := True; 625 return; 626 627 -- Otherwise we have an OK static choice 628 629 else 630 Lo_Val := Expr_Value (Lo); 631 Hi_Val := Expr_Value (Hi); 632 633 -- Do not insert null ranges in the choices table 634 635 if Lo_Val > Hi_Val then 636 Process_Empty_Choice (Choice); 637 return; 638 end if; 639 end if; 640 641 -- Check for bound out of range. 642 643 if Lo_Val < Bounds_Lo then 644 if Is_Integer_Type (Bounds_Type) then 645 Error_Msg_Uint_1 := Bounds_Lo; 646 Error_Msg_N ("minimum allowed choice value is^", Lo); 647 else 648 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); 649 Error_Msg_N ("minimum allowed choice value is%", Lo); 650 end if; 651 652 elsif Hi_Val > Bounds_Hi then 653 if Is_Integer_Type (Bounds_Type) then 654 Error_Msg_Uint_1 := Bounds_Hi; 655 Error_Msg_N ("maximum allowed choice value is^", Hi); 656 else 657 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); 658 Error_Msg_N ("maximum allowed choice value is%", Hi); 659 end if; 660 end if; 661 662 -- Store bounds in the table 663 664 -- Note: we still store the bounds, even if they are out of 665 -- range, since this may prevent unnecessary cascaded errors 666 -- for values that are covered by such an excessive range. 667 668 Last_Choice := Last_Choice + 1; 669 Sort_Choice_Table (Last_Choice).Lo := Lo; 670 Sort_Choice_Table (Last_Choice).Hi := Hi; 671 Sort_Choice_Table (Last_Choice).Node := Choice; 672 end Check; 673 674 -- Start of processing for Analyze_Choices 675 676 begin 677 Last_Choice := 0; 678 Raises_CE := False; 679 Others_Present := False; 680 681 -- If Subtyp is not a static subtype Ada 95 requires then we use 682 -- the bounds of its base type to determine the values covered by 683 -- the discrete choices. 684 685 if Is_OK_Static_Subtype (Subtyp) then 686 Bounds_Type := Subtyp; 687 else 688 Bounds_Type := Choice_Type; 689 end if; 690 691 -- Obtain static bounds of type, unless this is a generic formal 692 -- discrete type for which all choices will be non-static. 693 694 if not Is_Generic_Type (Root_Type (Bounds_Type)) 695 or else Ekind (Bounds_Type) /= E_Enumeration_Type 696 then 697 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); 698 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); 699 end if; 700 701 if Choice_Type = Universal_Integer then 702 Expected_Type := Any_Integer; 703 else 704 Expected_Type := Choice_Type; 705 end if; 706 707 -- Now loop through the case alternatives or record variants 708 709 Alt := First (Get_Alternatives (N)); 710 while Present (Alt) loop 711 712 -- If pragma, just analyze it 713 714 if Nkind (Alt) = N_Pragma then 715 Analyze (Alt); 716 717 -- Otherwise check each choice against its base type 718 719 else 720 Choice := First (Get_Choices (Alt)); 721 722 while Present (Choice) loop 723 Analyze (Choice); 724 Kind := Nkind (Choice); 725 726 -- Choice is a Range 727 728 if Kind = N_Range 729 or else (Kind = N_Attribute_Reference 730 and then Attribute_Name (Choice) = Name_Range) 731 then 732 Resolve (Choice, Expected_Type); 733 Check (Choice, Low_Bound (Choice), High_Bound (Choice)); 734 735 -- Choice is a subtype name 736 737 elsif Is_Entity_Name (Choice) 738 and then Is_Type (Entity (Choice)) 739 then 740 if not Covers (Expected_Type, Etype (Choice)) then 741 Wrong_Type (Choice, Choice_Type); 742 743 else 744 E := Entity (Choice); 745 746 if not Is_Static_Subtype (E) then 747 Process_Non_Static_Choice (Choice); 748 else 749 Check 750 (Choice, Type_Low_Bound (E), Type_High_Bound (E)); 751 end if; 752 end if; 753 754 -- Choice is a subtype indication 755 756 elsif Kind = N_Subtype_Indication then 757 Resolve_Discrete_Subtype_Indication 758 (Choice, Expected_Type); 759 760 if Etype (Choice) /= Any_Type then 761 declare 762 C : constant Node_Id := Constraint (Choice); 763 R : constant Node_Id := Range_Expression (C); 764 L : constant Node_Id := Low_Bound (R); 765 H : constant Node_Id := High_Bound (R); 766 767 begin 768 E := Entity (Subtype_Mark (Choice)); 769 770 if not Is_Static_Subtype (E) then 771 Process_Non_Static_Choice (Choice); 772 773 else 774 if Is_OK_Static_Expression (L) 775 and then Is_OK_Static_Expression (H) 776 then 777 if Expr_Value (L) > Expr_Value (H) then 778 Process_Empty_Choice (Choice); 779 else 780 if Is_Out_Of_Range (L, E) then 781 Apply_Compile_Time_Constraint_Error 782 (L, "static value out of range", 783 CE_Range_Check_Failed); 784 end if; 785 786 if Is_Out_Of_Range (H, E) then 787 Apply_Compile_Time_Constraint_Error 788 (H, "static value out of range", 789 CE_Range_Check_Failed); 790 end if; 791 end if; 792 end if; 793 794 Check (Choice, L, H); 795 end if; 796 end; 797 end if; 798 799 -- The others choice is only allowed for the last 800 -- alternative and as its only choice. 801 802 elsif Kind = N_Others_Choice then 803 if not (Choice = First (Get_Choices (Alt)) 804 and then Choice = Last (Get_Choices (Alt)) 805 and then Alt = Last (Get_Alternatives (N))) 806 then 807 Error_Msg_N 808 ("the choice OTHERS must appear alone and last", 809 Choice); 810 return; 811 end if; 812 813 Others_Present := True; 814 Others_Choice := Choice; 815 816 -- Only other possibility is an expression 817 818 else 819 Resolve (Choice, Expected_Type); 820 Check (Choice, Choice, Choice); 821 end if; 822 823 Next (Choice); 824 end loop; 825 826 Process_Associated_Node (Alt); 827 end if; 828 829 Next (Alt); 830 end loop; 831 832 Check_Choices 833 (Sort_Choice_Table (0 .. Last_Choice), 834 Bounds_Type, 835 Others_Present or else (Choice_Type = Universal_Integer), 836 Sloc (N)); 837 838 -- Now copy the sorted discrete choices 839 840 for J in 1 .. Last_Choice loop 841 Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J); 842 end loop; 843 844 -- If no others choice we are all done, otherwise we have one more 845 -- step, which is to set the Others_Discrete_Choices field of the 846 -- others choice (to contain all otherwise unspecified choices). 847 -- Skip this if CE is known to be raised. 848 849 if Others_Present and not Raises_CE then 850 Expand_Others_Choice 851 (Case_Table => Choice_Table (1 .. Last_Choice), 852 Others_Choice => Others_Choice, 853 Choice_Type => Bounds_Type); 854 end if; 855 end Analyze_Choices; 856 857 ----------------------- 858 -- Number_Of_Choices -- 859 ----------------------- 860 861 function Number_Of_Choices (N : Node_Id) return Nat is 862 Alt : Node_Id; 863 -- A case statement alternative or a record variant. 864 865 Choice : Node_Id; 866 Count : Nat := 0; 867 868 begin 869 if not Present (Get_Alternatives (N)) then 870 return 0; 871 end if; 872 873 Alt := First_Non_Pragma (Get_Alternatives (N)); 874 while Present (Alt) loop 875 876 Choice := First (Get_Choices (Alt)); 877 while Present (Choice) loop 878 if Nkind (Choice) /= N_Others_Choice then 879 Count := Count + 1; 880 end if; 881 882 Next (Choice); 883 end loop; 884 885 Next_Non_Pragma (Alt); 886 end loop; 887 888 return Count; 889 end Number_Of_Choices; 890 891 end Generic_Choices_Processing; 892 893end Sem_Case; 894