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-2013, 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 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Errout; use Errout; 29with Namet; use Namet; 30with Nlists; use Nlists; 31with Nmake; use Nmake; 32with Opt; use Opt; 33with Sem; use Sem; 34with Sem_Aux; use Sem_Aux; 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 Ada.Unchecked_Deallocation; 46 47with GNAT.Heap_Sort_G; 48 49package body Sem_Case is 50 51 type Choice_Bounds is record 52 Lo : Node_Id; 53 Hi : Node_Id; 54 Node : Node_Id; 55 end record; 56 -- Represent one choice bounds entry with Lo and Hi values, Node points 57 -- to the choice node itself. 58 59 type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; 60 -- Table type used to sort the choices present in a case statement or 61 -- record variant. The actual entries are stored in 1 .. Last, but we 62 -- have a 0 entry for use in sorting. 63 64 ----------------------- 65 -- Local Subprograms -- 66 ----------------------- 67 68 procedure Check_Choice_Set 69 (Choice_Table : in out Choice_Table_Type; 70 Bounds_Type : Entity_Id; 71 Subtyp : Entity_Id; 72 Others_Present : Boolean; 73 Case_Node : Node_Id); 74 -- This is the procedure which verifies that a set of case alternatives 75 -- or record variant choices has no duplicates, and covers the range 76 -- specified by Bounds_Type. Choice_Table contains the discrete choices 77 -- to check. These must start at position 1. 78 -- 79 -- Furthermore Choice_Table (0) must exist. This element is used by 80 -- the sorting algorithm as a temporary. Others_Present is a flag 81 -- indicating whether or not an Others choice is present. Finally 82 -- Msg_Sloc gives the source location of the construct containing the 83 -- choices in the Choice_Table. 84 -- 85 -- Bounds_Type is the type whose range must be covered by the alternatives 86 -- 87 -- Subtyp is the subtype of the expression. If its bounds are non-static 88 -- the alternatives must cover its base type. 89 90 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; 91 -- Given a Pos value of enumeration type Ctype, returns the name 92 -- ID of an appropriate string to be used in error message output. 93 94 procedure Expand_Others_Choice 95 (Case_Table : Choice_Table_Type; 96 Others_Choice : Node_Id; 97 Choice_Type : Entity_Id); 98 -- The case table is the table generated by a call to Check_Choices 99 -- (with just 1 .. Last_Choice entries present). Others_Choice is a 100 -- pointer to the N_Others_Choice node (this routine is only called if 101 -- an others choice is present), and Choice_Type is the discrete type 102 -- of the bounds. The effect of this call is to analyze the cases and 103 -- determine the set of values covered by others. This choice list is 104 -- set in the Others_Discrete_Choices field of the N_Others_Choice node. 105 106 ---------------------- 107 -- Check_Choice_Set -- 108 ---------------------- 109 110 procedure Check_Choice_Set 111 (Choice_Table : in out Choice_Table_Type; 112 Bounds_Type : Entity_Id; 113 Subtyp : Entity_Id; 114 Others_Present : Boolean; 115 Case_Node : Node_Id) 116 is 117 procedure Check_Against_Predicate 118 (Pred : in out Node_Id; 119 Choice : Choice_Bounds; 120 Prev_Lo : in out Uint; 121 Prev_Hi : in out Uint; 122 Error : in out Boolean); 123 -- Determine whether a choice covers legal values as defined by a static 124 -- predicate set. Pred is a static predicate range. Choice is the choice 125 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous 126 -- choice that covered a predicate set. Error denotes whether the check 127 -- found an illegal intersection. 128 129 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); 130 -- Post message "duplication of choice value(s) bla bla at xx". Message 131 -- is posted at location C. Caller sets Error_Msg_Sloc for xx. 132 133 procedure Explain_Non_Static_Bound; 134 -- Called when we find a non-static bound, requiring the base type to 135 -- be covered. Provides where possible a helpful explanation of why the 136 -- bounds are non-static, since this is not always obvious. 137 138 function Lt_Choice (C1, C2 : Natural) return Boolean; 139 -- Comparison routine for comparing Choice_Table entries. Use the lower 140 -- bound of each Choice as the key. 141 142 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id); 143 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint); 144 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id); 145 procedure Missing_Choice (Value1 : Uint; Value2 : Uint); 146 -- Issue an error message indicating that there are missing choices, 147 -- followed by the image of the missing choices themselves which lie 148 -- between Value1 and Value2 inclusive. 149 150 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint); 151 -- Emit an error message for each non-covered static predicate set. 152 -- Prev_Hi denotes the upper bound of the last choice covering a set. 153 154 procedure Move_Choice (From : Natural; To : Natural); 155 -- Move routine for sorting the Choice_Table 156 157 package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); 158 159 ----------------------------- 160 -- Check_Against_Predicate -- 161 ----------------------------- 162 163 procedure Check_Against_Predicate 164 (Pred : in out Node_Id; 165 Choice : Choice_Bounds; 166 Prev_Lo : in out Uint; 167 Prev_Hi : in out Uint; 168 Error : in out Boolean) 169 is 170 procedure Illegal_Range 171 (Loc : Source_Ptr; 172 Lo : Uint; 173 Hi : Uint); 174 -- Emit an error message regarding a choice that clashes with the 175 -- legal static predicate sets. Loc is the location of the choice 176 -- that introduced the illegal range. Lo .. Hi is the range. 177 178 function Inside_Range 179 (Lo : Uint; 180 Hi : Uint; 181 Val : Uint) return Boolean; 182 -- Determine whether position Val within a discrete type is within 183 -- the range Lo .. Hi inclusive. 184 185 ------------------- 186 -- Illegal_Range -- 187 ------------------- 188 189 procedure Illegal_Range 190 (Loc : Source_Ptr; 191 Lo : Uint; 192 Hi : Uint) 193 is 194 begin 195 Error_Msg_Name_1 := Chars (Bounds_Type); 196 197 -- Single value 198 199 if Lo = Hi then 200 if Is_Integer_Type (Bounds_Type) then 201 Error_Msg_Uint_1 := Lo; 202 Error_Msg ("static predicate on % excludes value ^!", Loc); 203 else 204 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); 205 Error_Msg ("static predicate on % excludes value %!", Loc); 206 end if; 207 208 -- Range 209 210 else 211 if Is_Integer_Type (Bounds_Type) then 212 Error_Msg_Uint_1 := Lo; 213 Error_Msg_Uint_2 := Hi; 214 Error_Msg 215 ("static predicate on % excludes range ^ .. ^!", Loc); 216 else 217 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); 218 Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type); 219 Error_Msg 220 ("static predicate on % excludes range % .. %!", Loc); 221 end if; 222 end if; 223 end Illegal_Range; 224 225 ------------------ 226 -- Inside_Range -- 227 ------------------ 228 229 function Inside_Range 230 (Lo : Uint; 231 Hi : Uint; 232 Val : Uint) return Boolean 233 is 234 begin 235 return 236 Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi); 237 end Inside_Range; 238 239 -- Local variables 240 241 Choice_Hi : constant Uint := Expr_Value (Choice.Hi); 242 Choice_Lo : constant Uint := Expr_Value (Choice.Lo); 243 Loc : Source_Ptr; 244 LocN : Node_Id; 245 Next_Hi : Uint; 246 Next_Lo : Uint; 247 Pred_Hi : Uint; 248 Pred_Lo : Uint; 249 250 -- Start of processing for Check_Against_Predicate 251 252 begin 253 -- Find the proper error message location 254 255 if Present (Choice.Node) then 256 LocN := Choice.Node; 257 else 258 LocN := Case_Node; 259 end if; 260 261 Loc := Sloc (LocN); 262 263 if Present (Pred) then 264 Pred_Lo := Expr_Value (Low_Bound (Pred)); 265 Pred_Hi := Expr_Value (High_Bound (Pred)); 266 267 -- Previous choices managed to satisfy all static predicate sets 268 269 else 270 Illegal_Range (Loc, Choice_Lo, Choice_Hi); 271 Error := True; 272 return; 273 end if; 274 275 -- Step 1: Detect duplicate choices 276 277 if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then 278 Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN); 279 Error := True; 280 281 elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then 282 Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN); 283 Error := True; 284 285 -- Step 2: Detect full coverage 286 287 -- Choice_Lo Choice_Hi 288 -- +============+ 289 -- Pred_Lo Pred_Hi 290 291 elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then 292 Prev_Lo := Choice_Lo; 293 Prev_Hi := Choice_Hi; 294 Next (Pred); 295 296 -- Step 3: Detect all cases where a choice mentions values that are 297 -- not part of the static predicate sets. 298 299 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi 300 -- +-----------+ . . . . . +=========+ 301 -- ^ illegal ^ 302 303 elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then 304 Illegal_Range (Loc, Choice_Lo, Choice_Hi); 305 Error := True; 306 307 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi 308 -- +-----------+=========+===========+ 309 -- ^ illegal ^ 310 311 elsif Choice_Lo < Pred_Lo 312 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi) 313 then 314 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); 315 Error := True; 316 317 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi 318 -- +=========+ . . . . +-----------+ 319 -- ^ illegal ^ 320 321 elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then 322 if Others_Present then 323 324 -- Current predicate set is covered by others clause. 325 326 null; 327 328 else 329 Missing_Choice (Pred_Lo, Pred_Hi); 330 Error := True; 331 end if; 332 333 -- There may be several static predicate sets between the current 334 -- one and the choice. Inspect the next static predicate set. 335 336 Next (Pred); 337 Check_Against_Predicate 338 (Pred => Pred, 339 Choice => Choice, 340 Prev_Lo => Prev_Lo, 341 Prev_Hi => Prev_Hi, 342 Error => Error); 343 344 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi 345 -- +=========+===========+-----------+ 346 -- ^ illegal ^ 347 348 elsif Pred_Hi < Choice_Hi 349 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo) 350 then 351 Next (Pred); 352 353 -- The choice may fall in a static predicate set. If this is the 354 -- case, avoid mentioning legal values in the error message. 355 356 if Present (Pred) then 357 Next_Lo := Expr_Value (Low_Bound (Pred)); 358 Next_Hi := Expr_Value (High_Bound (Pred)); 359 360 -- The next static predicate set is to the right of the choice 361 362 if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then 363 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); 364 else 365 Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1); 366 end if; 367 else 368 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); 369 end if; 370 371 Error := True; 372 373 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi 374 -- +-----------+=========+-----------+ 375 -- ^ illegal ^ ^ illegal ^ 376 377 -- Emit an error on the low gap, disregard the upper gap 378 379 elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then 380 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); 381 Error := True; 382 383 -- Step 4: Detect all cases of partial or missing coverage 384 385 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi 386 -- +=========+==========+===========+ 387 -- ^ gap ^ ^ gap ^ 388 389 else 390 -- An "others" choice covers all gaps 391 392 if Others_Present then 393 Prev_Lo := Choice_Lo; 394 Prev_Hi := Choice_Hi; 395 396 -- Check whether predicate set is fully covered by choice 397 398 if Pred_Hi = Choice_Hi then 399 Next (Pred); 400 end if; 401 402 -- Choice_Lo Choice_Hi Pred_Hi 403 -- +===========+===========+ 404 -- Pred_Lo ^ gap ^ 405 406 -- The upper gap may be covered by a subsequent choice 407 408 elsif Pred_Lo = Choice_Lo then 409 Prev_Lo := Choice_Lo; 410 Prev_Hi := Choice_Hi; 411 412 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi 413 -- +===========+=========+===========+===========+ 414 -- ^ covered ^ ^ gap ^ 415 416 else pragma Assert (Pred_Lo < Choice_Lo); 417 418 -- A previous choice covered the gap up to the current choice 419 420 if Prev_Hi = Choice_Lo - 1 then 421 Prev_Lo := Choice_Lo; 422 Prev_Hi := Choice_Hi; 423 424 if Choice_Hi = Pred_Hi then 425 Next (Pred); 426 end if; 427 428 -- The previous choice did not intersect with the current 429 -- static predicate set. 430 431 elsif Prev_Hi < Pred_Lo then 432 Missing_Choice (Pred_Lo, Choice_Lo - 1); 433 Error := True; 434 435 -- The previous choice covered part of the static predicate set 436 437 else 438 Missing_Choice (Prev_Hi, Choice_Lo - 1); 439 Error := True; 440 end if; 441 end if; 442 end if; 443 end Check_Against_Predicate; 444 445 ---------------- 446 -- Dup_Choice -- 447 ---------------- 448 449 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is 450 begin 451 -- In some situations, we call this with a null range, and obviously 452 -- we don't want to complain in this case. 453 454 if Lo > Hi then 455 return; 456 end if; 457 458 -- Case of only one value that is missing 459 460 if Lo = Hi then 461 if Is_Integer_Type (Bounds_Type) then 462 Error_Msg_Uint_1 := Lo; 463 Error_Msg_N ("duplication of choice value: ^#!", C); 464 else 465 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); 466 Error_Msg_N ("duplication of choice value: %#!", C); 467 end if; 468 469 -- More than one choice value, so print range of values 470 471 else 472 if Is_Integer_Type (Bounds_Type) then 473 Error_Msg_Uint_1 := Lo; 474 Error_Msg_Uint_2 := Hi; 475 Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); 476 else 477 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); 478 Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); 479 Error_Msg_N ("duplication of choice values: % .. %#!", C); 480 end if; 481 end if; 482 end Dup_Choice; 483 484 ------------------------------ 485 -- Explain_Non_Static_Bound -- 486 ------------------------------ 487 488 procedure Explain_Non_Static_Bound is 489 Expr : Node_Id; 490 491 begin 492 if Nkind (Case_Node) = N_Variant_Part then 493 Expr := Name (Case_Node); 494 else 495 Expr := Expression (Case_Node); 496 end if; 497 498 if Bounds_Type /= Subtyp then 499 500 -- If the case is a variant part, the expression is given by the 501 -- discriminant itself, and the bounds are the culprits. 502 503 if Nkind (Case_Node) = N_Variant_Part then 504 Error_Msg_NE 505 ("bounds of & are not static, " 506 & "alternatives must cover base type!", Expr, Expr); 507 508 -- If this is a case statement, the expression may be non-static 509 -- or else the subtype may be at fault. 510 511 elsif Is_Entity_Name (Expr) then 512 Error_Msg_NE 513 ("bounds of & are not static, " 514 & "alternatives must cover base type!", Expr, Expr); 515 516 else 517 Error_Msg_N 518 ("subtype of expression is not static, " 519 & "alternatives must cover base type!", Expr); 520 end if; 521 522 -- Otherwise the expression is not static, even if the bounds of the 523 -- type are, or else there are missing alternatives. If both, the 524 -- additional information may be redundant but harmless. 525 526 elsif not Is_Entity_Name (Expr) then 527 Error_Msg_N 528 ("subtype of expression is not static, " 529 & "alternatives must cover base type!", Expr); 530 end if; 531 end Explain_Non_Static_Bound; 532 533 --------------- 534 -- Lt_Choice -- 535 --------------- 536 537 function Lt_Choice (C1, C2 : Natural) return Boolean is 538 begin 539 return 540 Expr_Value (Choice_Table (Nat (C1)).Lo) 541 < 542 Expr_Value (Choice_Table (Nat (C2)).Lo); 543 end Lt_Choice; 544 545 -------------------- 546 -- Missing_Choice -- 547 -------------------- 548 549 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is 550 begin 551 Missing_Choice (Expr_Value (Value1), Expr_Value (Value2)); 552 end Missing_Choice; 553 554 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is 555 begin 556 Missing_Choice (Expr_Value (Value1), Value2); 557 end Missing_Choice; 558 559 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is 560 begin 561 Missing_Choice (Value1, Expr_Value (Value2)); 562 end Missing_Choice; 563 564 procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is 565 Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); 566 567 begin 568 -- AI05-0188 : within an instance the non-others choices do not have 569 -- to belong to the actual subtype. 570 571 if Ada_Version >= Ada_2012 and then In_Instance then 572 return; 573 574 -- In some situations, we call this with a null range, and obviously 575 -- we don't want to complain in this case. 576 577 elsif Value1 > Value2 then 578 return; 579 end if; 580 581 -- Case of only one value that is missing 582 583 if Value1 = Value2 then 584 if Is_Integer_Type (Bounds_Type) then 585 Error_Msg_Uint_1 := Value1; 586 Error_Msg ("missing case value: ^!", Msg_Sloc); 587 else 588 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); 589 Error_Msg ("missing case value: %!", Msg_Sloc); 590 end if; 591 592 -- More than one choice value, so print range of values 593 594 else 595 if Is_Integer_Type (Bounds_Type) then 596 Error_Msg_Uint_1 := Value1; 597 Error_Msg_Uint_2 := Value2; 598 Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); 599 else 600 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); 601 Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); 602 Error_Msg ("missing case values: % .. %!", Msg_Sloc); 603 end if; 604 end if; 605 end Missing_Choice; 606 607 --------------------- 608 -- Missing_Choices -- 609 --------------------- 610 611 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is 612 Hi : Uint; 613 Lo : Uint; 614 Set : Node_Id; 615 616 begin 617 Set := Pred; 618 while Present (Set) loop 619 Lo := Expr_Value (Low_Bound (Set)); 620 Hi := Expr_Value (High_Bound (Set)); 621 622 -- A choice covered part of a static predicate set 623 624 if Lo <= Prev_Hi and then Prev_Hi < Hi then 625 Missing_Choice (Prev_Hi + 1, Hi); 626 627 else 628 Missing_Choice (Lo, Hi); 629 end if; 630 631 Next (Set); 632 end loop; 633 end Missing_Choices; 634 635 ----------------- 636 -- Move_Choice -- 637 ----------------- 638 639 procedure Move_Choice (From : Natural; To : Natural) is 640 begin 641 Choice_Table (Nat (To)) := Choice_Table (Nat (From)); 642 end Move_Choice; 643 644 -- Local variables 645 646 Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); 647 Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); 648 Has_Predicate : constant Boolean := 649 Is_Static_Subtype (Bounds_Type) 650 and then Present (Static_Predicate (Bounds_Type)); 651 Num_Choices : constant Nat := Choice_Table'Last; 652 653 Choice : Node_Id; 654 Choice_Hi : Uint; 655 Choice_Lo : Uint; 656 Error : Boolean; 657 Pred : Node_Id; 658 Prev_Choice : Node_Id; 659 Prev_Lo : Uint; 660 Prev_Hi : Uint; 661 662 -- Start of processing for Check_Choice_Set 663 664 begin 665 -- Choice_Table must start at 0 which is an unused location used by the 666 -- sorting algorithm. However the first valid position for a discrete 667 -- choice is 1. 668 669 pragma Assert (Choice_Table'First = 0); 670 671 -- The choices do not cover the base range. Emit an error if "others" is 672 -- not available and return as there is no need for further processing. 673 674 if Num_Choices = 0 then 675 if not Others_Present then 676 Missing_Choice (Bounds_Lo, Bounds_Hi); 677 end if; 678 679 return; 680 end if; 681 682 Sorting.Sort (Positive (Choice_Table'Last)); 683 684 -- The type covered by the list of choices is actually a static subtype 685 -- subject to a static predicate. The predicate defines subsets of legal 686 -- values and requires finer grained analysis. 687 688 if Has_Predicate then 689 Pred := First (Static_Predicate (Bounds_Type)); 690 Prev_Lo := Uint_Minus_1; 691 Prev_Hi := Uint_Minus_1; 692 Error := False; 693 694 for Index in 1 .. Num_Choices loop 695 Check_Against_Predicate 696 (Pred => Pred, 697 Choice => Choice_Table (Index), 698 Prev_Lo => Prev_Lo, 699 Prev_Hi => Prev_Hi, 700 Error => Error); 701 702 -- The analysis detected an illegal intersection between a choice 703 -- and a static predicate set. 704 705 if Error then 706 return; 707 end if; 708 end loop; 709 710 -- The choices may legally cover some of the static predicate sets, 711 -- but not all. Emit an error for each non-covered set. 712 713 if not Others_Present then 714 Missing_Choices (Pred, Prev_Hi); 715 end if; 716 717 -- Default analysis 718 719 else 720 Choice_Lo := Expr_Value (Choice_Table (1).Lo); 721 Choice_Hi := Expr_Value (Choice_Table (1).Hi); 722 Prev_Hi := Choice_Hi; 723 724 if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then 725 Missing_Choice (Bounds_Lo, Choice_Lo - 1); 726 727 -- If values are missing outside of the subtype, add explanation. 728 -- No additional message if only one value is missing. 729 730 if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then 731 Explain_Non_Static_Bound; 732 end if; 733 end if; 734 735 for Outer_Index in 2 .. Num_Choices loop 736 Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); 737 Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); 738 739 if Choice_Lo <= Prev_Hi then 740 Choice := Choice_Table (Outer_Index).Node; 741 742 -- Find first previous choice that overlaps 743 744 for Inner_Index in 1 .. Outer_Index - 1 loop 745 if Choice_Lo <= 746 Expr_Value (Choice_Table (Inner_Index).Hi) 747 then 748 Prev_Choice := Choice_Table (Inner_Index).Node; 749 exit; 750 end if; 751 end loop; 752 753 if Sloc (Prev_Choice) <= Sloc (Choice) then 754 Error_Msg_Sloc := Sloc (Prev_Choice); 755 Dup_Choice 756 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); 757 else 758 Error_Msg_Sloc := Sloc (Choice); 759 Dup_Choice 760 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); 761 end if; 762 763 elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then 764 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); 765 end if; 766 767 if Choice_Hi > Prev_Hi then 768 Prev_Hi := Choice_Hi; 769 end if; 770 end loop; 771 772 if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then 773 Missing_Choice (Prev_Hi + 1, Bounds_Hi); 774 775 if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then 776 Explain_Non_Static_Bound; 777 end if; 778 end if; 779 end if; 780 end Check_Choice_Set; 781 782 ------------------ 783 -- Choice_Image -- 784 ------------------ 785 786 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is 787 Rtp : constant Entity_Id := Root_Type (Ctype); 788 Lit : Entity_Id; 789 C : Int; 790 791 begin 792 -- For character, or wide [wide] character. If 7-bit ASCII graphic 793 -- range, then build and return appropriate character literal name 794 795 if Is_Standard_Character_Type (Ctype) then 796 C := UI_To_Int (Value); 797 798 if C in 16#20# .. 16#7E# then 799 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 800 return Name_Find; 801 end if; 802 803 -- For user defined enumeration type, find enum/char literal 804 805 else 806 Lit := First_Literal (Rtp); 807 808 for J in 1 .. UI_To_Int (Value) loop 809 Next_Literal (Lit); 810 end loop; 811 812 -- If enumeration literal, just return its value 813 814 if Nkind (Lit) = N_Defining_Identifier then 815 return Chars (Lit); 816 817 -- For character literal, get the name and use it if it is 818 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. 819 820 else 821 Get_Decoded_Name_String (Chars (Lit)); 822 823 if Name_Len = 3 824 and then Name_Buffer (2) in 825 Character'Val (16#20#) .. Character'Val (16#7E#) 826 then 827 return Chars (Lit); 828 end if; 829 end if; 830 end if; 831 832 -- If we fall through, we have a character literal which is not in 833 -- the 7-bit ASCII graphic set. For such cases, we construct the 834 -- name "type'val(nnn)" where type is the choice type, and nnn is 835 -- the pos value passed as an argument to Choice_Image. 836 837 Get_Name_String (Chars (First_Subtype (Ctype))); 838 839 Add_Str_To_Name_Buffer ("'val("); 840 UI_Image (Value); 841 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); 842 Add_Char_To_Name_Buffer (')'); 843 return Name_Find; 844 end Choice_Image; 845 846 -------------------------- 847 -- Expand_Others_Choice -- 848 -------------------------- 849 850 procedure Expand_Others_Choice 851 (Case_Table : Choice_Table_Type; 852 Others_Choice : Node_Id; 853 Choice_Type : Entity_Id) 854 is 855 Loc : constant Source_Ptr := Sloc (Others_Choice); 856 Choice_List : constant List_Id := New_List; 857 Choice : Node_Id; 858 Exp_Lo : Node_Id; 859 Exp_Hi : Node_Id; 860 Hi : Uint; 861 Lo : Uint; 862 Previous_Hi : Uint; 863 864 function Build_Choice (Value1, Value2 : Uint) return Node_Id; 865 -- Builds a node representing the missing choices given by Value1 and 866 -- Value2. A N_Range node is built if there is more than one literal 867 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier 868 -- or N_Character_Literal is built depending on what Choice_Type is. 869 870 function Lit_Of (Value : Uint) return Node_Id; 871 -- Returns the Node_Id for the enumeration literal corresponding to the 872 -- position given by Value within the enumeration type Choice_Type. 873 874 ------------------ 875 -- Build_Choice -- 876 ------------------ 877 878 function Build_Choice (Value1, Value2 : Uint) return Node_Id is 879 Lit_Node : Node_Id; 880 Lo, Hi : Node_Id; 881 882 begin 883 -- If there is only one choice value missing between Value1 and 884 -- Value2, build an integer or enumeration literal to represent it. 885 886 if (Value2 - Value1) = 0 then 887 if Is_Integer_Type (Choice_Type) then 888 Lit_Node := Make_Integer_Literal (Loc, Value1); 889 Set_Etype (Lit_Node, Choice_Type); 890 else 891 Lit_Node := Lit_Of (Value1); 892 end if; 893 894 -- Otherwise is more that one choice value that is missing between 895 -- Value1 and Value2, therefore build a N_Range node of either 896 -- integer or enumeration literals. 897 898 else 899 if Is_Integer_Type (Choice_Type) then 900 Lo := Make_Integer_Literal (Loc, Value1); 901 Set_Etype (Lo, Choice_Type); 902 Hi := Make_Integer_Literal (Loc, Value2); 903 Set_Etype (Hi, Choice_Type); 904 Lit_Node := 905 Make_Range (Loc, 906 Low_Bound => Lo, 907 High_Bound => Hi); 908 909 else 910 Lit_Node := 911 Make_Range (Loc, 912 Low_Bound => Lit_Of (Value1), 913 High_Bound => Lit_Of (Value2)); 914 end if; 915 end if; 916 917 return Lit_Node; 918 end Build_Choice; 919 920 ------------ 921 -- Lit_Of -- 922 ------------ 923 924 function Lit_Of (Value : Uint) return Node_Id is 925 Lit : Entity_Id; 926 927 begin 928 -- In the case where the literal is of type Character, there needs 929 -- to be some special handling since there is no explicit chain 930 -- of literals to search. Instead, a N_Character_Literal node 931 -- is created with the appropriate Char_Code and Chars fields. 932 933 if Is_Standard_Character_Type (Choice_Type) then 934 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 935 Lit := New_Node (N_Character_Literal, Loc); 936 Set_Chars (Lit, Name_Find); 937 Set_Char_Literal_Value (Lit, Value); 938 Set_Etype (Lit, Choice_Type); 939 Set_Is_Static_Expression (Lit, True); 940 return Lit; 941 942 -- Otherwise, iterate through the literals list of Choice_Type 943 -- "Value" number of times until the desired literal is reached 944 -- and then return an occurrence of it. 945 946 else 947 Lit := First_Literal (Choice_Type); 948 for J in 1 .. UI_To_Int (Value) loop 949 Next_Literal (Lit); 950 end loop; 951 952 return New_Occurrence_Of (Lit, Loc); 953 end if; 954 end Lit_Of; 955 956 -- Start of processing for Expand_Others_Choice 957 958 begin 959 if Case_Table'Last = 0 then 960 961 -- Special case: only an others case is present. The others case 962 -- covers the full range of the type. 963 964 if Is_Static_Subtype (Choice_Type) then 965 Choice := New_Occurrence_Of (Choice_Type, Loc); 966 else 967 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); 968 end if; 969 970 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); 971 return; 972 end if; 973 974 -- Establish the bound values for the choice depending upon whether the 975 -- type of the case statement is static or not. 976 977 if Is_OK_Static_Subtype (Choice_Type) then 978 Exp_Lo := Type_Low_Bound (Choice_Type); 979 Exp_Hi := Type_High_Bound (Choice_Type); 980 else 981 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); 982 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); 983 end if; 984 985 Lo := Expr_Value (Case_Table (1).Lo); 986 Hi := Expr_Value (Case_Table (1).Hi); 987 Previous_Hi := Expr_Value (Case_Table (1).Hi); 988 989 -- Build the node for any missing choices that are smaller than any 990 -- explicit choices given in the case. 991 992 if Expr_Value (Exp_Lo) < Lo then 993 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); 994 end if; 995 996 -- Build the nodes representing any missing choices that lie between 997 -- the explicit ones given in the case. 998 999 for J in 2 .. Case_Table'Last loop 1000 Lo := Expr_Value (Case_Table (J).Lo); 1001 Hi := Expr_Value (Case_Table (J).Hi); 1002 1003 if Lo /= (Previous_Hi + 1) then 1004 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); 1005 end if; 1006 1007 Previous_Hi := Hi; 1008 end loop; 1009 1010 -- Build the node for any missing choices that are greater than any 1011 -- explicit choices given in the case. 1012 1013 if Expr_Value (Exp_Hi) > Hi then 1014 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); 1015 end if; 1016 1017 Set_Others_Discrete_Choices (Others_Choice, Choice_List); 1018 1019 -- Warn on null others list if warning option set 1020 1021 if Warn_On_Redundant_Constructs 1022 and then Comes_From_Source (Others_Choice) 1023 and then Is_Empty_List (Choice_List) 1024 then 1025 Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice); 1026 Error_Msg_N ("\?r?previous choices cover all values", Others_Choice); 1027 end if; 1028 end Expand_Others_Choice; 1029 1030 ----------- 1031 -- No_OP -- 1032 ----------- 1033 1034 procedure No_OP (C : Node_Id) is 1035 pragma Warnings (Off, C); 1036 begin 1037 null; 1038 end No_OP; 1039 1040 ----------------------------- 1041 -- Generic_Analyze_Choices -- 1042 ----------------------------- 1043 1044 package body Generic_Analyze_Choices is 1045 1046 -- The following type is used to gather the entries for the choice 1047 -- table, so that we can then allocate the right length. 1048 1049 type Link; 1050 type Link_Ptr is access all Link; 1051 1052 type Link is record 1053 Val : Choice_Bounds; 1054 Nxt : Link_Ptr; 1055 end record; 1056 1057 --------------------- 1058 -- Analyze_Choices -- 1059 --------------------- 1060 1061 procedure Analyze_Choices 1062 (Alternatives : List_Id; 1063 Subtyp : Entity_Id) 1064 is 1065 Choice_Type : constant Entity_Id := Base_Type (Subtyp); 1066 -- The actual type against which the discrete choices are resolved. 1067 -- Note that this type is always the base type not the subtype of the 1068 -- ruling expression, index or discriminant. 1069 1070 Expected_Type : Entity_Id; 1071 -- The expected type of each choice. Equal to Choice_Type, except if 1072 -- the expression is universal, in which case the choices can be of 1073 -- any integer type. 1074 1075 Alt : Node_Id; 1076 -- A case statement alternative or a variant in a record type 1077 -- declaration. 1078 1079 Choice : Node_Id; 1080 Kind : Node_Kind; 1081 -- The node kind of the current Choice 1082 1083 begin 1084 -- Set Expected type (= choice type except for universal integer, 1085 -- where we accept any integer type as a choice). 1086 1087 if Choice_Type = Universal_Integer then 1088 Expected_Type := Any_Integer; 1089 else 1090 Expected_Type := Choice_Type; 1091 end if; 1092 1093 -- Now loop through the case alternatives or record variants 1094 1095 Alt := First (Alternatives); 1096 while Present (Alt) loop 1097 1098 -- If pragma, just analyze it 1099 1100 if Nkind (Alt) = N_Pragma then 1101 Analyze (Alt); 1102 1103 -- Otherwise we have an alternative. In most cases the semantic 1104 -- processing leaves the list of choices unchanged 1105 1106 -- Check each choice against its base type 1107 1108 else 1109 Choice := First (Discrete_Choices (Alt)); 1110 while Present (Choice) loop 1111 Analyze (Choice); 1112 Kind := Nkind (Choice); 1113 1114 -- Choice is a Range 1115 1116 if Kind = N_Range 1117 or else (Kind = N_Attribute_Reference 1118 and then Attribute_Name (Choice) = Name_Range) 1119 then 1120 Resolve (Choice, Expected_Type); 1121 1122 -- Choice is a subtype name, nothing further to do now 1123 1124 elsif Is_Entity_Name (Choice) 1125 and then Is_Type (Entity (Choice)) 1126 then 1127 null; 1128 1129 -- Choice is a subtype indication 1130 1131 elsif Kind = N_Subtype_Indication then 1132 Resolve_Discrete_Subtype_Indication 1133 (Choice, Expected_Type); 1134 1135 -- Others choice, no analysis needed 1136 1137 elsif Kind = N_Others_Choice then 1138 null; 1139 1140 -- Only other possibility is an expression 1141 1142 else 1143 Resolve (Choice, Expected_Type); 1144 end if; 1145 1146 -- Move to next choice 1147 1148 Next (Choice); 1149 end loop; 1150 1151 Process_Associated_Node (Alt); 1152 end if; 1153 1154 Next (Alt); 1155 end loop; 1156 end Analyze_Choices; 1157 1158 end Generic_Analyze_Choices; 1159 1160 --------------------------- 1161 -- Generic_Check_Choices -- 1162 --------------------------- 1163 1164 package body Generic_Check_Choices is 1165 1166 -- The following type is used to gather the entries for the choice 1167 -- table, so that we can then allocate the right length. 1168 1169 type Link; 1170 type Link_Ptr is access all Link; 1171 1172 type Link is record 1173 Val : Choice_Bounds; 1174 Nxt : Link_Ptr; 1175 end record; 1176 1177 procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); 1178 1179 ------------------- 1180 -- Check_Choices -- 1181 ------------------- 1182 1183 procedure Check_Choices 1184 (N : Node_Id; 1185 Alternatives : List_Id; 1186 Subtyp : Entity_Id; 1187 Others_Present : out Boolean) 1188 is 1189 E : Entity_Id; 1190 1191 Raises_CE : Boolean; 1192 -- Set True if one of the bounds of a choice raises CE 1193 1194 Enode : Node_Id; 1195 -- This is where we post error messages for bounds out of range 1196 1197 Choice_List : Link_Ptr := null; 1198 -- Gather list of choices 1199 1200 Num_Choices : Nat := 0; 1201 -- Number of entries in Choice_List 1202 1203 Choice_Type : constant Entity_Id := Base_Type (Subtyp); 1204 -- The actual type against which the discrete choices are resolved. 1205 -- Note that this type is always the base type not the subtype of the 1206 -- ruling expression, index or discriminant. 1207 1208 Bounds_Type : Entity_Id; 1209 -- The type from which are derived the bounds of the values covered 1210 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice 1211 -- specifies a value outside of these bounds we have an error. 1212 1213 Bounds_Lo : Uint; 1214 Bounds_Hi : Uint; 1215 -- The actual bounds of the above type 1216 1217 Expected_Type : Entity_Id; 1218 -- The expected type of each choice. Equal to Choice_Type, except if 1219 -- the expression is universal, in which case the choices can be of 1220 -- any integer type. 1221 1222 Alt : Node_Id; 1223 -- A case statement alternative or a variant in a record type 1224 -- declaration. 1225 1226 Choice : Node_Id; 1227 Kind : Node_Kind; 1228 -- The node kind of the current Choice 1229 1230 Others_Choice : Node_Id := Empty; 1231 -- Remember others choice if it is present (empty otherwise) 1232 1233 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); 1234 -- Checks the validity of the bounds of a choice. When the bounds 1235 -- are static and no error occurred the bounds are collected for 1236 -- later entry into the choices table so that they can be sorted 1237 -- later on. 1238 1239 ----------- 1240 -- Check -- 1241 ----------- 1242 1243 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is 1244 Lo_Val : Uint; 1245 Hi_Val : Uint; 1246 1247 begin 1248 -- First check if an error was already detected on either bounds 1249 1250 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then 1251 return; 1252 1253 -- Do not insert non static choices in the table to be sorted 1254 1255 elsif not Is_Static_Expression (Lo) 1256 or else 1257 not Is_Static_Expression (Hi) 1258 then 1259 Process_Non_Static_Choice (Choice); 1260 return; 1261 1262 -- Ignore range which raise constraint error 1263 1264 elsif Raises_Constraint_Error (Lo) 1265 or else Raises_Constraint_Error (Hi) 1266 then 1267 Raises_CE := True; 1268 return; 1269 1270 -- AI05-0188 : Within an instance the non-others choices do not 1271 -- have to belong to the actual subtype. 1272 1273 elsif Ada_Version >= Ada_2012 and then In_Instance then 1274 return; 1275 1276 -- Otherwise we have an OK static choice 1277 1278 else 1279 Lo_Val := Expr_Value (Lo); 1280 Hi_Val := Expr_Value (Hi); 1281 1282 -- Do not insert null ranges in the choices table 1283 1284 if Lo_Val > Hi_Val then 1285 Process_Empty_Choice (Choice); 1286 return; 1287 end if; 1288 end if; 1289 1290 -- Check for low bound out of range 1291 1292 if Lo_Val < Bounds_Lo then 1293 1294 -- If the choice is an entity name, then it is a type, and we 1295 -- want to post the message on the reference to this entity. 1296 -- Otherwise post it on the lower bound of the range. 1297 1298 if Is_Entity_Name (Choice) then 1299 Enode := Choice; 1300 else 1301 Enode := Lo; 1302 end if; 1303 1304 -- Specialize message for integer/enum type 1305 1306 if Is_Integer_Type (Bounds_Type) then 1307 Error_Msg_Uint_1 := Bounds_Lo; 1308 Error_Msg_N ("minimum allowed choice value is^", Enode); 1309 else 1310 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); 1311 Error_Msg_N ("minimum allowed choice value is%", Enode); 1312 end if; 1313 end if; 1314 1315 -- Check for high bound out of range 1316 1317 if Hi_Val > Bounds_Hi then 1318 1319 -- If the choice is an entity name, then it is a type, and we 1320 -- want to post the message on the reference to this entity. 1321 -- Otherwise post it on the upper bound of the range. 1322 1323 if Is_Entity_Name (Choice) then 1324 Enode := Choice; 1325 else 1326 Enode := Hi; 1327 end if; 1328 1329 -- Specialize message for integer/enum type 1330 1331 if Is_Integer_Type (Bounds_Type) then 1332 Error_Msg_Uint_1 := Bounds_Hi; 1333 Error_Msg_N ("maximum allowed choice value is^", Enode); 1334 else 1335 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); 1336 Error_Msg_N ("maximum allowed choice value is%", Enode); 1337 end if; 1338 end if; 1339 1340 -- Collect bounds in the list 1341 1342 -- Note: we still store the bounds, even if they are out of range, 1343 -- since this may prevent unnecessary cascaded errors for values 1344 -- that are covered by such an excessive range. 1345 1346 Choice_List := 1347 new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); 1348 Num_Choices := Num_Choices + 1; 1349 end Check; 1350 1351 -- Start of processing for Check_Choices 1352 1353 begin 1354 Raises_CE := False; 1355 Others_Present := False; 1356 1357 -- If Subtyp is not a discrete type or there was some other error, 1358 -- then don't try any semantic checking on the choices since we have 1359 -- a complete mess. 1360 1361 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then 1362 return; 1363 end if; 1364 1365 -- If Subtyp is not a static subtype Ada 95 requires then we use the 1366 -- bounds of its base type to determine the values covered by the 1367 -- discrete choices. 1368 1369 -- In Ada 2012, if the subtype has a non-static predicate the full 1370 -- range of the base type must be covered as well. 1371 1372 if Is_OK_Static_Subtype (Subtyp) then 1373 if not Has_Predicates (Subtyp) 1374 or else Present (Static_Predicate (Subtyp)) 1375 then 1376 Bounds_Type := Subtyp; 1377 else 1378 Bounds_Type := Choice_Type; 1379 end if; 1380 1381 else 1382 Bounds_Type := Choice_Type; 1383 end if; 1384 1385 -- Obtain static bounds of type, unless this is a generic formal 1386 -- discrete type for which all choices will be non-static. 1387 1388 if not Is_Generic_Type (Root_Type (Bounds_Type)) 1389 or else Ekind (Bounds_Type) /= E_Enumeration_Type 1390 then 1391 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); 1392 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); 1393 end if; 1394 1395 if Choice_Type = Universal_Integer then 1396 Expected_Type := Any_Integer; 1397 else 1398 Expected_Type := Choice_Type; 1399 end if; 1400 1401 -- Now loop through the case alternatives or record variants 1402 1403 Alt := First (Alternatives); 1404 while Present (Alt) loop 1405 1406 -- If pragma, just analyze it 1407 1408 if Nkind (Alt) = N_Pragma then 1409 Analyze (Alt); 1410 1411 -- Otherwise we have an alternative. In most cases the semantic 1412 -- processing leaves the list of choices unchanged 1413 1414 -- Check each choice against its base type 1415 1416 else 1417 Choice := First (Discrete_Choices (Alt)); 1418 while Present (Choice) loop 1419 Kind := Nkind (Choice); 1420 1421 -- Choice is a Range 1422 1423 if Kind = N_Range 1424 or else (Kind = N_Attribute_Reference 1425 and then Attribute_Name (Choice) = Name_Range) 1426 then 1427 Check (Choice, Low_Bound (Choice), High_Bound (Choice)); 1428 1429 -- Choice is a subtype name 1430 1431 elsif Is_Entity_Name (Choice) 1432 and then Is_Type (Entity (Choice)) 1433 then 1434 -- Check for inappropriate type 1435 1436 if not Covers (Expected_Type, Etype (Choice)) then 1437 Wrong_Type (Choice, Choice_Type); 1438 1439 -- Type is OK, so check further 1440 1441 else 1442 E := Entity (Choice); 1443 1444 -- Case of predicated subtype 1445 1446 if Has_Predicates (E) then 1447 1448 -- Use of non-static predicate is an error 1449 1450 if not Is_Discrete_Type (E) 1451 or else No (Static_Predicate (E)) 1452 then 1453 Bad_Predicated_Subtype_Use 1454 ("cannot use subtype& with non-static " 1455 & "predicate as case alternative", 1456 Choice, E, Suggest_Static => True); 1457 1458 -- Static predicate case 1459 1460 else 1461 declare 1462 P : Node_Id; 1463 C : Node_Id; 1464 1465 begin 1466 -- Loop through entries in predicate list, 1467 -- checking each entry. Note that if the 1468 -- list is empty, corresponding to a False 1469 -- predicate, then no choices are checked. 1470 1471 P := First (Static_Predicate (E)); 1472 while Present (P) loop 1473 C := New_Copy (P); 1474 Set_Sloc (C, Sloc (Choice)); 1475 Check (C, Low_Bound (C), High_Bound (C)); 1476 Next (P); 1477 end loop; 1478 end; 1479 1480 Set_Has_SP_Choice (Alt); 1481 end if; 1482 1483 -- Not predicated subtype case 1484 1485 elsif not Is_Static_Subtype (E) then 1486 Process_Non_Static_Choice (Choice); 1487 else 1488 Check 1489 (Choice, Type_Low_Bound (E), Type_High_Bound (E)); 1490 end if; 1491 end if; 1492 1493 -- Choice is a subtype indication 1494 1495 elsif Kind = N_Subtype_Indication then 1496 Resolve_Discrete_Subtype_Indication 1497 (Choice, Expected_Type); 1498 1499 if Etype (Choice) /= Any_Type then 1500 declare 1501 C : constant Node_Id := Constraint (Choice); 1502 R : constant Node_Id := Range_Expression (C); 1503 L : constant Node_Id := Low_Bound (R); 1504 H : constant Node_Id := High_Bound (R); 1505 1506 begin 1507 E := Entity (Subtype_Mark (Choice)); 1508 1509 if not Is_Static_Subtype (E) then 1510 Process_Non_Static_Choice (Choice); 1511 1512 else 1513 if Is_OK_Static_Expression (L) 1514 and then 1515 Is_OK_Static_Expression (H) 1516 then 1517 if Expr_Value (L) > Expr_Value (H) then 1518 Process_Empty_Choice (Choice); 1519 else 1520 if Is_Out_Of_Range (L, E) then 1521 Apply_Compile_Time_Constraint_Error 1522 (L, "static value out of range", 1523 CE_Range_Check_Failed); 1524 end if; 1525 1526 if Is_Out_Of_Range (H, E) then 1527 Apply_Compile_Time_Constraint_Error 1528 (H, "static value out of range", 1529 CE_Range_Check_Failed); 1530 end if; 1531 end if; 1532 end if; 1533 1534 Check (Choice, L, H); 1535 end if; 1536 end; 1537 end if; 1538 1539 -- The others choice is only allowed for the last 1540 -- alternative and as its only choice. 1541 1542 elsif Kind = N_Others_Choice then 1543 if not (Choice = First (Discrete_Choices (Alt)) 1544 and then Choice = Last (Discrete_Choices (Alt)) 1545 and then Alt = Last (Alternatives)) 1546 then 1547 Error_Msg_N 1548 ("the choice OTHERS must appear alone and last", 1549 Choice); 1550 return; 1551 end if; 1552 1553 Others_Present := True; 1554 Others_Choice := Choice; 1555 1556 -- Only other possibility is an expression 1557 1558 else 1559 Check (Choice, Choice, Choice); 1560 end if; 1561 1562 -- Move to next choice 1563 1564 Next (Choice); 1565 end loop; 1566 1567 Process_Associated_Node (Alt); 1568 end if; 1569 1570 Next (Alt); 1571 end loop; 1572 1573 -- Now we can create the Choice_Table, since we know how long 1574 -- it needs to be so we can allocate exactly the right length. 1575 1576 declare 1577 Choice_Table : Choice_Table_Type (0 .. Num_Choices); 1578 1579 begin 1580 -- Now copy the items we collected in the linked list into this 1581 -- newly allocated table (leave entry 0 unused for sorting). 1582 1583 declare 1584 T : Link_Ptr; 1585 begin 1586 for J in 1 .. Num_Choices loop 1587 T := Choice_List; 1588 Choice_List := T.Nxt; 1589 Choice_Table (J) := T.Val; 1590 Free (T); 1591 end loop; 1592 end; 1593 1594 Check_Choice_Set 1595 (Choice_Table, 1596 Bounds_Type, 1597 Subtyp, 1598 Others_Present or else (Choice_Type = Universal_Integer), 1599 N); 1600 1601 -- If no others choice we are all done, otherwise we have one more 1602 -- step, which is to set the Others_Discrete_Choices field of the 1603 -- others choice (to contain all otherwise unspecified choices). 1604 -- Skip this if CE is known to be raised. 1605 1606 if Others_Present and not Raises_CE then 1607 Expand_Others_Choice 1608 (Case_Table => Choice_Table, 1609 Others_Choice => Others_Choice, 1610 Choice_Type => Bounds_Type); 1611 end if; 1612 end; 1613 end Check_Choices; 1614 1615 end Generic_Check_Choices; 1616 1617end Sem_Case; 1618