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