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