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