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-2021, 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 Einfo.Entities; use Einfo.Entities; 29with Einfo.Utils; use Einfo.Utils; 30with Elists; use Elists; 31with Errout; use Errout; 32with Namet; use Namet; 33with Nlists; use Nlists; 34with Nmake; use Nmake; 35with Opt; use Opt; 36with Sem; use Sem; 37with Sem_Aux; use Sem_Aux; 38with Sem_Eval; use Sem_Eval; 39with Sem_Res; use Sem_Res; 40with Sem_Util; use Sem_Util; 41with Sem_Type; use Sem_Type; 42with Snames; use Snames; 43with Stand; use Stand; 44with Sinfo; use Sinfo; 45with Sinfo.Nodes; use Sinfo.Nodes; 46with Sinfo.Utils; use Sinfo.Utils; 47with Stringt; use Stringt; 48with Table; 49with Tbuild; use Tbuild; 50with Uintp; use Uintp; 51 52with Ada.Unchecked_Deallocation; 53 54with GNAT.Heap_Sort_G; 55with GNAT.Sets; 56 57package body Sem_Case is 58 59 type Choice_Bounds is record 60 Lo : Node_Id; 61 Hi : Node_Id; 62 Node : Node_Id; 63 end record; 64 -- Represent one choice bounds entry with Lo and Hi values, Node points 65 -- to the choice node itself. 66 67 type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; 68 -- Table type used to sort the choices present in a case statement or 69 -- record variant. The actual entries are stored in 1 .. Last, but we 70 -- have a 0 entry for use in sorting. 71 72 ----------------------- 73 -- Local Subprograms -- 74 ----------------------- 75 76 procedure Check_Choice_Set 77 (Choice_Table : in out Choice_Table_Type; 78 Bounds_Type : Entity_Id; 79 Subtyp : Entity_Id; 80 Others_Present : Boolean; 81 Case_Node : Node_Id); 82 -- This is the procedure which verifies that a set of case alternatives 83 -- or record variant choices has no duplicates, and covers the range 84 -- specified by Bounds_Type. Choice_Table contains the discrete choices 85 -- to check. These must start at position 1. 86 -- 87 -- Furthermore Choice_Table (0) must exist. This element is used by 88 -- the sorting algorithm as a temporary. Others_Present is a flag 89 -- indicating whether or not an Others choice is present. Finally 90 -- Msg_Sloc gives the source location of the construct containing the 91 -- choices in the Choice_Table. 92 -- 93 -- Bounds_Type is the type whose range must be covered by the alternatives 94 -- 95 -- Subtyp is the subtype of the expression. If its bounds are nonstatic 96 -- the alternatives must cover its base type. 97 98 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; 99 -- Given a Pos value of enumeration type Ctype, returns the name 100 -- ID of an appropriate string to be used in error message output. 101 102 function Has_Static_Discriminant_Constraint 103 (Subtyp : Entity_Id) return Boolean; 104 -- Returns True if the given subtype is subject to a discriminant 105 -- constraint and at least one of the constraint values is nonstatic. 106 107 package Composite_Case_Ops is 108 109 function Box_Value_Required (Subtyp : Entity_Id) return Boolean; 110 -- If result is True, then the only allowed value (in a choice 111 -- aggregate) for a component of this (sub)type is a box. This rule 112 -- means that such a component can be ignored in case alternative 113 -- selection. This in turn implies that it is ok if the component 114 -- type doesn't meet the usual restrictions, such as not being an 115 -- access/task/protected type, since nobody is going to look 116 -- at it. 117 118 function Choice_Count (Alternatives : List_Id) return Nat; 119 -- The sum of the number of choices for each alternative in the given 120 -- list. 121 122 function Normalized_Case_Expr_Type 123 (Case_Statement : Node_Id) return Entity_Id; 124 -- Usually returns the Etype of the selector expression of the 125 -- case statement. However, in the case of a constrained composite 126 -- subtype with a nonstatic constraint, returns the unconstrained 127 -- base type. 128 129 function Scalar_Part_Count (Subtyp : Entity_Id) return Nat; 130 -- Given the composite type Subtyp of a case selector, returns the 131 -- number of scalar parts in an object of this type. This is the 132 -- dimensionality of the associated Cartesian product space. 133 134 package Array_Case_Ops is 135 function Array_Choice_Length (Choice : Node_Id) return Nat; 136 -- Given a choice expression of an array type, returns its length. 137 138 function Unconstrained_Array_Effective_Length 139 (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat; 140 -- If the nominal subtype of the case selector is unconstrained, 141 -- then use the length of the longest choice of the case statement. 142 -- Components beyond that index value will not influence the case 143 -- selection decision. 144 145 function Unconstrained_Array_Scalar_Part_Count 146 (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat; 147 -- Same as Scalar_Part_Count except that the value used for the 148 -- "length" of the array subtype being cased on is determined by 149 -- calling Unconstrained_Array_Effective_Length. 150 end Array_Case_Ops; 151 152 generic 153 Case_Statement : Node_Id; 154 package Choice_Analysis is 155 156 use Array_Case_Ops; 157 158 type Alternative_Id is 159 new Int range 1 .. List_Length (Alternatives (Case_Statement)); 160 type Choice_Id is 161 new Int range 1 .. Choice_Count (Alternatives (Case_Statement)); 162 163 Case_Expr_Type : constant Entity_Id := 164 Normalized_Case_Expr_Type (Case_Statement); 165 166 Unconstrained_Array_Case : constant Boolean := 167 Is_Array_Type (Case_Expr_Type) 168 and then not Is_Constrained (Case_Expr_Type); 169 170 -- If Unconstrained_Array_Case is True, choice lengths may differ: 171 -- when "Aaa" | "Bb" | "C" | "" => 172 -- 173 -- Strictly speaking, the name "Unconstrained_Array_Case" is 174 -- slightly imprecise; a subtype with a nonstatic constraint is 175 -- also treated as unconstrained (see Normalize_Case_Expr_Type). 176 177 type Part_Id is new Int range 178 1 .. (if Unconstrained_Array_Case 179 then Unconstrained_Array_Scalar_Part_Count 180 (Case_Expr_Type, Case_Statement) 181 else Scalar_Part_Count (Case_Expr_Type)); 182 183 type Discrete_Range_Info is 184 record 185 Low, High : Uint; 186 end record; 187 188 type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info; 189 190 type Choice_Range_Info (Is_Others : Boolean := False) is 191 record 192 case Is_Others is 193 when False => 194 Ranges : Composite_Range_Info; 195 when True => 196 null; 197 end case; 198 end record; 199 200 type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info; 201 202 package Value_Sets is 203 204 type Value_Set is private; 205 -- A set of points in the Cartesian product space defined 206 -- by the composite type of the case selector. 207 -- Implemented as an access type. 208 209 type Set_Comparison is 210 (Disjoint, Equal, Contains, Contained_By, Overlaps); 211 212 function Compare (S1, S2 : Value_Set) return Set_Comparison; 213 -- If either argument (or both) is empty, result is Disjoint. 214 -- Otherwise, result is Equal if the two sets are equal. 215 216 Empty : constant Value_Set; 217 218 function Matching_Values 219 (Info : Composite_Range_Info) return Value_Set; 220 -- The Cartesian product of the given array of ranges 221 -- (excluding any values outside the Cartesian product of the 222 -- component ranges). 223 224 procedure Union (Target : in out Value_Set; Source : Value_Set); 225 -- Add elements of Source into Target 226 227 procedure Remove (Target : in out Value_Set; Source : Value_Set); 228 -- Remove elements of Source from Target 229 230 function Complement_Is_Empty (Set : Value_Set) return Boolean; 231 -- Return True iff the set is "maximal", in the sense that it 232 -- includes every value in the Cartesian product of the 233 -- component ranges. 234 235 procedure Free_Value_Sets; 236 -- Reclaim storage associated with implementation of this package. 237 238 private 239 type Value_Set is new Natural; 240 -- An index for a table that will be declared in the package body. 241 242 Empty : constant Value_Set := 0; 243 244 end Value_Sets; 245 246 type Single_Choice_Info (Is_Others : Boolean := False) is 247 record 248 Alternative : Alternative_Id; 249 case Is_Others is 250 when False => 251 Matches : Value_Sets.Value_Set; 252 when True => 253 null; 254 end case; 255 end record; 256 257 type Choices_Info is array (Choice_Id) of Single_Choice_Info; 258 259 function Analysis return Choices_Info; 260 -- Parse the case choices in order to determine the set of 261 -- matching values associated with each choice. 262 263 type Bound_Values is array (Positive range <>) of Node_Id; 264 265 end Choice_Analysis; 266 267 end Composite_Case_Ops; 268 269 procedure Expand_Others_Choice 270 (Case_Table : Choice_Table_Type; 271 Others_Choice : Node_Id; 272 Choice_Type : Entity_Id); 273 -- The case table is the table generated by a call to Check_Choices 274 -- (with just 1 .. Last_Choice entries present). Others_Choice is a 275 -- pointer to the N_Others_Choice node (this routine is only called if 276 -- an others choice is present), and Choice_Type is the discrete type 277 -- of the bounds. The effect of this call is to analyze the cases and 278 -- determine the set of values covered by others. This choice list is 279 -- set in the Others_Discrete_Choices field of the N_Others_Choice node. 280 281 ---------------------- 282 -- Check_Choice_Set -- 283 ---------------------- 284 285 procedure Check_Choice_Set 286 (Choice_Table : in out Choice_Table_Type; 287 Bounds_Type : Entity_Id; 288 Subtyp : Entity_Id; 289 Others_Present : Boolean; 290 Case_Node : Node_Id) 291 is 292 Predicate_Error : Boolean := False; 293 -- Flag to prevent cascaded errors when a static predicate is known to 294 -- be violated by one choice. 295 296 Num_Choices : constant Nat := Choice_Table'Last; 297 298 procedure Check_Against_Predicate 299 (Pred : in out Node_Id; 300 Choice : Choice_Bounds; 301 Prev_Lo : in out Uint; 302 Prev_Hi : in out Uint; 303 Error : in out Boolean); 304 -- Determine whether a choice covers legal values as defined by a static 305 -- predicate set. Pred is a static predicate range. Choice is the choice 306 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous 307 -- choice that covered a predicate set. Error denotes whether the check 308 -- found an illegal intersection. 309 310 procedure Check_Duplicates; 311 -- Check for duplicate choices, and call Dup_Choice if there are any 312 -- such errors. Note that predicates are irrelevant here. 313 314 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); 315 -- Post message "duplication of choice value(s) bla bla at xx". Message 316 -- is posted at location C. Caller sets Error_Msg_Sloc for xx. 317 318 procedure Explain_Non_Static_Bound; 319 -- Called when we find a nonstatic bound, requiring the base type to 320 -- be covered. Provides where possible a helpful explanation of why the 321 -- bounds are nonstatic, since this is not always obvious. 322 323 function Lt_Choice (C1, C2 : Natural) return Boolean; 324 -- Comparison routine for comparing Choice_Table entries. Use the lower 325 -- bound of each Choice as the key. 326 327 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id); 328 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint); 329 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id); 330 procedure Missing_Choice (Value1 : Uint; Value2 : Uint); 331 -- Issue an error message indicating that there are missing choices, 332 -- followed by the image of the missing choices themselves which lie 333 -- between Value1 and Value2 inclusive. 334 335 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint); 336 -- Emit an error message for each non-covered static predicate set. 337 -- Prev_Hi denotes the upper bound of the last choice covering a set. 338 339 procedure Move_Choice (From : Natural; To : Natural); 340 -- Move routine for sorting the Choice_Table 341 342 package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); 343 344 ----------------------------- 345 -- Check_Against_Predicate -- 346 ----------------------------- 347 348 procedure Check_Against_Predicate 349 (Pred : in out Node_Id; 350 Choice : Choice_Bounds; 351 Prev_Lo : in out Uint; 352 Prev_Hi : in out Uint; 353 Error : in out Boolean) 354 is 355 procedure Illegal_Range 356 (Loc : Source_Ptr; 357 Lo : Uint; 358 Hi : Uint); 359 -- Emit an error message regarding a choice that clashes with the 360 -- legal static predicate sets. Loc is the location of the choice 361 -- that introduced the illegal range. Lo .. Hi is the range. 362 363 function Inside_Range 364 (Lo : Uint; 365 Hi : Uint; 366 Val : Uint) return Boolean; 367 -- Determine whether position Val within a discrete type is within 368 -- the range Lo .. Hi inclusive. 369 370 ------------------- 371 -- Illegal_Range -- 372 ------------------- 373 374 procedure Illegal_Range 375 (Loc : Source_Ptr; 376 Lo : Uint; 377 Hi : Uint) 378 is 379 begin 380 Error_Msg_Name_1 := Chars (Bounds_Type); 381 382 -- Single value 383 384 if Lo = Hi then 385 if Is_Integer_Type (Bounds_Type) then 386 Error_Msg_Uint_1 := Lo; 387 Error_Msg ("static predicate on % excludes value ^!", Loc); 388 else 389 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); 390 Error_Msg ("static predicate on % excludes value %!", Loc); 391 end if; 392 393 -- Range 394 395 else 396 if Is_Integer_Type (Bounds_Type) then 397 Error_Msg_Uint_1 := Lo; 398 Error_Msg_Uint_2 := Hi; 399 Error_Msg 400 ("static predicate on % excludes range ^ .. ^!", Loc); 401 else 402 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); 403 Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type); 404 Error_Msg 405 ("static predicate on % excludes range % .. %!", Loc); 406 end if; 407 end if; 408 end Illegal_Range; 409 410 ------------------ 411 -- Inside_Range -- 412 ------------------ 413 414 function Inside_Range 415 (Lo : Uint; 416 Hi : Uint; 417 Val : Uint) return Boolean 418 is 419 begin 420 return Lo <= Val and then Val <= Hi; 421 end Inside_Range; 422 423 -- Local variables 424 425 Choice_Hi : constant Uint := Expr_Value (Choice.Hi); 426 Choice_Lo : constant Uint := Expr_Value (Choice.Lo); 427 Loc : Source_Ptr; 428 LocN : Node_Id; 429 Next_Hi : Uint; 430 Next_Lo : Uint; 431 Pred_Hi : Uint; 432 Pred_Lo : Uint; 433 434 -- Start of processing for Check_Against_Predicate 435 436 begin 437 -- Find the proper error message location 438 439 if Present (Choice.Node) then 440 LocN := Choice.Node; 441 else 442 LocN := Case_Node; 443 end if; 444 445 Loc := Sloc (LocN); 446 447 if Present (Pred) then 448 Pred_Lo := Expr_Value (Low_Bound (Pred)); 449 Pred_Hi := Expr_Value (High_Bound (Pred)); 450 451 -- Previous choices managed to satisfy all static predicate sets 452 453 else 454 Illegal_Range (Loc, Choice_Lo, Choice_Hi); 455 Error := True; 456 return; 457 end if; 458 459 -- Step 1: Ignore duplicate choices, other than to set the flag, 460 -- because these were already detected by Check_Duplicates. 461 462 if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) 463 or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) 464 then 465 Error := True; 466 467 -- Step 2: Detect full coverage 468 469 -- Choice_Lo Choice_Hi 470 -- +============+ 471 -- Pred_Lo Pred_Hi 472 473 elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then 474 Prev_Lo := Choice_Lo; 475 Prev_Hi := Choice_Hi; 476 Next (Pred); 477 478 -- Step 3: Detect all cases where a choice mentions values that are 479 -- not part of the static predicate sets. 480 481 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi 482 -- +-----------+ . . . . . +=========+ 483 -- ^ illegal ^ 484 485 elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then 486 Illegal_Range (Loc, Choice_Lo, Choice_Hi); 487 Error := True; 488 489 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi 490 -- +-----------+=========+===========+ 491 -- ^ illegal ^ 492 493 elsif Choice_Lo < Pred_Lo 494 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi) 495 then 496 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); 497 Error := True; 498 499 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi 500 -- +=========+ . . . . +-----------+ 501 -- ^ illegal ^ 502 503 elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then 504 if Others_Present then 505 506 -- Current predicate set is covered by others clause. 507 508 null; 509 510 else 511 Missing_Choice (Pred_Lo, Pred_Hi); 512 Error := True; 513 end if; 514 515 -- There may be several static predicate sets between the current 516 -- one and the choice. Inspect the next static predicate set. 517 518 Next (Pred); 519 Check_Against_Predicate 520 (Pred => Pred, 521 Choice => Choice, 522 Prev_Lo => Prev_Lo, 523 Prev_Hi => Prev_Hi, 524 Error => Error); 525 526 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi 527 -- +=========+===========+-----------+ 528 -- ^ illegal ^ 529 530 elsif Pred_Hi < Choice_Hi 531 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo) 532 then 533 Next (Pred); 534 535 -- The choice may fall in a static predicate set. If this is the 536 -- case, avoid mentioning legal values in the error message. 537 538 if Present (Pred) then 539 Next_Lo := Expr_Value (Low_Bound (Pred)); 540 Next_Hi := Expr_Value (High_Bound (Pred)); 541 542 -- The next static predicate set is to the right of the choice 543 544 if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then 545 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); 546 else 547 Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1); 548 end if; 549 else 550 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); 551 end if; 552 553 Error := True; 554 555 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi 556 -- +-----------+=========+-----------+ 557 -- ^ illegal ^ ^ illegal ^ 558 559 -- Emit an error on the low gap, disregard the upper gap 560 561 elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then 562 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); 563 Error := True; 564 565 -- Step 4: Detect all cases of partial or missing coverage 566 567 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi 568 -- +=========+==========+===========+ 569 -- ^ gap ^ ^ gap ^ 570 571 else 572 -- An "others" choice covers all gaps 573 574 if Others_Present then 575 Prev_Lo := Choice_Lo; 576 Prev_Hi := Choice_Hi; 577 578 -- Check whether predicate set is fully covered by choice 579 580 if Pred_Hi = Choice_Hi then 581 Next (Pred); 582 end if; 583 584 -- Choice_Lo Choice_Hi Pred_Hi 585 -- +===========+===========+ 586 -- Pred_Lo ^ gap ^ 587 588 -- The upper gap may be covered by a subsequent choice 589 590 elsif Pred_Lo = Choice_Lo then 591 Prev_Lo := Choice_Lo; 592 Prev_Hi := Choice_Hi; 593 594 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi 595 -- +===========+=========+===========+===========+ 596 -- ^ covered ^ ^ gap ^ 597 598 else pragma Assert (Pred_Lo < Choice_Lo); 599 600 -- A previous choice covered the gap up to the current choice 601 602 if Prev_Hi = Choice_Lo - 1 then 603 Prev_Lo := Choice_Lo; 604 Prev_Hi := Choice_Hi; 605 606 if Choice_Hi = Pred_Hi then 607 Next (Pred); 608 end if; 609 610 -- The previous choice did not intersect with the current 611 -- static predicate set. 612 613 elsif Prev_Hi < Pred_Lo then 614 Missing_Choice (Pred_Lo, Choice_Lo - 1); 615 Error := True; 616 617 -- The previous choice covered part of the static predicate set 618 -- but there is a gap after Prev_Hi. 619 620 else 621 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); 622 Error := True; 623 end if; 624 end if; 625 end if; 626 end Check_Against_Predicate; 627 628 ---------------------- 629 -- Check_Duplicates -- 630 ---------------------- 631 632 procedure Check_Duplicates is 633 Choice : Node_Id; 634 Choice_Hi : Uint; 635 Choice_Lo : Uint; 636 Prev_Choice : Node_Id := Empty; 637 Prev_Hi : Uint; 638 639 begin 640 Prev_Hi := Expr_Value (Choice_Table (1).Hi); 641 642 for Outer_Index in 2 .. Num_Choices loop 643 Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); 644 Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); 645 646 -- Choices overlap; this is an error 647 648 if Choice_Lo <= Prev_Hi then 649 Choice := Choice_Table (Outer_Index).Node; 650 651 -- Find first previous choice that overlaps 652 653 for Inner_Index in 1 .. Outer_Index - 1 loop 654 if Choice_Lo <= 655 Expr_Value (Choice_Table (Inner_Index).Hi) 656 then 657 Prev_Choice := Choice_Table (Inner_Index).Node; 658 exit; 659 end if; 660 end loop; 661 662 pragma Assert (Present (Prev_Choice)); 663 664 if Sloc (Prev_Choice) <= Sloc (Choice) then 665 Error_Msg_Sloc := Sloc (Prev_Choice); 666 Dup_Choice (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); 667 else 668 Error_Msg_Sloc := Sloc (Choice); 669 Dup_Choice 670 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); 671 end if; 672 end if; 673 674 if Choice_Hi > Prev_Hi then 675 Prev_Hi := Choice_Hi; 676 end if; 677 end loop; 678 end Check_Duplicates; 679 680 ---------------- 681 -- Dup_Choice -- 682 ---------------- 683 684 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is 685 begin 686 -- In some situations, we call this with a null range, and obviously 687 -- we don't want to complain in this case. 688 689 if Lo > Hi then 690 return; 691 end if; 692 693 -- Case of only one value that is duplicated 694 695 if Lo = Hi then 696 697 -- Integer type 698 699 if Is_Integer_Type (Bounds_Type) then 700 701 -- We have an integer value, Lo, but if the given choice 702 -- placement is a constant with that value, then use the 703 -- name of that constant instead in the message: 704 705 if Nkind (C) = N_Identifier 706 and then Compile_Time_Known_Value (C) 707 and then Expr_Value (C) = Lo 708 then 709 Error_Msg_N 710 ("duplication of choice value: &#!", Original_Node (C)); 711 712 -- Not that special case, so just output the integer value 713 714 else 715 Error_Msg_Uint_1 := Lo; 716 Error_Msg_N 717 ("duplication of choice value: ^#!", Original_Node (C)); 718 end if; 719 720 -- Enumeration type 721 722 else 723 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); 724 Error_Msg_N 725 ("duplication of choice value: %#!", Original_Node (C)); 726 end if; 727 728 -- More than one choice value, so print range of values 729 730 else 731 -- Integer type 732 733 if Is_Integer_Type (Bounds_Type) then 734 735 -- Similar to the above, if C is a range of known values which 736 -- match Lo and Hi, then use the names. We have to go to the 737 -- original nodes, since the values will have been rewritten 738 -- to their integer values. 739 740 if Nkind (C) = N_Range 741 and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier 742 and then Nkind (Original_Node (High_Bound (C))) = N_Identifier 743 and then Compile_Time_Known_Value (Low_Bound (C)) 744 and then Compile_Time_Known_Value (High_Bound (C)) 745 and then Expr_Value (Low_Bound (C)) = Lo 746 and then Expr_Value (High_Bound (C)) = Hi 747 then 748 Error_Msg_Node_2 := Original_Node (High_Bound (C)); 749 Error_Msg_N 750 ("duplication of choice values: & .. &#!", 751 Original_Node (Low_Bound (C))); 752 753 -- Not that special case, output integer values 754 755 else 756 Error_Msg_Uint_1 := Lo; 757 Error_Msg_Uint_2 := Hi; 758 Error_Msg_N 759 ("duplication of choice values: ^ .. ^#!", 760 Original_Node (C)); 761 end if; 762 763 -- Enumeration type 764 765 else 766 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); 767 Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); 768 Error_Msg_N 769 ("duplication of choice values: % .. %#!", Original_Node (C)); 770 end if; 771 end if; 772 end Dup_Choice; 773 774 ------------------------------ 775 -- Explain_Non_Static_Bound -- 776 ------------------------------ 777 778 procedure Explain_Non_Static_Bound is 779 Expr : Node_Id; 780 781 begin 782 if Nkind (Case_Node) = N_Variant_Part then 783 Expr := Name (Case_Node); 784 else 785 Expr := Expression (Case_Node); 786 end if; 787 788 if Bounds_Type /= Subtyp then 789 790 -- If the case is a variant part, the expression is given by the 791 -- discriminant itself, and the bounds are the culprits. 792 793 if Nkind (Case_Node) = N_Variant_Part then 794 Error_Msg_NE 795 ("bounds of & are not static, " 796 & "alternatives must cover base type!", Expr, Expr); 797 798 -- If this is a case statement, the expression may be nonstatic 799 -- or else the subtype may be at fault. 800 801 elsif Is_Entity_Name (Expr) then 802 Error_Msg_NE 803 ("bounds of & are not static, " 804 & "alternatives must cover base type!", Expr, Expr); 805 806 else 807 Error_Msg_N 808 ("subtype of expression is not static, " 809 & "alternatives must cover base type!", Expr); 810 end if; 811 812 -- Otherwise the expression is not static, even if the bounds of the 813 -- type are, or else there are missing alternatives. If both, the 814 -- additional information may be redundant but harmless. Examine 815 -- whether original node is an entity, because it may have been 816 -- constant-folded to a literal if value is known. 817 818 elsif not Is_Entity_Name (Original_Node (Expr)) then 819 Error_Msg_N 820 ("subtype of expression is not static, " 821 & "alternatives must cover base type!", Expr); 822 end if; 823 end Explain_Non_Static_Bound; 824 825 --------------- 826 -- Lt_Choice -- 827 --------------- 828 829 function Lt_Choice (C1, C2 : Natural) return Boolean is 830 begin 831 return 832 Expr_Value (Choice_Table (Nat (C1)).Lo) 833 < 834 Expr_Value (Choice_Table (Nat (C2)).Lo); 835 end Lt_Choice; 836 837 -------------------- 838 -- Missing_Choice -- 839 -------------------- 840 841 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is 842 begin 843 Missing_Choice (Expr_Value (Value1), Expr_Value (Value2)); 844 end Missing_Choice; 845 846 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is 847 begin 848 Missing_Choice (Expr_Value (Value1), Value2); 849 end Missing_Choice; 850 851 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is 852 begin 853 Missing_Choice (Value1, Expr_Value (Value2)); 854 end Missing_Choice; 855 856 -------------------- 857 -- Missing_Choice -- 858 -------------------- 859 860 procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is 861 begin 862 -- AI05-0188 : within an instance the non-others choices do not have 863 -- to belong to the actual subtype. 864 865 if Ada_Version >= Ada_2012 and then In_Instance then 866 return; 867 868 -- In some situations, we call this with a null range, and obviously 869 -- we don't want to complain in this case. 870 871 elsif Value1 > Value2 then 872 return; 873 874 -- If predicate is already known to be violated, do not check for 875 -- coverage error, to prevent cascaded messages. 876 877 elsif Predicate_Error then 878 return; 879 end if; 880 881 -- Case of only one value that is missing 882 883 if Value1 = Value2 then 884 if Is_Integer_Type (Bounds_Type) then 885 Error_Msg_Uint_1 := Value1; 886 Error_Msg_N ("missing case value: ^!", Case_Node); 887 else 888 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); 889 Error_Msg_N ("missing case value: %!", Case_Node); 890 end if; 891 892 -- More than one choice value, so print range of values 893 894 else 895 if Is_Integer_Type (Bounds_Type) then 896 Error_Msg_Uint_1 := Value1; 897 Error_Msg_Uint_2 := Value2; 898 Error_Msg_N ("missing case values: ^ .. ^!", Case_Node); 899 else 900 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); 901 Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); 902 Error_Msg_N ("missing case values: % .. %!", Case_Node); 903 end if; 904 end if; 905 end Missing_Choice; 906 907 --------------------- 908 -- Missing_Choices -- 909 --------------------- 910 911 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is 912 Hi : Uint; 913 Lo : Uint; 914 Set : Node_Id; 915 916 begin 917 Set := Pred; 918 while Present (Set) loop 919 Lo := Expr_Value (Low_Bound (Set)); 920 Hi := Expr_Value (High_Bound (Set)); 921 922 -- A choice covered part of a static predicate set 923 924 if Lo <= Prev_Hi and then Prev_Hi < Hi then 925 Missing_Choice (Prev_Hi + 1, Hi); 926 927 else 928 Missing_Choice (Lo, Hi); 929 end if; 930 931 Next (Set); 932 end loop; 933 end Missing_Choices; 934 935 ----------------- 936 -- Move_Choice -- 937 ----------------- 938 939 procedure Move_Choice (From : Natural; To : Natural) is 940 begin 941 Choice_Table (Nat (To)) := Choice_Table (Nat (From)); 942 end Move_Choice; 943 944 -- Local variables 945 946 Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); 947 Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); 948 Has_Predicate : constant Boolean := 949 Is_OK_Static_Subtype (Bounds_Type) 950 and then Has_Static_Predicate (Bounds_Type); 951 952 Choice_Hi : Uint; 953 Choice_Lo : Uint; 954 Pred : Node_Id; 955 Prev_Lo : Uint; 956 Prev_Hi : Uint; 957 958 -- Start of processing for Check_Choice_Set 959 960 begin 961 -- If the case is part of a predicate aspect specification, do not 962 -- recheck it against itself. 963 964 if Present (Parent (Case_Node)) 965 and then Nkind (Parent (Case_Node)) = N_Aspect_Specification 966 then 967 return; 968 end if; 969 970 -- Choice_Table must start at 0 which is an unused location used by the 971 -- sorting algorithm. However the first valid position for a discrete 972 -- choice is 1. 973 974 pragma Assert (Choice_Table'First = 0); 975 976 -- The choices do not cover the base range. Emit an error if "others" is 977 -- not available and return as there is no need for further processing. 978 979 if Num_Choices = 0 then 980 if not Others_Present then 981 Missing_Choice (Bounds_Lo, Bounds_Hi); 982 end if; 983 984 return; 985 end if; 986 987 Sorting.Sort (Positive (Choice_Table'Last)); 988 989 -- First check for duplicates. This involved the choices; predicates, if 990 -- any, are irrelevant. 991 992 Check_Duplicates; 993 994 -- Then check for overlaps 995 996 -- If the subtype has a static predicate, the predicate defines subsets 997 -- of legal values and requires finer-grained analysis. 998 999 -- Note that in GNAT the predicate is considered static if the predicate 1000 -- expression is static, independently of whether the aspect mentions 1001 -- Static explicitly. 1002 1003 if Has_Predicate then 1004 Pred := First (Static_Discrete_Predicate (Bounds_Type)); 1005 1006 -- Make initial value smaller than 'First of type, so that first 1007 -- range comparison succeeds. This applies both to integer types 1008 -- and to enumeration types. 1009 1010 Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1; 1011 Prev_Hi := Prev_Lo; 1012 1013 declare 1014 Error : Boolean := False; 1015 begin 1016 for Index in 1 .. Num_Choices loop 1017 Check_Against_Predicate 1018 (Pred => Pred, 1019 Choice => Choice_Table (Index), 1020 Prev_Lo => Prev_Lo, 1021 Prev_Hi => Prev_Hi, 1022 Error => Error); 1023 1024 -- The analysis detected an illegal intersection between a 1025 -- choice and a static predicate set. Do not examine other 1026 -- choices unless all errors are requested. 1027 1028 if Error then 1029 Predicate_Error := True; 1030 1031 if not All_Errors_Mode then 1032 return; 1033 end if; 1034 end if; 1035 end loop; 1036 end; 1037 1038 if Predicate_Error then 1039 return; 1040 end if; 1041 1042 -- The choices may legally cover some of the static predicate sets, 1043 -- but not all. Emit an error for each non-covered set. 1044 1045 if not Others_Present then 1046 Missing_Choices (Pred, Prev_Hi); 1047 end if; 1048 1049 -- Default analysis 1050 1051 else 1052 Choice_Lo := Expr_Value (Choice_Table (1).Lo); 1053 Choice_Hi := Expr_Value (Choice_Table (1).Hi); 1054 Prev_Hi := Choice_Hi; 1055 1056 if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then 1057 Missing_Choice (Bounds_Lo, Choice_Lo - 1); 1058 1059 -- If values are missing outside of the subtype, add explanation. 1060 -- No additional message if only one value is missing. 1061 1062 if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then 1063 Explain_Non_Static_Bound; 1064 end if; 1065 end if; 1066 1067 for Index in 2 .. Num_Choices loop 1068 Choice_Lo := Expr_Value (Choice_Table (Index).Lo); 1069 Choice_Hi := Expr_Value (Choice_Table (Index).Hi); 1070 1071 if Choice_Lo > Prev_Hi + 1 and then not Others_Present then 1072 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); 1073 end if; 1074 1075 if Choice_Hi > Prev_Hi then 1076 Prev_Hi := Choice_Hi; 1077 end if; 1078 end loop; 1079 1080 if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then 1081 Missing_Choice (Prev_Hi + 1, Bounds_Hi); 1082 1083 if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then 1084 Explain_Non_Static_Bound; 1085 end if; 1086 end if; 1087 end if; 1088 end Check_Choice_Set; 1089 1090 ------------------ 1091 -- Choice_Image -- 1092 ------------------ 1093 1094 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is 1095 Rtp : constant Entity_Id := Root_Type (Ctype); 1096 Lit : Entity_Id; 1097 C : Int; 1098 1099 begin 1100 -- For character, or wide [wide] character. If 7-bit ASCII graphic 1101 -- range, then build and return appropriate character literal name 1102 1103 if Is_Standard_Character_Type (Ctype) then 1104 C := UI_To_Int (Value); 1105 1106 if C in 16#20# .. 16#7E# then 1107 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 1108 return Name_Find; 1109 end if; 1110 1111 -- For user defined enumeration type, find enum/char literal 1112 1113 else 1114 Lit := First_Literal (Rtp); 1115 1116 for J in 1 .. UI_To_Int (Value) loop 1117 Next_Literal (Lit); 1118 end loop; 1119 1120 -- If enumeration literal, just return its value 1121 1122 if Nkind (Lit) = N_Defining_Identifier then 1123 return Chars (Lit); 1124 1125 -- For character literal, get the name and use it if it is 1126 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. 1127 1128 else 1129 Get_Decoded_Name_String (Chars (Lit)); 1130 1131 if Name_Len = 3 1132 and then Name_Buffer (2) in 1133 Character'Val (16#20#) .. Character'Val (16#7E#) 1134 then 1135 return Chars (Lit); 1136 end if; 1137 end if; 1138 end if; 1139 1140 -- If we fall through, we have a character literal which is not in 1141 -- the 7-bit ASCII graphic set. For such cases, we construct the 1142 -- name "type'val(nnn)" where type is the choice type, and nnn is 1143 -- the pos value passed as an argument to Choice_Image. 1144 1145 Get_Name_String (Chars (First_Subtype (Ctype))); 1146 1147 Add_Str_To_Name_Buffer ("'val("); 1148 UI_Image (Value); 1149 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); 1150 Add_Char_To_Name_Buffer (')'); 1151 return Name_Find; 1152 end Choice_Image; 1153 1154 package body Composite_Case_Ops is 1155 1156 function Static_Array_Length (Subtyp : Entity_Id) return Nat; 1157 -- Given a one-dimensional constrained array subtype with 1158 -- statically known bounds, return its length. 1159 1160 ------------------------- 1161 -- Static_Array_Length -- 1162 ------------------------- 1163 1164 function Static_Array_Length (Subtyp : Entity_Id) return Nat is 1165 pragma Assert (Is_Constrained (Subtyp)); 1166 pragma Assert (Number_Dimensions (Subtyp) = 1); 1167 Index : constant Node_Id := First_Index (Subtyp); 1168 pragma Assert (Is_OK_Static_Range (Index)); 1169 Lo : constant Uint := Expr_Value (Low_Bound (Index)); 1170 Hi : constant Uint := Expr_Value (High_Bound (Index)); 1171 Len : constant Uint := UI_Max (0, (Hi - Lo) + 1); 1172 begin 1173 return UI_To_Int (Len); 1174 end Static_Array_Length; 1175 1176 ------------------------ 1177 -- Box_Value_Required -- 1178 ------------------------ 1179 1180 function Box_Value_Required (Subtyp : Entity_Id) return Boolean is 1181 -- Some of these restrictions will be relaxed eventually, but best 1182 -- to initially err in the direction of being too restrictive. 1183 begin 1184 if Has_Predicates (Subtyp) then 1185 return True; 1186 elsif Is_Discrete_Type (Subtyp) then 1187 if not Is_Static_Subtype (Subtyp) then 1188 return True; 1189 elsif Is_Enumeration_Type (Subtyp) 1190 and then Has_Enumeration_Rep_Clause (Subtyp) 1191 -- Maybe enumeration rep clauses can be ignored here? 1192 then 1193 return True; 1194 end if; 1195 elsif Is_Array_Type (Subtyp) then 1196 if Number_Dimensions (Subtyp) /= 1 then 1197 return True; 1198 elsif not Is_Constrained (Subtyp) then 1199 if not Is_Static_Subtype (Etype (First_Index (Subtyp))) then 1200 return True; 1201 end if; 1202 elsif not Is_OK_Static_Range (First_Index (Subtyp)) then 1203 return True; 1204 end if; 1205 elsif Is_Record_Type (Subtyp) then 1206 if Has_Discriminants (Subtyp) 1207 and then Is_Constrained (Subtyp) 1208 and then not Has_Static_Discriminant_Constraint (Subtyp) 1209 then 1210 -- Perhaps treat differently the case where Subtyp is the 1211 -- subtype of the top-level selector expression, as opposed 1212 -- to the subtype of some subcomponent thereof. 1213 return True; 1214 end if; 1215 else 1216 -- Return True for any type that is not a discrete type, 1217 -- a record type, or an array type. 1218 return True; 1219 end if; 1220 1221 return False; 1222 end Box_Value_Required; 1223 1224 ------------------ 1225 -- Choice_Count -- 1226 ------------------ 1227 1228 function Choice_Count (Alternatives : List_Id) return Nat is 1229 Result : Nat := 0; 1230 Alt : Node_Id := First (Alternatives); 1231 begin 1232 while Present (Alt) loop 1233 Result := Result + List_Length (Discrete_Choices (Alt)); 1234 Next (Alt); 1235 end loop; 1236 return Result; 1237 end Choice_Count; 1238 1239 ------------------------------- 1240 -- Normalized_Case_Expr_Type -- 1241 ------------------------------- 1242 1243 function Normalized_Case_Expr_Type 1244 (Case_Statement : Node_Id) return Entity_Id 1245 is 1246 Unnormalized : constant Entity_Id := 1247 Etype (Expression (Case_Statement)); 1248 1249 Is_Dynamically_Constrained_Array : constant Boolean := 1250 Is_Array_Type (Unnormalized) 1251 and then Is_Constrained (Unnormalized) 1252 and then not Has_Static_Array_Bounds (Unnormalized); 1253 1254 Is_Dynamically_Constrained_Record : constant Boolean := 1255 Is_Record_Type (Unnormalized) 1256 and then Has_Discriminants (Unnormalized) 1257 and then Is_Constrained (Unnormalized) 1258 and then not Has_Static_Discriminant_Constraint (Unnormalized); 1259 begin 1260 if Is_Dynamically_Constrained_Array 1261 or Is_Dynamically_Constrained_Record 1262 then 1263 return Base_Type (Unnormalized); 1264 else 1265 return Unnormalized; 1266 end if; 1267 end Normalized_Case_Expr_Type; 1268 1269 ----------------------- 1270 -- Scalar_Part_Count -- 1271 ----------------------- 1272 1273 function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is 1274 begin 1275 if Box_Value_Required (Subtyp) then 1276 return 0; -- component does not participate in case selection 1277 elsif Is_Scalar_Type (Subtyp) then 1278 return 1; 1279 elsif Is_Array_Type (Subtyp) then 1280 return Static_Array_Length (Subtyp) 1281 * Scalar_Part_Count (Component_Type (Subtyp)); 1282 elsif Is_Record_Type (Subtyp) then 1283 declare 1284 Result : Nat := 0; 1285 Comp : Entity_Id := First_Component_Or_Discriminant 1286 (Base_Type (Subtyp)); 1287 begin 1288 while Present (Comp) loop 1289 Result := Result + Scalar_Part_Count (Etype (Comp)); 1290 Next_Component_Or_Discriminant (Comp); 1291 end loop; 1292 return Result; 1293 end; 1294 else 1295 pragma Assert (Serious_Errors_Detected > 0); 1296 return 0; 1297 end if; 1298 end Scalar_Part_Count; 1299 1300 package body Array_Case_Ops is 1301 1302 ------------------------- 1303 -- Array_Choice_Length -- 1304 ------------------------- 1305 1306 function Array_Choice_Length (Choice : Node_Id) return Nat is 1307 begin 1308 case Nkind (Choice) is 1309 when N_String_Literal => 1310 return String_Length (Strval (Choice)); 1311 when N_Aggregate => 1312 declare 1313 Bounds : constant Node_Id := 1314 Aggregate_Bounds (Choice); 1315 pragma Assert (Is_OK_Static_Range (Bounds)); 1316 Lo : constant Uint := 1317 Expr_Value (Low_Bound (Bounds)); 1318 Hi : constant Uint := 1319 Expr_Value (High_Bound (Bounds)); 1320 Len : constant Uint := (Hi - Lo) + 1; 1321 begin 1322 return UI_To_Int (Len); 1323 end; 1324 when N_Has_Entity => 1325 if Present (Entity (Choice)) 1326 and then Ekind (Entity (Choice)) = E_Constant 1327 then 1328 return Array_Choice_Length 1329 (Expression (Parent (Entity (Choice)))); 1330 end if; 1331 when N_Others_Choice => 1332 return 0; 1333 when others => 1334 null; 1335 end case; 1336 1337 if Nkind (Original_Node (Choice)) 1338 in N_String_Literal | N_Aggregate 1339 then 1340 return Array_Choice_Length (Original_Node (Choice)); 1341 end if; 1342 1343 Error_Msg_N ("Unsupported case choice", Choice); 1344 return 0; 1345 end Array_Choice_Length; 1346 1347 ------------------------------------------ 1348 -- Unconstrained_Array_Effective_Length -- 1349 ------------------------------------------ 1350 1351 function Unconstrained_Array_Effective_Length 1352 (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat 1353 is 1354 pragma Assert (Is_Array_Type (Array_Type)); 1355 -- Array_Type is otherwise unreferenced for now. 1356 1357 Result : Nat := 0; 1358 Alt : Node_Id := First (Alternatives (Case_Statement)); 1359 begin 1360 while Present (Alt) loop 1361 declare 1362 Choice : Node_Id := First (Discrete_Choices (Alt)); 1363 begin 1364 while Present (Choice) loop 1365 Result := Nat'Max (Result, Array_Choice_Length (Choice)); 1366 Next (Choice); 1367 end loop; 1368 end; 1369 Next (Alt); 1370 end loop; 1371 1372 return Result; 1373 end Unconstrained_Array_Effective_Length; 1374 1375 ------------------------------------------- 1376 -- Unconstrained_Array_Scalar_Part_Count -- 1377 ------------------------------------------- 1378 1379 function Unconstrained_Array_Scalar_Part_Count 1380 (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat 1381 is 1382 begin 1383 -- Add one for the length, which is treated like a discriminant 1384 1385 return 1 + (Unconstrained_Array_Effective_Length 1386 (Array_Type => Array_Type, 1387 Case_Statement => Case_Statement) 1388 * Scalar_Part_Count (Component_Type (Array_Type))); 1389 end Unconstrained_Array_Scalar_Part_Count; 1390 1391 end Array_Case_Ops; 1392 1393 package body Choice_Analysis is 1394 1395 function Component_Bounds_Info return Composite_Range_Info; 1396 -- Returns the (statically known) bounds for each component. 1397 -- The selector expression value (or any other value of the type 1398 -- of the selector expression) can be thought of as a point in the 1399 -- Cartesian product of these sets. 1400 1401 function Parse_Choice (Choice : Node_Id; 1402 Alt : Node_Id) return Choice_Range_Info; 1403 -- Extract Choice_Range_Info from a Choice node 1404 1405 --------------------------- 1406 -- Component_Bounds_Info -- 1407 --------------------------- 1408 1409 function Component_Bounds_Info return Composite_Range_Info is 1410 Result : Composite_Range_Info; 1411 Next : Part_Id := 1; 1412 Done : Boolean := False; 1413 1414 procedure Update_Result (Info : Discrete_Range_Info); 1415 -- Initialize first remaining uninitialized element of Result. 1416 -- Also set Next and Done. 1417 1418 ------------------- 1419 -- Update_Result -- 1420 ------------------- 1421 1422 procedure Update_Result (Info : Discrete_Range_Info) is 1423 begin 1424 Result (Next) := Info; 1425 if Next /= Part_Id'Last then 1426 Next := Next + 1; 1427 else 1428 pragma Assert (not Done); 1429 Done := True; 1430 end if; 1431 end Update_Result; 1432 1433 procedure Traverse_Discrete_Parts (Subtyp : Entity_Id); 1434 -- Traverse the given subtype, looking for discrete parts. 1435 -- For an array subtype of length N, the element subtype 1436 -- is traversed N times. For a record subtype, traverse 1437 -- each component's subtype (once). When a discrete part is 1438 -- found, call Update_Result. 1439 1440 ----------------------------- 1441 -- Traverse_Discrete_Parts -- 1442 ----------------------------- 1443 1444 procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is 1445 begin 1446 if Box_Value_Required (Subtyp) then 1447 return; 1448 end if; 1449 1450 if Is_Discrete_Type (Subtyp) then 1451 Update_Result 1452 ((Low => Expr_Value (Type_Low_Bound (Subtyp)), 1453 High => Expr_Value (Type_High_Bound (Subtyp)))); 1454 elsif Is_Array_Type (Subtyp) then 1455 declare 1456 Len : Nat; 1457 begin 1458 if Is_Constrained (Subtyp) then 1459 Len := Static_Array_Length (Subtyp); 1460 else 1461 -- Length will be treated like a discriminant; 1462 -- We could compute High more precisely as 1463 -- 1 + Index_Subtype'Last - Index_Subtype'First 1464 -- (we currently require that those bounds be 1465 -- static, so this is an option), but only downside of 1466 -- overshooting is if somebody wants to omit a 1467 -- "when others" choice and exhaustively cover all 1468 -- possibilities explicitly. 1469 Update_Result 1470 ((Low => Uint_0, 1471 High => Uint_2 ** Uint_32)); 1472 1473 Len := Unconstrained_Array_Effective_Length 1474 (Array_Type => Subtyp, 1475 Case_Statement => Case_Statement); 1476 end if; 1477 for I in 1 .. Len loop 1478 Traverse_Discrete_Parts (Component_Type (Subtyp)); 1479 end loop; 1480 end; 1481 elsif Is_Record_Type (Subtyp) then 1482 if Has_Static_Discriminant_Constraint (Subtyp) then 1483 1484 -- The component range for a constrained discriminant 1485 -- is a single value. 1486 declare 1487 Dc_Elmt : Elmt_Id := 1488 First_Elmt (Discriminant_Constraint (Subtyp)); 1489 Dc_Value : Uint; 1490 begin 1491 while Present (Dc_Elmt) loop 1492 Dc_Value := Expr_Value (Node (Dc_Elmt)); 1493 Update_Result ((Low => Dc_Value, 1494 High => Dc_Value)); 1495 1496 Next_Elmt (Dc_Elmt); 1497 end loop; 1498 end; 1499 1500 -- Generate ranges for nondiscriminant components. 1501 declare 1502 Comp : Entity_Id := First_Component 1503 (Base_Type (Subtyp)); 1504 begin 1505 while Present (Comp) loop 1506 Traverse_Discrete_Parts (Etype (Comp)); 1507 Next_Component (Comp); 1508 end loop; 1509 end; 1510 else 1511 -- Generate ranges for all components 1512 declare 1513 Comp : Entity_Id := 1514 First_Component_Or_Discriminant 1515 (Base_Type (Subtyp)); 1516 begin 1517 while Present (Comp) loop 1518 Traverse_Discrete_Parts (Etype (Comp)); 1519 Next_Component_Or_Discriminant (Comp); 1520 end loop; 1521 end; 1522 end if; 1523 else 1524 Error_Msg_N 1525 ("case selector type having a non-discrete non-record" 1526 & " non-array subcomponent type not implemented", 1527 Expression (Case_Statement)); 1528 end if; 1529 end Traverse_Discrete_Parts; 1530 1531 begin 1532 Traverse_Discrete_Parts (Case_Expr_Type); 1533 pragma Assert (Done or else Serious_Errors_Detected > 0); 1534 return Result; 1535 end Component_Bounds_Info; 1536 1537 Component_Bounds : constant Composite_Range_Info 1538 := Component_Bounds_Info; 1539 1540 package Case_Bindings is 1541 1542 procedure Note_Binding 1543 (Comp_Assoc : Node_Id; 1544 Choice : Node_Id; 1545 Alt : Node_Id); 1546 -- Note_Binding is called once for each component association 1547 -- that defines a binding (using either "A => B is X" or 1548 -- "A => <X>" syntax); 1549 1550 procedure Check_Bindings; 1551 -- After all calls to Note_Binding, check that bindings are 1552 -- ok (e.g., check consistency among different choices of 1553 -- one alternative). 1554 1555 end Case_Bindings; 1556 1557 procedure Refresh_Binding_Info (Aggr : Node_Id); 1558 -- The parser records binding-related info in the tree. 1559 -- The choice nodes that we see here might not be (will never be?) 1560 -- the original nodes that were produced by the parser. The info 1561 -- recorded by the parser is missing in that case, so this 1562 -- procedure recovers it. 1563 -- 1564 -- There are bugs here. In some cases involving nested aggregates, 1565 -- the path back to the parser-created nodes is lost. In particular, 1566 -- we may fail to detect an illegal case like 1567 -- when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) => 1568 -- This should be rejected because it is binding X to both the 1569 -- F1.Bb and to the F2.Bb subcomponents of the case selector. 1570 -- It would be nice if the not-specific-to-pattern-matching 1571 -- aggregate-processing code could remain unaware of the existence 1572 -- of this binding-related info but perhaps that isn't possible. 1573 1574 -------------------------- 1575 -- Refresh_Binding_Info -- 1576 -------------------------- 1577 1578 procedure Refresh_Binding_Info (Aggr : Node_Id) is 1579 Orig_Aggr : constant Node_Id := Original_Node (Aggr); 1580 Orig_Comp : Node_Id := First (Component_Associations (Orig_Aggr)); 1581 begin 1582 if Aggr = Orig_Aggr then 1583 return; 1584 end if; 1585 1586 while Present (Orig_Comp) loop 1587 if Nkind (Orig_Comp) = N_Component_Association 1588 and then Binding_Chars (Orig_Comp) /= No_Name 1589 then 1590 if List_Length (Choices (Orig_Comp)) /= 1 then 1591 -- Conceivably this could be checked during parsing, 1592 -- but checking is easier here. 1593 1594 Error_Msg_N 1595 ("binding shared by multiple components", Orig_Comp); 1596 return; 1597 end if; 1598 1599 declare 1600 Orig_Name : constant Name_Id := 1601 Chars (First (Choices (Orig_Comp))); 1602 Comp : Node_Id := First (Component_Associations (Aggr)); 1603 Matching_Comp : Node_Id := Empty; 1604 begin 1605 while Present (Comp) loop 1606 if Chars (First (Choices (Comp))) = Orig_Name then 1607 pragma Assert (not Present (Matching_Comp)); 1608 Matching_Comp := Comp; 1609 end if; 1610 1611 Next (Comp); 1612 end loop; 1613 1614 pragma Assert (Present (Matching_Comp)); 1615 1616 Set_Binding_Chars 1617 (Matching_Comp, 1618 Binding_Chars (Orig_Comp)); 1619 end; 1620 end if; 1621 1622 Next (Orig_Comp); 1623 end loop; 1624 end Refresh_Binding_Info; 1625 1626 ------------------ 1627 -- Parse_Choice -- 1628 ------------------ 1629 1630 function Parse_Choice (Choice : Node_Id; 1631 Alt : Node_Id) return Choice_Range_Info 1632 is 1633 Result : Choice_Range_Info (Is_Others => False); 1634 Ranges : Composite_Range_Info renames Result.Ranges; 1635 Next_Part : Part_Id'Base range 1 .. Part_Id'Last + 1 := 1; 1636 1637 procedure Traverse_Choice (Expr : Node_Id); 1638 -- Traverse a legal choice expression, looking for 1639 -- values/ranges of discrete parts. Call Update_Result 1640 -- for each. 1641 1642 procedure Update_Result (Discrete_Range : Discrete_Range_Info); 1643 -- Initialize first remaining uninitialized element of Ranges. 1644 -- Also set Next_Part. 1645 1646 procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id); 1647 -- For each scalar part of the given component type, call 1648 -- Update_Result with the full range for that scalar part. 1649 -- This is used for both box components in aggregates and 1650 -- for any inactive-variant components that do not appear in 1651 -- a given aggregate. 1652 1653 ------------------- 1654 -- Update_Result -- 1655 ------------------- 1656 1657 procedure Update_Result (Discrete_Range : Discrete_Range_Info) is 1658 begin 1659 Ranges (Next_Part) := Discrete_Range; 1660 Next_Part := Next_Part + 1; 1661 end Update_Result; 1662 1663 ------------------------------------- 1664 -- Update_Result_For_Full_Coverage -- 1665 ------------------------------------- 1666 1667 procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id) 1668 is 1669 begin 1670 for Counter in 1 .. Scalar_Part_Count (Comp_Type) loop 1671 Update_Result (Component_Bounds (Next_Part)); 1672 end loop; 1673 end Update_Result_For_Full_Coverage; 1674 1675 --------------------- 1676 -- Traverse_Choice -- 1677 --------------------- 1678 1679 procedure Traverse_Choice (Expr : Node_Id) is 1680 begin 1681 if Nkind (Expr) = N_Qualified_Expression then 1682 Traverse_Choice (Expression (Expr)); 1683 1684 elsif Nkind (Expr) = N_Type_Conversion 1685 and then not Comes_From_Source (Expr) 1686 then 1687 if Expr /= Original_Node (Expr) then 1688 Traverse_Choice (Original_Node (Expr)); 1689 else 1690 Traverse_Choice (Expression (Expr)); 1691 end if; 1692 1693 elsif Nkind (Expr) = N_Aggregate then 1694 if Is_Record_Type (Etype (Expr)) then 1695 Refresh_Binding_Info (Aggr => Expr); 1696 1697 declare 1698 Comp_Assoc : Node_Id := 1699 First (Component_Associations (Expr)); 1700 -- Aggregate has been normalized (components in 1701 -- order, only one component per choice, etc.). 1702 1703 Comp_From_Type : Node_Id := 1704 First_Component_Or_Discriminant 1705 (Base_Type (Etype (Expr))); 1706 1707 Saved_Next_Part : constant Part_Id := Next_Part; 1708 begin 1709 while Present (Comp_Assoc) loop 1710 pragma Assert 1711 (List_Length (Choices (Comp_Assoc)) = 1); 1712 1713 declare 1714 Comp : constant Node_Id := 1715 Entity (First (Choices (Comp_Assoc))); 1716 Comp_Seen : Boolean := False; 1717 begin 1718 loop 1719 if Original_Record_Component (Comp) = 1720 Original_Record_Component (Comp_From_Type) 1721 then 1722 Comp_Seen := True; 1723 else 1724 -- We have an aggregate of a type that 1725 -- has a variant part (or has a 1726 -- subcomponent type that has a variant 1727 -- part) and we have to deal with a 1728 -- component that is present in the type 1729 -- but not in the aggregate (because the 1730 -- component is in an inactive variant). 1731 -- 1732 Update_Result_For_Full_Coverage 1733 (Comp_Type => Etype (Comp_From_Type)); 1734 end if; 1735 1736 Comp_From_Type := 1737 Next_Component_Or_Discriminant 1738 (Comp_From_Type); 1739 1740 exit when Comp_Seen; 1741 end loop; 1742 end; 1743 1744 declare 1745 Comp_Type : constant Entity_Id := 1746 Etype (First (Choices (Comp_Assoc))); 1747 begin 1748 if Box_Value_Required (Comp_Type) then 1749 -- This component is not allowed to 1750 -- influence which alternative is 1751 -- chosen; case choice must be box. 1752 -- 1753 -- For example, component might be 1754 -- of a real type or of an access type 1755 -- or of a non-static discrete subtype. 1756 if not Box_Present (Comp_Assoc) then 1757 Error_Msg_N 1758 ("Non-box case choice component value" & 1759 " of unsupported type/subtype", 1760 Expression (Comp_Assoc)); 1761 end if; 1762 elsif Box_Present (Comp_Assoc) then 1763 -- Box matches all values 1764 Update_Result_For_Full_Coverage 1765 (Etype (First (Choices (Comp_Assoc)))); 1766 else 1767 Traverse_Choice (Expression (Comp_Assoc)); 1768 end if; 1769 end; 1770 1771 if Binding_Chars (Comp_Assoc) /= No_Name 1772 then 1773 Case_Bindings.Note_Binding 1774 (Comp_Assoc => Comp_Assoc, 1775 Choice => Choice, 1776 Alt => Alt); 1777 end if; 1778 1779 Next (Comp_Assoc); 1780 end loop; 1781 1782 while Present (Comp_From_Type) loop 1783 -- Deal with any trailing inactive-variant 1784 -- components. 1785 -- 1786 -- See earlier commment about calling 1787 -- Update_Result_For_Full_Coverage for such 1788 -- components. 1789 1790 Update_Result_For_Full_Coverage 1791 (Comp_Type => Etype (Comp_From_Type)); 1792 1793 Comp_From_Type := 1794 Next_Component_Or_Discriminant (Comp_From_Type); 1795 end loop; 1796 1797 declare 1798 Expr_Type : Entity_Id := Etype (Expr); 1799 begin 1800 if Has_Discriminants (Expr_Type) then 1801 -- Avoid nonstatic choice expr types, 1802 -- for which Scalar_Part_Count returns 0. 1803 Expr_Type := Base_Type (Expr_Type); 1804 end if; 1805 1806 pragma Assert 1807 (Nat (Next_Part - Saved_Next_Part) 1808 = Scalar_Part_Count (Expr_Type)); 1809 end; 1810 end; 1811 elsif Is_Array_Type (Etype (Expr)) then 1812 if Is_Non_Empty_List (Component_Associations (Expr)) then 1813 Error_Msg_N 1814 ("non-positional array aggregate as/within case " 1815 & "choice not implemented", Expr); 1816 end if; 1817 1818 if not Unconstrained_Array_Case 1819 and then List_Length (Expressions (Expr)) 1820 /= Nat (Part_Id'Last) 1821 then 1822 Error_Msg_Uint_1 := UI_From_Int 1823 (List_Length (Expressions (Expr))); 1824 Error_Msg_Uint_2 := UI_From_Int (Int (Part_Id'Last)); 1825 Error_Msg_N 1826 ("array aggregate length ^ does not match length " & 1827 "of statically constrained case selector ^", Expr); 1828 return; 1829 end if; 1830 1831 declare 1832 Subexpr : Node_Id := First (Expressions (Expr)); 1833 begin 1834 while Present (Subexpr) loop 1835 Traverse_Choice (Subexpr); 1836 Next (Subexpr); 1837 end loop; 1838 end; 1839 else 1840 raise Program_Error; 1841 end if; 1842 elsif Nkind (Expr) = N_String_Literal then 1843 if not Is_Array_Type (Etype (Expr)) then 1844 Error_Msg_N 1845 ("User-defined string literal not allowed as/within" 1846 & "case choice", Expr); 1847 else 1848 declare 1849 Char_Type : constant Entity_Id := 1850 Root_Type (Component_Type (Etype (Expr))); 1851 1852 -- If the component type is not a standard character 1853 -- type then this string lit should have already been 1854 -- transformed into an aggregate in 1855 -- Resolve_String_Literal. 1856 -- 1857 pragma Assert (Is_Standard_Character_Type (Char_Type)); 1858 1859 Str : constant String_Id := Strval (Expr); 1860 Strlen : constant Nat := String_Length (Str); 1861 Char_Val : Uint; 1862 begin 1863 if not Unconstrained_Array_Case 1864 and then Strlen /= Nat (Part_Id'Last) 1865 then 1866 Error_Msg_Uint_1 := UI_From_Int (Strlen); 1867 Error_Msg_Uint_2 := UI_From_Int 1868 (Int (Part_Id'Last)); 1869 Error_Msg_N 1870 ("String literal length ^ does not match length" & 1871 " of statically constrained case selector ^", 1872 Expr); 1873 return; 1874 end if; 1875 1876 for Idx in 1 .. Strlen loop 1877 Char_Val := 1878 UI_From_CC (Get_String_Char (Str, Idx)); 1879 Update_Result ((Low | High => Char_Val)); 1880 end loop; 1881 end; 1882 end if; 1883 elsif Is_Discrete_Type (Etype (Expr)) then 1884 if Nkind (Expr) in N_Has_Entity 1885 and then Present (Entity (Expr)) 1886 and then Is_Type (Entity (Expr)) 1887 then 1888 declare 1889 Low : constant Node_Id := 1890 Type_Low_Bound (Entity (Expr)); 1891 High : constant Node_Id := 1892 Type_High_Bound (Entity (Expr)); 1893 begin 1894 Update_Result ((Low => Expr_Value (Low), 1895 High => Expr_Value (High))); 1896 end; 1897 else 1898 pragma Assert (Compile_Time_Known_Value (Expr)); 1899 Update_Result ((Low | High => Expr_Value (Expr))); 1900 end if; 1901 elsif Nkind (Expr) in N_Has_Entity 1902 and then Present (Entity (Expr)) 1903 and then Ekind (Entity (Expr)) = E_Constant 1904 then 1905 Traverse_Choice (Expression (Parent (Entity (Expr)))); 1906 elsif Nkind (Original_Node (Expr)) 1907 in N_Aggregate | N_String_Literal 1908 then 1909 Traverse_Choice (Original_Node (Expr)); 1910 else 1911 Error_Msg_N 1912 ("non-aggregate case choice (or subexpression thereof)" 1913 & " that is not of a discrete type not implemented", 1914 Expr); 1915 end if; 1916 end Traverse_Choice; 1917 1918 -- Start of processing for Parse_Choice 1919 1920 begin 1921 if Nkind (Choice) = N_Others_Choice then 1922 return (Is_Others => True); 1923 end if; 1924 1925 if Unconstrained_Array_Case then 1926 -- Treat length like a discriminant 1927 Update_Result ((Low | High => 1928 UI_From_Int (Array_Choice_Length (Choice)))); 1929 end if; 1930 1931 Traverse_Choice (Choice); 1932 1933 if Unconstrained_Array_Case then 1934 -- This is somewhat tricky. Suppose we are casing on String, 1935 -- the longest choice in the case statement is length 10, and 1936 -- the choice we are looking at now is of length 6. We fill 1937 -- in the trailing 4 slots here. 1938 while Next_Part <= Part_Id'Last loop 1939 Update_Result_For_Full_Coverage 1940 (Comp_Type => Component_Type (Case_Expr_Type)); 1941 end loop; 1942 end if; 1943 1944 -- Avoid returning uninitialized garbage in error case 1945 if Next_Part /= Part_Id'Last + 1 then 1946 pragma Assert (Serious_Errors_Detected > 0); 1947 Result.Ranges := (others => (Low => Uint_1, High => Uint_0)); 1948 end if; 1949 1950 return Result; 1951 end Parse_Choice; 1952 1953 package body Case_Bindings is 1954 1955 type Binding is record 1956 Comp_Assoc : Node_Id; 1957 Choice : Node_Id; 1958 Alt : Node_Id; 1959 end record; 1960 1961 type Binding_Index is new Natural; 1962 1963 package Case_Bindings_Table is new Table.Table 1964 (Table_Component_Type => Binding, 1965 Table_Index_Type => Binding_Index, 1966 Table_Low_Bound => 1, 1967 Table_Initial => 16, 1968 Table_Increment => 64, 1969 Table_Name => "Composite_Case_Ops.Case_Bindings"); 1970 1971 ------------------ 1972 -- Note_Binding -- 1973 ------------------ 1974 1975 procedure Note_Binding 1976 (Comp_Assoc : Node_Id; 1977 Choice : Node_Id; 1978 Alt : Node_Id) 1979 is 1980 begin 1981 Case_Bindings_Table.Append 1982 ((Comp_Assoc => Comp_Assoc, 1983 Choice => Choice, 1984 Alt => Alt)); 1985 end Note_Binding; 1986 1987 -------------------- 1988 -- Check_Bindings -- 1989 -------------------- 1990 1991 procedure Check_Bindings 1992 is 1993 use Case_Bindings_Table; 1994 1995 function Binding_Subtype (Idx : Binding_Index; 1996 Tab : Table_Type) 1997 return Entity_Id is 1998 (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc)))); 1999 2000 procedure Declare_Binding_Objects 2001 (Alt_Start : Binding_Index; 2002 Alt : Node_Id; 2003 First_Choice_Bindings : Natural; 2004 Tab : Table_Type); 2005 -- Declare the binding objects for a given alternative 2006 2007 ------------------------------ 2008 -- Declare_Binding_Objects -- 2009 ------------------------------ 2010 2011 procedure Declare_Binding_Objects 2012 (Alt_Start : Binding_Index; 2013 Alt : Node_Id; 2014 First_Choice_Bindings : Natural; 2015 Tab : Table_Type) 2016 is 2017 Loc : constant Source_Ptr := Sloc (Alt); 2018 Declarations : constant List_Id := New_List; 2019 Decl : Node_Id; 2020 Obj_Type : Entity_Id; 2021 Def_Id : Entity_Id; 2022 begin 2023 for FC_Idx in Alt_Start .. 2024 Alt_Start + Binding_Index (First_Choice_Bindings - 1) 2025 loop 2026 Obj_Type := Binding_Subtype (FC_Idx, Tab); 2027 Def_Id := Make_Defining_Identifier 2028 (Loc, 2029 Binding_Chars (Tab (FC_Idx).Comp_Assoc)); 2030 2031 -- Either make a copy or rename the original. At a 2032 -- minimum, we do not want a copy if it would need 2033 -- finalization. Copies may also introduce problems 2034 -- if default init can have side effects (although we 2035 -- could suppress such default initialization). 2036 -- We have to make a copy in any cases where 2037 -- Unrestricted_Access doesn't work. 2038 -- 2039 -- This is where the copy-or-rename decision is made. 2040 -- In many cases either way would work and so we have 2041 -- some flexibility here. 2042 2043 if not Is_By_Copy_Type (Obj_Type) then 2044 -- Generate 2045 -- type Ref 2046 -- is access constant Obj_Type; 2047 -- Ptr : Ref := <some bogus value>; 2048 -- Obj : Obj_Type renames Ptr.all; 2049 -- 2050 -- Initialization of Ptr will be generated later 2051 -- during expansion. 2052 2053 declare 2054 Ptr_Type : constant Entity_Id := 2055 Make_Temporary (Loc, 'P'); 2056 2057 Ptr_Type_Def : constant Node_Id := 2058 Make_Access_To_Object_Definition (Loc, 2059 All_Present => True, 2060 Subtype_Indication => 2061 New_Occurrence_Of (Obj_Type, Loc)); 2062 2063 Ptr_Type_Decl : constant Node_Id := 2064 Make_Full_Type_Declaration (Loc, 2065 Ptr_Type, 2066 Type_Definition => Ptr_Type_Def); 2067 2068 Ptr_Obj : constant Entity_Id := 2069 Make_Temporary (Loc, 'T'); 2070 2071 -- We will generate initialization code for this 2072 -- object later (during expansion) but in the 2073 -- meantime we don't want the dereference that 2074 -- is generated a few lines below here to be 2075 -- transformed into a Raise_C_E. To prevent this, 2076 -- we provide a bogus initial value here; this 2077 -- initial value will be removed later during 2078 -- expansion. 2079 2080 Ptr_Obj_Decl : constant Node_Id := 2081 Make_Object_Declaration 2082 (Loc, Ptr_Obj, 2083 Object_Definition => 2084 New_Occurrence_Of (Ptr_Type, Loc), 2085 Expression => 2086 Unchecked_Convert_To 2087 (Ptr_Type, 2088 Make_Integer_Literal (Loc, 5432))); 2089 begin 2090 Mutate_Ekind (Ptr_Type, E_Access_Type); 2091 2092 -- in effect, Storage_Size => 0 2093 Set_No_Pool_Assigned (Ptr_Type); 2094 2095 Set_Is_Access_Constant (Ptr_Type); 2096 2097 -- We could set Ptr_Type'Alignment here if that 2098 -- ever turns out to be needed for renaming a 2099 -- misaligned subcomponent. 2100 2101 Mutate_Ekind (Ptr_Obj, E_Variable); 2102 Set_Etype (Ptr_Obj, Ptr_Type); 2103 2104 Decl := 2105 Make_Object_Renaming_Declaration 2106 (Loc, Def_Id, 2107 Subtype_Mark => 2108 New_Occurrence_Of (Obj_Type, Loc), 2109 Name => 2110 Make_Explicit_Dereference 2111 (Loc, New_Occurrence_Of (Ptr_Obj, Loc))); 2112 2113 Append_To (Declarations, Ptr_Type_Decl); 2114 Append_To (Declarations, Ptr_Obj_Decl); 2115 end; 2116 else 2117 Decl := Make_Object_Declaration 2118 (Sloc => Loc, 2119 Defining_Identifier => Def_Id, 2120 Object_Definition => 2121 New_Occurrence_Of (Obj_Type, Loc)); 2122 end if; 2123 Append_To (Declarations, Decl); 2124 end loop; 2125 2126 declare 2127 Old_Statements : constant List_Id := Statements (Alt); 2128 New_Statements : constant List_Id := New_List; 2129 2130 Block_Statement : constant Node_Id := 2131 Make_Block_Statement (Sloc => Loc, 2132 Declarations => Declarations, 2133 Handled_Statement_Sequence => 2134 Make_Handled_Sequence_Of_Statements 2135 (Loc, Old_Statements), 2136 Has_Created_Identifier => True); 2137 begin 2138 Append_To (New_Statements, Block_Statement); 2139 Set_Statements (Alt, New_Statements); 2140 end; 2141 end Declare_Binding_Objects; 2142 begin 2143 if Last = 0 then 2144 -- no bindings to check 2145 return; 2146 end if; 2147 2148 declare 2149 Tab : Table_Type 2150 renames Case_Bindings_Table.Table (1 .. Last); 2151 2152 function Same_Id (Idx1, Idx2 : Binding_Index) 2153 return Boolean is ( 2154 Binding_Chars (Tab (Idx1).Comp_Assoc) = 2155 Binding_Chars (Tab (Idx2).Comp_Assoc)); 2156 begin 2157 -- Verify that elements with given choice or alt value 2158 -- are contiguous, and that elements with equal 2159 -- choice values have same alt value. 2160 2161 for Idx1 in 2 .. Tab'Last loop 2162 if Tab (Idx1 - 1).Choice /= Tab (Idx1).Choice then 2163 pragma Assert 2164 (for all Idx2 in Idx1 + 1 .. Tab'Last => 2165 Tab (Idx2).Choice /= Tab (Idx1 - 1).Choice); 2166 else 2167 pragma Assert (Tab (Idx1 - 1).Alt = Tab (Idx1).Alt); 2168 end if; 2169 if Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt then 2170 pragma Assert 2171 (for all Idx2 in Idx1 + 1 .. Tab'Last => 2172 Tab (Idx2).Alt /= Tab (Idx1 - 1).Alt); 2173 end if; 2174 end loop; 2175 2176 -- Check for user errors: 2177 -- 1) Two choices for a given alternative shall define the 2178 -- same set of names. Can't have 2179 -- when (<X>, 0) | (0, <Y>) => 2180 -- 2) A choice shall not define a name twice. Can't have 2181 -- when (A => <X>, B => <X>, C => 0) => 2182 -- 3) Two definitions of a name within one alternative 2183 -- shall have statically matching component subtypes. 2184 -- Can't have 2185 -- type R is record Int : Integer; 2186 -- Nat : Natural; end record; 2187 -- case R'(...) is 2188 -- when (<X>, 1) | (1, <X>) => 2189 -- 4) A given binding shall match only one value. 2190 -- Can't have 2191 -- (Fld1 | Fld2 => (Fld => <X>)) 2192 -- For now, this is enforced *very* conservatively 2193 -- with respect to arrays - a binding cannot match 2194 -- any part of an array. This is temporary. 2195 2196 for Idx1 in Tab'Range loop 2197 if Idx1 = 1 2198 or else Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt 2199 then 2200 -- Process one alternative 2201 declare 2202 Alt_Start : constant Binding_Index := Idx1; 2203 Alt : constant Node_Id := Tab (Alt_Start).Alt; 2204 2205 First_Choice : constant Node_Id := 2206 Nlists.First (Discrete_Choices (Alt)); 2207 First_Choice_Bindings : Natural := 0; 2208 begin 2209 -- Check for duplicates within one choice, 2210 -- and for choices with no bindings. 2211 2212 if First_Choice /= Tab (Alt_Start).Choice then 2213 Error_Msg_N ("binding(s) missing for choice", 2214 First_Choice); 2215 return; 2216 end if; 2217 2218 declare 2219 Current_Choice : Node_Id := First_Choice; 2220 Choice_Start : Binding_Index := Alt_Start; 2221 begin 2222 for Idx2 in Alt_Start .. Tab'Last loop 2223 exit when Tab (Idx2).Alt /= Alt; 2224 if Tab (Idx2).Choice = Current_Choice then 2225 for Idx3 in Choice_Start .. Idx2 - 1 loop 2226 if Same_Id (Idx2, Idx3) 2227 then 2228 Error_Msg_N 2229 ("duplicate binding in choice", 2230 Current_Choice); 2231 return; 2232 end if; 2233 end loop; 2234 else 2235 Next (Current_Choice); 2236 pragma Assert (Present (Current_Choice)); 2237 Choice_Start := Idx2; 2238 2239 if Tab (Idx2).Choice /= Current_Choice 2240 then 2241 Error_Msg_N 2242 ("binding(s) missing for choice", 2243 Current_Choice); 2244 return; 2245 end if; 2246 end if; 2247 end loop; 2248 2249 -- If we made it through all the bindings 2250 -- for this alternative but didn't make it 2251 -- to the last choice, then bindings are 2252 -- missing for all remaining choices. 2253 -- We only complain about the first one. 2254 2255 if Present (Next (Current_Choice)) then 2256 Error_Msg_N 2257 ("binding(s) missing for choice", 2258 Next (Current_Choice)); 2259 return; 2260 end if; 2261 end; 2262 2263 -- Count bindings for first choice of alternative 2264 2265 for FC_Idx in Alt_Start .. Tab'Last loop 2266 exit when Tab (FC_Idx).Choice /= First_Choice; 2267 First_Choice_Bindings := 2268 First_Choice_Bindings + 1; 2269 end loop; 2270 2271 declare 2272 Current_Choice : Node_Id := First_Choice; 2273 Current_Choice_Bindings : Natural := 0; 2274 begin 2275 for Idx2 in Alt_Start .. Tab'Last loop 2276 exit when Tab (Idx2).Alt /= Alt; 2277 2278 -- If starting a new choice 2279 2280 if Tab (Idx2).Choice /= Current_Choice then 2281 2282 -- Check count for choice just finished 2283 2284 if Current_Choice_Bindings 2285 /= First_Choice_Bindings 2286 then 2287 Error_Msg_N 2288 ("subsequent choice has different" 2289 & " number of bindings than first" 2290 & " choice", Current_Choice); 2291 end if; 2292 2293 Current_Choice := Tab (Idx2).Choice; 2294 Current_Choice_Bindings := 1; 2295 2296 -- Remember that Alt has both one or more 2297 -- bindings and two or more choices; we'll 2298 -- need to know this during expansion. 2299 2300 Set_Multidefined_Bindings (Alt, True); 2301 else 2302 Current_Choice_Bindings := 2303 Current_Choice_Bindings + 1; 2304 end if; 2305 2306 -- Check that first choice has binding with 2307 -- matching name; check subtype consistency. 2308 2309 declare 2310 Found : Boolean := False; 2311 begin 2312 for FC_Idx in 2313 Alt_Start .. 2314 Alt_Start + Binding_Index 2315 (First_Choice_Bindings - 1) 2316 loop 2317 if Same_Id (Idx2, FC_Idx) then 2318 if not Subtypes_Statically_Match 2319 (Binding_Subtype (Idx2, Tab), 2320 Binding_Subtype (FC_Idx, Tab)) 2321 then 2322 Error_Msg_N 2323 ("subtype of binding in " 2324 & "subsequent choice does not " 2325 & "match that in first choice", 2326 Tab (Idx2).Comp_Assoc); 2327 end if; 2328 Found := True; 2329 exit; 2330 end if; 2331 end loop; 2332 2333 if not Found then 2334 Error_Msg_N 2335 ("binding defined in subsequent " 2336 & "choice not defined in first " 2337 & "choice", Current_Choice); 2338 end if; 2339 end; 2340 2341 -- Check for illegal repeated binding 2342 -- via an enclosing aggregate, as in 2343 -- (F1 | F2 => (F3 => Natural is X, 2344 -- F4 => Natural)) 2345 -- where the inner aggregate would be ok. 2346 2347 declare 2348 Rover : Node_Id := Tab (Idx2).Comp_Assoc; 2349 begin 2350 while Rover /= Tab (Idx2).Choice loop 2351 Rover := 2352 (if Is_List_Member (Rover) then 2353 Parent (List_Containing (Rover)) 2354 else Parent (Rover)); 2355 pragma Assert (Present (Rover)); 2356 if Nkind (Rover) 2357 = N_Component_Association 2358 and then List_Length (Choices (Rover)) 2359 > 1 2360 then 2361 Error_Msg_N 2362 ("binding shared by multiple " 2363 & "enclosing components", 2364 Tab (Idx2).Comp_Assoc); 2365 end if; 2366 end loop; 2367 end; 2368 end loop; 2369 end; 2370 2371 -- Construct the (unanalyzed) declarations for 2372 -- the current alternative. Then analyze them. 2373 2374 if First_Choice_Bindings > 0 then 2375 Declare_Binding_Objects 2376 (Alt_Start => Alt_Start, 2377 Alt => Alt, 2378 First_Choice_Bindings => 2379 First_Choice_Bindings, 2380 Tab => Tab); 2381 end if; 2382 end; 2383 end if; 2384 end loop; 2385 end; 2386 end Check_Bindings; 2387 end Case_Bindings; 2388 2389 function Choice_Bounds_Info return Choices_Range_Info; 2390 -- Returns mapping from any given Choice_Id value to that choice's 2391 -- component-to-range map. 2392 2393 ------------------------ 2394 -- Choice_Bounds_Info -- 2395 ------------------------ 2396 2397 function Choice_Bounds_Info return Choices_Range_Info is 2398 Result : Choices_Range_Info; 2399 Alt : Node_Id := First (Alternatives (Case_Statement)); 2400 C_Id : Choice_Id := 1; 2401 begin 2402 while Present (Alt) loop 2403 declare 2404 Choice : Node_Id := First (Discrete_Choices (Alt)); 2405 begin 2406 while Present (Choice) loop 2407 Result (C_Id) := Parse_Choice (Choice, Alt => Alt); 2408 2409 Next (Choice); 2410 if C_Id /= Choice_Id'Last then 2411 C_Id := C_Id + 1; 2412 end if; 2413 end loop; 2414 end; 2415 Next (Alt); 2416 end loop; 2417 2418 pragma Assert (C_Id = Choice_Id'Last); 2419 2420 -- No more calls to Note_Binding, so time for checks. 2421 Case_Bindings.Check_Bindings; 2422 2423 return Result; 2424 end Choice_Bounds_Info; 2425 2426 Choices_Bounds : constant Choices_Range_Info := Choice_Bounds_Info; 2427 2428 package body Value_Sets is 2429 use GNAT; 2430 2431 function Hash (Key : Uint) return Bucket_Range_Type is 2432 (Bucket_Range_Type 2433 (UI_To_Int (Key mod (Uint_2 ** Uint_31)))); 2434 2435 package Uint_Sets is new GNAT.Sets.Membership_Sets 2436 (Uint, "=", Hash); 2437 2438 type Representative_Values_Array is 2439 array (Part_Id) of Uint_Sets.Membership_Set; 2440 2441 function Representative_Values_Init 2442 return Representative_Values_Array; 2443 -- Select the representative values for each Part_Id value. 2444 -- This function is called exactly once, immediately after it 2445 -- is declared. 2446 2447 -------------------------------- 2448 -- Representative_Values_Init -- 2449 -------------------------------- 2450 2451 function Representative_Values_Init 2452 return Representative_Values_Array 2453 is 2454 -- For each range of each choice (as well as the range for the 2455 -- component subtype, which is handled in the first loop), 2456 -- insert the low bound of the range and the successor of 2457 -- the high bound into the corresponding R_V element. 2458 -- 2459 -- The idea we are trying to capture here is somewhat tricky. 2460 -- Given an arbitrary point P1 in the Cartesian product 2461 -- of the Component_Bounds sets, we want to be able 2462 -- to map that to a point P2 in the (smaller) Cartesian product 2463 -- of the Representative_Values sets that has the property 2464 -- that for every choice of the case statement, P1 matches 2465 -- the choice if and only if P2 also matches. Given that, 2466 -- we can implement the overlapping/containment/etc. rules 2467 -- safely by just looking at (using brute force enumeration) 2468 -- the (smaller) Cartesian product of the R_V sets. 2469 -- We are never going to actually perform this point-to-point 2470 -- mapping - just the fact that it exists is enough to ensure 2471 -- we can safely look at just the R_V sets. 2472 -- 2473 -- The desired mapping can be implemented by mapping a point 2474 -- P1 to a point P2 by reducing each of P1's coordinates down 2475 -- to the largest element of the corresponding R_V set that is 2476 -- less than or equal to the original coordinate value (such 2477 -- an element Y will always exist because the R_V set for a 2478 -- given component always includes the low bound of the 2479 -- component subtype). It then suffices to show that every 2480 -- choice in the case statement yields the same Boolean result 2481 -- for P1 as for P2. 2482 -- 2483 -- Suppose the contrary. Then there is some particular 2484 -- coordinate position X (i.e., a Part_Id value) and some 2485 -- choice C where exactly one of P1(X) and P2(X) belongs to 2486 -- the (contiguous) range associated with C(X); call that 2487 -- range L .. H. We know that P2(X) <= P1(X) because the 2488 -- mapping never increases coordinate values. Consider three 2489 -- cases: P1(X) lies within the L .. H range, or it is greater 2490 -- than H, or it is lower than L. 2491 -- The third case is impossible because reducing a value that 2492 -- is less than L can only produce another such value, 2493 -- violating the "exactly one" assumption. The second 2494 -- case is impossible because L belongs to the corresponding 2495 -- R_V set, so P2(X) >= L and both values belong to the 2496 -- range, again violating the "exactly one" assumption. 2497 -- Finally, the third case is impossible because H+1 belongs 2498 -- to the corresponding R_V set, so P2(X) > H, so neither 2499 -- value belongs to the range, again violating the "exactly 2500 -- one" assumption. So our initial supposition was wrong. QED. 2501 2502 use Uint_Sets; 2503 2504 Result : constant Representative_Values_Array 2505 := (others => Uint_Sets.Create (Initial_Size => 32)); 2506 2507 procedure Insert_Representative (Value : Uint; P : Part_Id); 2508 -- Insert the given Value into the representative values set 2509 -- for the given component if it belongs to the component's 2510 -- subtype. Otherwise, do nothing. 2511 2512 --------------------------- 2513 -- Insert_Representative -- 2514 --------------------------- 2515 2516 procedure Insert_Representative (Value : Uint; P : Part_Id) is 2517 begin 2518 if Value >= Component_Bounds (P).Low and 2519 Value <= Component_Bounds (P).High 2520 then 2521 Insert (Result (P), Value); 2522 end if; 2523 end Insert_Representative; 2524 2525 begin 2526 for P in Part_Id loop 2527 Insert_Representative (Component_Bounds (P).Low, P); 2528 end loop; 2529 for C of Choices_Bounds loop 2530 if not C.Is_Others then 2531 for P in Part_Id loop 2532 if C.Ranges (P).Low <= C.Ranges (P).High then 2533 Insert_Representative (C.Ranges (P).Low, P); 2534 Insert_Representative (C.Ranges (P).High + 1, P); 2535 end if; 2536 end loop; 2537 end if; 2538 end loop; 2539 return Result; 2540 end Representative_Values_Init; 2541 2542 Representative_Values : constant Representative_Values_Array 2543 := Representative_Values_Init; 2544 -- We want to avoid looking at every point in the Cartesian 2545 -- product of all component values. Instead we select, for each 2546 -- component, a set of representative values and then look only 2547 -- at the Cartesian product of those sets. A single value can 2548 -- safely represent a larger enclosing interval if every choice 2549 -- for that component either completely includes or completely 2550 -- excludes the interval. The elements of this array will be 2551 -- populated by a call to Initialize_Representative_Values and 2552 -- will remain constant after that. 2553 2554 type Value_Index_Base is new Natural; 2555 2556 function Value_Index_Count return Value_Index_Base; 2557 -- Returns the product of the sizes of the Representative_Values 2558 -- sets (i.e., the size of the Cartesian product of the sets). 2559 -- May return zero if one of the sets is empty. 2560 -- This function is called exactly once, immediately after it 2561 -- is declared. 2562 2563 ----------------------- 2564 -- Value_Index_Count -- 2565 ----------------------- 2566 2567 function Value_Index_Count return Value_Index_Base is 2568 Result : Value_Index_Base := 1; 2569 begin 2570 for Set of Representative_Values loop 2571 Result := Result * Value_Index_Base (Uint_Sets.Size (Set)); 2572 end loop; 2573 return Result; 2574 exception 2575 when Constraint_Error => 2576 Error_Msg_N 2577 ("Capacity exceeded in compiling case statement with" 2578 & " composite selector type", Case_Statement); 2579 raise; 2580 end Value_Index_Count; 2581 2582 Max_Value_Index : constant Value_Index_Base := Value_Index_Count; 2583 2584 subtype Value_Index is Value_Index_Base range 1 .. Max_Value_Index; 2585 type Value_Index_Set is array (Value_Index) of Boolean; 2586 2587 package Value_Index_Set_Table is new Table.Table 2588 (Table_Component_Type => Value_Index_Set, 2589 Table_Index_Type => Value_Set, 2590 Table_Low_Bound => 1, 2591 Table_Initial => 16, 2592 Table_Increment => 100, 2593 Table_Name => "Composite_Case_Ops.Value_Sets"); 2594 -- A nonzero Value_Set value is an index into this table. 2595 2596 function Indexed (Index : Value_Set) return Value_Index_Set 2597 is (Value_Index_Set_Table.Table.all (Index)); 2598 2599 function Allocate_Table_Element (Initial_Value : Value_Index_Set) 2600 return Value_Set; 2601 -- Allocate and initialize a new table element; return its index. 2602 2603 ---------------------------- 2604 -- Allocate_Table_Element -- 2605 ---------------------------- 2606 2607 function Allocate_Table_Element (Initial_Value : Value_Index_Set) 2608 return Value_Set 2609 is 2610 use Value_Index_Set_Table; 2611 begin 2612 Append (Initial_Value); 2613 return Last; 2614 end Allocate_Table_Element; 2615 2616 procedure Assign_Table_Element (Index : Value_Set; 2617 Value : Value_Index_Set); 2618 -- Assign specified value to specified table element. 2619 2620 -------------------------- 2621 -- Assign_Table_Element -- 2622 -------------------------- 2623 2624 procedure Assign_Table_Element (Index : Value_Set; 2625 Value : Value_Index_Set) 2626 is 2627 begin 2628 Value_Index_Set_Table.Table.all (Index) := Value; 2629 end Assign_Table_Element; 2630 2631 ------------- 2632 -- Compare -- 2633 ------------- 2634 2635 function Compare (S1, S2 : Value_Set) return Set_Comparison is 2636 begin 2637 if S1 = Empty or S2 = Empty then 2638 return Disjoint; 2639 elsif Indexed (S1) = Indexed (S2) then 2640 return Equal; 2641 else 2642 declare 2643 Intersection : constant Value_Index_Set 2644 := Indexed (S1) and Indexed (S2); 2645 begin 2646 if (for all Flag of Intersection => not Flag) then 2647 return Disjoint; 2648 elsif Intersection = Indexed (S1) then 2649 return Contained_By; 2650 elsif Intersection = Indexed (S2) then 2651 return Contains; 2652 else 2653 return Overlaps; 2654 end if; 2655 end; 2656 end if; 2657 end Compare; 2658 2659 ------------------------- 2660 -- Complement_Is_Empty -- 2661 ------------------------- 2662 2663 function Complement_Is_Empty (Set : Value_Set) return Boolean 2664 is (Set /= Empty 2665 and then (for all Flag of Indexed (Set) => Flag)); 2666 2667 --------------------- 2668 -- Free_Value_Sets -- 2669 --------------------- 2670 procedure Free_Value_Sets is 2671 begin 2672 Value_Index_Set_Table.Free; 2673 end Free_Value_Sets; 2674 2675 ----------- 2676 -- Union -- 2677 ----------- 2678 2679 procedure Union (Target : in out Value_Set; Source : Value_Set) is 2680 begin 2681 if Source /= Empty then 2682 if Target = Empty then 2683 Target := Allocate_Table_Element (Indexed (Source)); 2684 else 2685 Assign_Table_Element 2686 (Target, Indexed (Target) or Indexed (Source)); 2687 end if; 2688 end if; 2689 end Union; 2690 2691 ------------ 2692 -- Remove -- 2693 ------------ 2694 2695 procedure Remove (Target : in out Value_Set; Source : Value_Set) is 2696 begin 2697 if Source /= Empty and Target /= Empty then 2698 Assign_Table_Element 2699 (Target, Indexed (Target) and not Indexed (Source)); 2700 if (for all V of Indexed (Target) => not V) then 2701 Target := Empty; 2702 end if; 2703 end if; 2704 end Remove; 2705 2706 --------------------- 2707 -- Matching_Values -- 2708 --------------------- 2709 2710 function Matching_Values 2711 (Info : Composite_Range_Info) return Value_Set 2712 is 2713 Matches : Value_Index_Set; 2714 Next_Index : Value_Index := 1; 2715 Done : Boolean := False; 2716 Point : array (Part_Id) of Uint; 2717 2718 procedure Test_Point_For_Match; 2719 -- Point identifies a point in the Cartesian product of the 2720 -- representative value sets. Record whether that Point 2721 -- belongs to the product-of-ranges specified by Info. 2722 2723 -------------------------- 2724 -- Test_Point_For_Match -- 2725 -------------------------- 2726 2727 procedure Test_Point_For_Match is 2728 function In_Range (Val : Uint; Rang : Discrete_Range_Info) 2729 return Boolean is 2730 ((Rang.Low <= Val) and then (Val <= Rang.High)); 2731 begin 2732 pragma Assert (not Done); 2733 Matches (Next_Index) := 2734 (for all P in Part_Id => In_Range (Point (P), Info (P))); 2735 if Next_Index = Matches'Last then 2736 Done := True; 2737 else 2738 Next_Index := Next_Index + 1; 2739 end if; 2740 end Test_Point_For_Match; 2741 2742 procedure Test_Points (P : Part_Id); 2743 -- Iterate over the Cartesian product of the representative 2744 -- value sets, calling Test_Point_For_Match for each point. 2745 2746 ----------------- 2747 -- Test_Points -- 2748 ----------------- 2749 2750 procedure Test_Points (P : Part_Id) is 2751 use Uint_Sets; 2752 Iter : Iterator := Iterate (Representative_Values (P)); 2753 begin 2754 -- We could traverse here in sorted order, as opposed to 2755 -- whatever order the set iterator gives us. 2756 -- No need for that as long as every iteration over 2757 -- a given representative values set yields the same order. 2758 -- Not sorting is more efficient, but it makes it harder to 2759 -- interpret a Value_Index_Set bit vector when debugging. 2760 2761 while Has_Next (Iter) loop 2762 Next (Iter, Point (P)); 2763 2764 -- If we have finished building up a Point value, then 2765 -- test it for matching. Otherwise, recurse to continue 2766 -- building up a point value. 2767 2768 if P = Part_Id'Last then 2769 Test_Point_For_Match; 2770 else 2771 Test_Points (P + 1); 2772 end if; 2773 end loop; 2774 end Test_Points; 2775 2776 begin 2777 Test_Points (1); 2778 if (for all Flag of Matches => not Flag) then 2779 return Empty; 2780 end if; 2781 return Allocate_Table_Element (Matches); 2782 end Matching_Values; 2783 2784 end Value_Sets; 2785 2786 -------------- 2787 -- Analysis -- 2788 -------------- 2789 2790 function Analysis return Choices_Info is 2791 Result : Choices_Info; 2792 Alt : Node_Id := First (Alternatives (Case_Statement)); 2793 A_Id : Alternative_Id := 1; 2794 C_Id : Choice_Id := 1; 2795 begin 2796 while Present (Alt) loop 2797 declare 2798 Choice : Node_Id := First (Discrete_Choices (Alt)); 2799 begin 2800 while Present (Choice) loop 2801 if Nkind (Choice) = N_Others_Choice then 2802 pragma Assert (Choices_Bounds (C_Id).Is_Others); 2803 Result (C_Id) := 2804 (Alternative => A_Id, 2805 Is_Others => True); 2806 else 2807 Result (C_Id) := 2808 (Alternative => A_Id, 2809 Is_Others => False, 2810 Matches => Value_Sets.Matching_Values 2811 (Choices_Bounds (C_Id).Ranges)); 2812 end if; 2813 Next (Choice); 2814 if C_Id /= Choice_Id'Last then 2815 C_Id := C_Id + 1; 2816 end if; 2817 end loop; 2818 end; 2819 2820 Next (Alt); 2821 if A_Id /= Alternative_Id'Last then 2822 A_Id := A_Id + 1; 2823 end if; 2824 end loop; 2825 2826 pragma Assert (A_Id = Alternative_Id'Last); 2827 pragma Assert (C_Id = Choice_Id'Last); 2828 2829 return Result; 2830 end Analysis; 2831 2832 end Choice_Analysis; 2833 2834 end Composite_Case_Ops; 2835 2836 -------------------------- 2837 -- Expand_Others_Choice -- 2838 -------------------------- 2839 2840 procedure Expand_Others_Choice 2841 (Case_Table : Choice_Table_Type; 2842 Others_Choice : Node_Id; 2843 Choice_Type : Entity_Id) 2844 is 2845 Loc : constant Source_Ptr := Sloc (Others_Choice); 2846 Choice_List : constant List_Id := New_List; 2847 Choice : Node_Id; 2848 Exp_Lo : Node_Id; 2849 Exp_Hi : Node_Id; 2850 Hi : Uint; 2851 Lo : Uint; 2852 Previous_Hi : Uint; 2853 2854 function Build_Choice (Value1, Value2 : Uint) return Node_Id; 2855 -- Builds a node representing the missing choices given by Value1 and 2856 -- Value2. A N_Range node is built if there is more than one literal 2857 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier 2858 -- or N_Character_Literal is built depending on what Choice_Type is. 2859 2860 function Lit_Of (Value : Uint) return Node_Id; 2861 -- Returns the Node_Id for the enumeration literal corresponding to the 2862 -- position given by Value within the enumeration type Choice_Type. The 2863 -- returned value has its Is_Static_Expression flag set to true. 2864 2865 ------------------ 2866 -- Build_Choice -- 2867 ------------------ 2868 2869 function Build_Choice (Value1, Value2 : Uint) return Node_Id is 2870 Lit_Node : Node_Id; 2871 Lo, Hi : Node_Id; 2872 2873 begin 2874 -- If there is only one choice value missing between Value1 and 2875 -- Value2, build an integer or enumeration literal to represent it. 2876 2877 if Value1 = Value2 then 2878 if Is_Integer_Type (Choice_Type) then 2879 Lit_Node := Make_Integer_Literal (Loc, Value1); 2880 Set_Etype (Lit_Node, Choice_Type); 2881 Set_Is_Static_Expression (Lit_Node); 2882 else 2883 Lit_Node := Lit_Of (Value1); 2884 end if; 2885 2886 -- Otherwise is more that one choice value that is missing between 2887 -- Value1 and Value2, therefore build a N_Range node of either 2888 -- integer or enumeration literals. 2889 2890 else 2891 if Is_Integer_Type (Choice_Type) then 2892 Lo := Make_Integer_Literal (Loc, Value1); 2893 Set_Etype (Lo, Choice_Type); 2894 Set_Is_Static_Expression (Lo); 2895 Hi := Make_Integer_Literal (Loc, Value2); 2896 Set_Etype (Hi, Choice_Type); 2897 Set_Is_Static_Expression (Hi); 2898 Lit_Node := 2899 Make_Range (Loc, 2900 Low_Bound => Lo, 2901 High_Bound => Hi); 2902 2903 else 2904 Lit_Node := 2905 Make_Range (Loc, 2906 Low_Bound => Lit_Of (Value1), 2907 High_Bound => Lit_Of (Value2)); 2908 end if; 2909 end if; 2910 2911 return Lit_Node; 2912 end Build_Choice; 2913 2914 ------------ 2915 -- Lit_Of -- 2916 ------------ 2917 2918 function Lit_Of (Value : Uint) return Node_Id is 2919 Lit : Entity_Id; 2920 2921 begin 2922 -- In the case where the literal is of type Character, there needs 2923 -- to be some special handling since there is no explicit chain 2924 -- of literals to search. Instead, a N_Character_Literal node 2925 -- is created with the appropriate Char_Code and Chars fields. 2926 2927 if Is_Standard_Character_Type (Choice_Type) then 2928 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 2929 Lit := 2930 Make_Character_Literal (Loc, 2931 Chars => Name_Find, 2932 Char_Literal_Value => Value); 2933 Set_Etype (Lit, Choice_Type); 2934 Set_Is_Static_Expression (Lit, True); 2935 return Lit; 2936 2937 -- Otherwise, iterate through the literals list of Choice_Type 2938 -- "Value" number of times until the desired literal is reached 2939 -- and then return an occurrence of it. 2940 2941 else 2942 Lit := First_Literal (Choice_Type); 2943 for J in 1 .. UI_To_Int (Value) loop 2944 Next_Literal (Lit); 2945 end loop; 2946 2947 return New_Occurrence_Of (Lit, Loc); 2948 end if; 2949 end Lit_Of; 2950 2951 -- Start of processing for Expand_Others_Choice 2952 2953 begin 2954 if Case_Table'Last = 0 then 2955 2956 -- Special case: only an others case is present. The others case 2957 -- covers the full range of the type. 2958 2959 if Is_OK_Static_Subtype (Choice_Type) then 2960 Choice := New_Occurrence_Of (Choice_Type, Loc); 2961 else 2962 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); 2963 end if; 2964 2965 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); 2966 return; 2967 end if; 2968 2969 -- Establish the bound values for the choice depending upon whether the 2970 -- type of the case statement is static or not. 2971 2972 if Is_OK_Static_Subtype (Choice_Type) then 2973 Exp_Lo := Type_Low_Bound (Choice_Type); 2974 Exp_Hi := Type_High_Bound (Choice_Type); 2975 else 2976 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); 2977 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); 2978 end if; 2979 2980 Lo := Expr_Value (Case_Table (1).Lo); 2981 Hi := Expr_Value (Case_Table (1).Hi); 2982 Previous_Hi := Expr_Value (Case_Table (1).Hi); 2983 2984 -- Build the node for any missing choices that are smaller than any 2985 -- explicit choices given in the case. 2986 2987 if Expr_Value (Exp_Lo) < Lo then 2988 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); 2989 end if; 2990 2991 -- Build the nodes representing any missing choices that lie between 2992 -- the explicit ones given in the case. 2993 2994 for J in 2 .. Case_Table'Last loop 2995 Lo := Expr_Value (Case_Table (J).Lo); 2996 Hi := Expr_Value (Case_Table (J).Hi); 2997 2998 if Lo /= (Previous_Hi + 1) then 2999 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); 3000 end if; 3001 3002 Previous_Hi := Hi; 3003 end loop; 3004 3005 -- Build the node for any missing choices that are greater than any 3006 -- explicit choices given in the case. 3007 3008 if Expr_Value (Exp_Hi) > Hi then 3009 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); 3010 end if; 3011 3012 Set_Others_Discrete_Choices (Others_Choice, Choice_List); 3013 3014 -- Warn on null others list if warning option set 3015 3016 if Warn_On_Redundant_Constructs 3017 and then Comes_From_Source (Others_Choice) 3018 and then Is_Empty_List (Choice_List) 3019 then 3020 Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice); 3021 Error_Msg_N ("\?r?previous choices cover all values", Others_Choice); 3022 end if; 3023 end Expand_Others_Choice; 3024 3025 ----------- 3026 -- No_OP -- 3027 ----------- 3028 3029 procedure No_OP (C : Node_Id) is 3030 begin 3031 if Nkind (C) = N_Range and then Warn_On_Redundant_Constructs then 3032 Error_Msg_N ("choice is an empty range?r?", C); 3033 end if; 3034 end No_OP; 3035 3036 ----------------------------- 3037 -- Generic_Analyze_Choices -- 3038 ----------------------------- 3039 3040 package body Generic_Analyze_Choices is 3041 3042 -- The following type is used to gather the entries for the choice 3043 -- table, so that we can then allocate the right length. 3044 3045 type Link; 3046 type Link_Ptr is access all Link; 3047 3048 type Link is record 3049 Val : Choice_Bounds; 3050 Nxt : Link_Ptr; 3051 end record; 3052 3053 --------------------- 3054 -- Analyze_Choices -- 3055 --------------------- 3056 3057 procedure Analyze_Choices 3058 (Alternatives : List_Id; 3059 Subtyp : Entity_Id) 3060 is 3061 Choice_Type : constant Entity_Id := Base_Type (Subtyp); 3062 -- The actual type against which the discrete choices are resolved. 3063 -- Note that this type is always the base type not the subtype of the 3064 -- ruling expression, index or discriminant. 3065 3066 Expected_Type : Entity_Id; 3067 -- The expected type of each choice. Equal to Choice_Type, except if 3068 -- the expression is universal, in which case the choices can be of 3069 -- any integer type. 3070 3071 Alt : Node_Id; 3072 -- A case statement alternative or a variant in a record type 3073 -- declaration. 3074 3075 Choice : Node_Id; 3076 Kind : Node_Kind; 3077 -- The node kind of the current Choice 3078 3079 begin 3080 -- Set Expected type (= choice type except for universal integer, 3081 -- where we accept any integer type as a choice). 3082 3083 if Choice_Type = Universal_Integer then 3084 Expected_Type := Any_Integer; 3085 else 3086 Expected_Type := Choice_Type; 3087 end if; 3088 3089 -- Now loop through the case alternatives or record variants 3090 3091 Alt := First (Alternatives); 3092 while Present (Alt) loop 3093 3094 -- If pragma, just analyze it 3095 3096 if Nkind (Alt) = N_Pragma then 3097 Analyze (Alt); 3098 3099 -- Otherwise we have an alternative. In most cases the semantic 3100 -- processing leaves the list of choices unchanged 3101 3102 -- Check each choice against its base type 3103 3104 else 3105 Choice := First (Discrete_Choices (Alt)); 3106 while Present (Choice) loop 3107 Analyze (Choice); 3108 Kind := Nkind (Choice); 3109 3110 -- Choice is a Range 3111 3112 if Kind = N_Range 3113 or else (Kind = N_Attribute_Reference 3114 and then Attribute_Name (Choice) = Name_Range) 3115 then 3116 Resolve (Choice, Expected_Type); 3117 3118 -- Choice is a subtype name, nothing further to do now 3119 3120 elsif Is_Entity_Name (Choice) 3121 and then Is_Type (Entity (Choice)) 3122 then 3123 null; 3124 3125 -- Choice is a subtype indication 3126 3127 elsif Kind = N_Subtype_Indication then 3128 Resolve_Discrete_Subtype_Indication 3129 (Choice, Expected_Type); 3130 3131 -- Others choice, no analysis needed 3132 3133 elsif Kind = N_Others_Choice then 3134 null; 3135 3136 -- Only other possibility is an expression 3137 3138 else 3139 Resolve (Choice, Expected_Type); 3140 end if; 3141 3142 -- Move to next choice 3143 3144 Next (Choice); 3145 end loop; 3146 3147 Process_Associated_Node (Alt); 3148 end if; 3149 3150 Next (Alt); 3151 end loop; 3152 end Analyze_Choices; 3153 3154 end Generic_Analyze_Choices; 3155 3156 --------------------------- 3157 -- Generic_Check_Choices -- 3158 --------------------------- 3159 3160 package body Generic_Check_Choices is 3161 3162 -- The following type is used to gather the entries for the choice 3163 -- table, so that we can then allocate the right length. 3164 3165 type Link; 3166 type Link_Ptr is access all Link; 3167 3168 type Link is record 3169 Val : Choice_Bounds; 3170 Nxt : Link_Ptr; 3171 end record; 3172 3173 procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); 3174 3175 ------------------- 3176 -- Check_Choices -- 3177 ------------------- 3178 3179 procedure Check_Choices 3180 (N : Node_Id; 3181 Alternatives : List_Id; 3182 Subtyp : Entity_Id; 3183 Others_Present : out Boolean) 3184 is 3185 E : Entity_Id; 3186 3187 Raises_CE : Boolean; 3188 -- Set True if one of the bounds of a choice raises CE 3189 3190 Enode : Node_Id; 3191 -- This is where we post error messages for bounds out of range 3192 3193 Choice_List : Link_Ptr := null; 3194 -- Gather list of choices 3195 3196 Num_Choices : Nat := 0; 3197 -- Number of entries in Choice_List 3198 3199 Choice_Type : constant Entity_Id := Base_Type (Subtyp); 3200 -- The actual type against which the discrete choices are resolved. 3201 -- Note that this type is always the base type not the subtype of the 3202 -- ruling expression, index or discriminant. 3203 3204 Bounds_Type : Entity_Id; 3205 -- The type from which are derived the bounds of the values covered 3206 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice 3207 -- specifies a value outside of these bounds we have an error. 3208 3209 Bounds_Lo : Uint; 3210 Bounds_Hi : Uint; 3211 -- The actual bounds of the above type 3212 3213 Expected_Type : Entity_Id; 3214 -- The expected type of each choice. Equal to Choice_Type, except if 3215 -- the expression is universal, in which case the choices can be of 3216 -- any integer type. 3217 3218 Alt : Node_Id; 3219 -- A case statement alternative or a variant in a record type 3220 -- declaration. 3221 3222 Choice : Node_Id; 3223 Kind : Node_Kind; 3224 -- The node kind of the current Choice 3225 3226 Others_Choice : Node_Id := Empty; 3227 -- Remember others choice if it is present (empty otherwise) 3228 3229 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); 3230 -- Checks the validity of the bounds of a choice. When the bounds 3231 -- are static and no error occurred the bounds are collected for 3232 -- later entry into the choices table so that they can be sorted 3233 -- later on. 3234 3235 procedure Check_Case_Pattern_Choices; 3236 -- Check choices validity for the Ada extension case where the 3237 -- selecting expression is not of a discrete type and so the 3238 -- choices are patterns. 3239 3240 procedure Check_Composite_Case_Selector; 3241 -- Check that the (non-discrete) type of the expression being 3242 -- cased on is suitable. 3243 3244 procedure Handle_Static_Predicate 3245 (Typ : Entity_Id; 3246 Lo : Node_Id; 3247 Hi : Node_Id); 3248 -- If the type of the alternative has predicates, we must examine 3249 -- each subset of the predicate rather than the bounds of the type 3250 -- itself. This is relevant when the choice is a subtype mark or a 3251 -- subtype indication. 3252 3253 ----------- 3254 -- Check -- 3255 ----------- 3256 3257 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is 3258 Lo_Val : Uint; 3259 Hi_Val : Uint; 3260 3261 begin 3262 -- First check if an error was already detected on either bounds 3263 3264 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then 3265 return; 3266 3267 -- Do not insert non static choices in the table to be sorted 3268 3269 elsif not Is_OK_Static_Expression (Lo) 3270 or else 3271 not Is_OK_Static_Expression (Hi) 3272 then 3273 Process_Non_Static_Choice (Choice); 3274 return; 3275 3276 -- Ignore range which raise constraint error 3277 3278 elsif Raises_Constraint_Error (Lo) 3279 or else Raises_Constraint_Error (Hi) 3280 then 3281 Raises_CE := True; 3282 return; 3283 3284 -- AI05-0188 : Within an instance the non-others choices do not 3285 -- have to belong to the actual subtype. 3286 3287 elsif Ada_Version >= Ada_2012 and then In_Instance then 3288 return; 3289 3290 -- Otherwise we have an OK static choice 3291 3292 else 3293 Lo_Val := Expr_Value (Lo); 3294 Hi_Val := Expr_Value (Hi); 3295 3296 -- Do not insert null ranges in the choices table 3297 3298 if Lo_Val > Hi_Val then 3299 Process_Empty_Choice (Choice); 3300 return; 3301 end if; 3302 end if; 3303 3304 -- Check for low bound out of range 3305 3306 if Lo_Val < Bounds_Lo then 3307 3308 -- If the choice is an entity name, then it is a type, and we 3309 -- want to post the message on the reference to this entity. 3310 -- Otherwise post it on the lower bound of the range. 3311 3312 if Is_Entity_Name (Choice) then 3313 Enode := Choice; 3314 else 3315 Enode := Lo; 3316 end if; 3317 3318 -- Specialize message for integer/enum type 3319 3320 if Is_Integer_Type (Bounds_Type) then 3321 Error_Msg_Uint_1 := Bounds_Lo; 3322 Error_Msg_N ("minimum allowed choice value is^", Enode); 3323 else 3324 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); 3325 Error_Msg_N ("minimum allowed choice value is%", Enode); 3326 end if; 3327 end if; 3328 3329 -- Check for high bound out of range 3330 3331 if Hi_Val > Bounds_Hi then 3332 3333 -- If the choice is an entity name, then it is a type, and we 3334 -- want to post the message on the reference to this entity. 3335 -- Otherwise post it on the upper bound of the range. 3336 3337 if Is_Entity_Name (Choice) then 3338 Enode := Choice; 3339 else 3340 Enode := Hi; 3341 end if; 3342 3343 -- Specialize message for integer/enum type 3344 3345 if Is_Integer_Type (Bounds_Type) then 3346 Error_Msg_Uint_1 := Bounds_Hi; 3347 Error_Msg_N ("maximum allowed choice value is^", Enode); 3348 else 3349 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); 3350 Error_Msg_N ("maximum allowed choice value is%", Enode); 3351 end if; 3352 end if; 3353 3354 -- Collect bounds in the list 3355 3356 -- Note: we still store the bounds, even if they are out of range, 3357 -- since this may prevent unnecessary cascaded errors for values 3358 -- that are covered by such an excessive range. 3359 3360 Choice_List := 3361 new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); 3362 Num_Choices := Num_Choices + 1; 3363 end Check; 3364 3365 -------------------------------- 3366 -- Check_Case_Pattern_Choices -- 3367 -------------------------------- 3368 3369 procedure Check_Case_Pattern_Choices is 3370 -- ??? Need to Free/Finalize value sets allocated here. 3371 3372 package Ops is new Composite_Case_Ops.Choice_Analysis 3373 (Case_Statement => N); 3374 use Ops; 3375 use Ops.Value_Sets; 3376 3377 Empty : Value_Set renames Value_Sets.Empty; 3378 -- Cope with hiding due to multiple use clauses 3379 3380 Info : constant Choices_Info := Analysis; 3381 Others_Seen : Boolean := False; 3382 3383 begin 3384 declare 3385 Matches : array (Alternative_Id) of Value_Sets.Value_Set := 3386 (others => Empty); 3387 3388 Flag_Overlapping_Within_One_Alternative : constant Boolean := 3389 False; 3390 -- We may want to flag overlapping (perhaps with only a 3391 -- warning) if the pattern binds an identifier, as in 3392 -- when (Positive, <X>) | (Integer, <X>) => 3393 3394 Covered : Value_Set := Empty; 3395 -- The union of all alternatives seen so far 3396 3397 begin 3398 for Choice of Info loop 3399 if Choice.Is_Others then 3400 Others_Seen := True; 3401 else 3402 if Flag_Overlapping_Within_One_Alternative 3403 and then (Compare (Matches (Choice.Alternative), 3404 Choice.Matches) /= Disjoint) 3405 then 3406 Error_Msg_N 3407 ("bad overlapping within one alternative", N); 3408 end if; 3409 3410 Union (Target => Matches (Choice.Alternative), 3411 Source => Choice.Matches); 3412 end if; 3413 end loop; 3414 3415 for A1 in Alternative_Id loop 3416 for A2 in Alternative_Id 3417 range A1 + 1 .. Alternative_Id'Last 3418 loop 3419 case Compare (Matches (A1), Matches (A2)) is 3420 when Disjoint | Contained_By => 3421 null; -- OK 3422 when Overlaps => 3423 declare 3424 Uncovered_1, Uncovered_2 : Value_Set := Empty; 3425 begin 3426 Union (Uncovered_1, Matches (A1)); 3427 Remove (Uncovered_1, Covered); 3428 Union (Uncovered_2, Matches (A2)); 3429 Remove (Uncovered_2, Covered); 3430 3431 -- Recheck for overlap after removing choices 3432 -- covered by earlier alternatives. 3433 3434 case Compare (Uncovered_1, Uncovered_2) is 3435 when Disjoint | Contained_By => 3436 null; 3437 when Contains | Overlaps | Equal => 3438 Error_Msg_N 3439 ("bad alternative overlapping", N); 3440 end case; 3441 end; 3442 3443 when Equal => 3444 Error_Msg_N ("alternatives match same values", N); 3445 when Contains => 3446 Error_Msg_N ("alternatives in wrong order", N); 3447 end case; 3448 end loop; 3449 3450 Union (Target => Covered, Source => Matches (A1)); 3451 end loop; 3452 3453 if (not Others_Seen) and then not Complement_Is_Empty (Covered) 3454 then 3455 Error_Msg_N ("not all values are covered", N); 3456 end if; 3457 end; 3458 3459 Ops.Value_Sets.Free_Value_Sets; 3460 end Check_Case_Pattern_Choices; 3461 3462 ----------------------------------- 3463 -- Check_Composite_Case_Selector -- 3464 ----------------------------------- 3465 3466 procedure Check_Composite_Case_Selector is 3467 begin 3468 if not Is_Composite_Type (Subtyp) then 3469 Error_Msg_N 3470 ("case selector type must be discrete or composite", N); 3471 elsif Is_Limited_Type (Subtyp) then 3472 Error_Msg_N ("case selector type must not be limited", N); 3473 elsif Is_Class_Wide_Type (Subtyp) then 3474 Error_Msg_N ("case selector type must not be class-wide", N); 3475 elsif Needs_Finalization (Subtyp) 3476 and then Is_Newly_Constructed 3477 (Expression (N), Context_Requires_NC => False) 3478 then 3479 -- We could allow this case as long as there are no bindings. 3480 -- 3481 -- If there are bindings, then allowing this case will get 3482 -- messy because the selector expression will be finalized 3483 -- before the statements of the selected alternative are 3484 -- executed (unless we add an INOX-specific change to the 3485 -- accessibility rules to prevent this earlier-than-wanted 3486 -- finalization, but adding new INOX-specific accessibility 3487 -- complexity is probably not the direction we want to go). 3488 -- This early selector finalization would be ok if we made 3489 -- copies in this case (so that the bindings would not yield 3490 -- a view of a finalized object), but then we'd have to deal 3491 -- with finalizing those copies (which would necessarily 3492 -- include defining their accessibility level). So it gets 3493 -- messy either way. 3494 3495 Error_Msg_N ("case selector must not require finalization", N); 3496 end if; 3497 end Check_Composite_Case_Selector; 3498 3499 ----------------------------- 3500 -- Handle_Static_Predicate -- 3501 ----------------------------- 3502 3503 procedure Handle_Static_Predicate 3504 (Typ : Entity_Id; 3505 Lo : Node_Id; 3506 Hi : Node_Id) 3507 is 3508 P : Node_Id; 3509 C : Node_Id; 3510 3511 begin 3512 -- Loop through entries in predicate list, checking each entry. 3513 -- Note that if the list is empty, corresponding to a False 3514 -- predicate, then no choices are checked. If the choice comes 3515 -- from a subtype indication, the given range may have bounds 3516 -- that narrow the predicate choices themselves, so we must 3517 -- consider only those entries within the range of the given 3518 -- subtype indication.. 3519 3520 P := First (Static_Discrete_Predicate (Typ)); 3521 while Present (P) loop 3522 3523 -- Check that part of the predicate choice is included in the 3524 -- given bounds. 3525 3526 if Expr_Value (High_Bound (P)) >= Expr_Value (Lo) 3527 and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi) 3528 then 3529 C := New_Copy (P); 3530 Set_Sloc (C, Sloc (Choice)); 3531 Set_Original_Node (C, Choice); 3532 3533 if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then 3534 Set_Low_Bound (C, Lo); 3535 end if; 3536 3537 if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then 3538 Set_High_Bound (C, Hi); 3539 end if; 3540 3541 Check (C, Low_Bound (C), High_Bound (C)); 3542 end if; 3543 3544 Next (P); 3545 end loop; 3546 3547 Set_Has_SP_Choice (Alt); 3548 end Handle_Static_Predicate; 3549 3550 -- Start of processing for Check_Choices 3551 3552 begin 3553 Raises_CE := False; 3554 Others_Present := False; 3555 3556 -- If Subtyp is not a discrete type or there was some other error, 3557 -- then don't try any semantic checking on the choices since we have 3558 -- a complete mess. 3559 3560 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then 3561 3562 -- Hold on, maybe it isn't a complete mess after all. 3563 3564 if Extensions_Allowed and then Subtyp /= Any_Type then 3565 Check_Composite_Case_Selector; 3566 Check_Case_Pattern_Choices; 3567 end if; 3568 3569 return; 3570 end if; 3571 3572 -- If Subtyp is not a static subtype Ada 95 requires then we use the 3573 -- bounds of its base type to determine the values covered by the 3574 -- discrete choices. 3575 3576 -- In Ada 2012, if the subtype has a nonstatic predicate the full 3577 -- range of the base type must be covered as well. 3578 3579 if Is_OK_Static_Subtype (Subtyp) then 3580 if not Has_Predicates (Subtyp) 3581 or else Has_Static_Predicate (Subtyp) 3582 then 3583 Bounds_Type := Subtyp; 3584 else 3585 Bounds_Type := Choice_Type; 3586 end if; 3587 3588 else 3589 Bounds_Type := Choice_Type; 3590 end if; 3591 3592 -- Obtain static bounds of type, unless this is a generic formal 3593 -- discrete type for which all choices will be nonstatic. 3594 3595 if not Is_Generic_Type (Root_Type (Bounds_Type)) 3596 or else Ekind (Bounds_Type) /= E_Enumeration_Type 3597 then 3598 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); 3599 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); 3600 end if; 3601 3602 if Choice_Type = Universal_Integer then 3603 Expected_Type := Any_Integer; 3604 else 3605 Expected_Type := Choice_Type; 3606 end if; 3607 3608 -- Now loop through the case alternatives or record variants 3609 3610 Alt := First (Alternatives); 3611 while Present (Alt) loop 3612 3613 -- If pragma, just analyze it 3614 3615 if Nkind (Alt) = N_Pragma then 3616 Analyze (Alt); 3617 3618 -- Otherwise we have an alternative. In most cases the semantic 3619 -- processing leaves the list of choices unchanged 3620 3621 -- Check each choice against its base type 3622 3623 else 3624 Choice := First (Discrete_Choices (Alt)); 3625 while Present (Choice) loop 3626 Kind := Nkind (Choice); 3627 3628 -- Choice is a Range 3629 3630 if Kind = N_Range 3631 or else (Kind = N_Attribute_Reference 3632 and then Attribute_Name (Choice) = Name_Range) 3633 then 3634 Check (Choice, Low_Bound (Choice), High_Bound (Choice)); 3635 3636 -- Choice is a subtype name 3637 3638 elsif Is_Entity_Name (Choice) 3639 and then Is_Type (Entity (Choice)) 3640 then 3641 -- Check for inappropriate type 3642 3643 if not Covers (Expected_Type, Etype (Choice)) then 3644 Wrong_Type (Choice, Choice_Type); 3645 3646 -- Type is OK, so check further 3647 3648 else 3649 E := Entity (Choice); 3650 3651 -- Case of predicated subtype 3652 3653 if Has_Predicates (E) then 3654 3655 -- Use of nonstatic predicate is an error 3656 3657 if not Is_Discrete_Type (E) 3658 or else not Has_Static_Predicate (E) 3659 or else Has_Dynamic_Predicate_Aspect (E) 3660 then 3661 Bad_Predicated_Subtype_Use 3662 ("cannot use subtype& with non-static " 3663 & "predicate as case alternative", 3664 Choice, E, Suggest_Static => True); 3665 3666 -- Static predicate case. The bounds are those of 3667 -- the given subtype. 3668 3669 else 3670 Handle_Static_Predicate (E, 3671 Type_Low_Bound (E), Type_High_Bound (E)); 3672 end if; 3673 3674 -- Not predicated subtype case 3675 3676 elsif not Is_OK_Static_Subtype (E) then 3677 Process_Non_Static_Choice (Choice); 3678 else 3679 Check 3680 (Choice, Type_Low_Bound (E), Type_High_Bound (E)); 3681 end if; 3682 end if; 3683 3684 -- Choice is a subtype indication 3685 3686 elsif Kind = N_Subtype_Indication then 3687 Resolve_Discrete_Subtype_Indication 3688 (Choice, Expected_Type); 3689 3690 if Etype (Choice) /= Any_Type then 3691 declare 3692 C : constant Node_Id := Constraint (Choice); 3693 R : constant Node_Id := Range_Expression (C); 3694 L : constant Node_Id := Low_Bound (R); 3695 H : constant Node_Id := High_Bound (R); 3696 3697 begin 3698 E := Entity (Subtype_Mark (Choice)); 3699 3700 if not Is_OK_Static_Subtype (E) then 3701 Process_Non_Static_Choice (Choice); 3702 3703 else 3704 if Is_OK_Static_Expression (L) 3705 and then 3706 Is_OK_Static_Expression (H) 3707 then 3708 if Expr_Value (L) > Expr_Value (H) then 3709 Process_Empty_Choice (Choice); 3710 else 3711 if Is_Out_Of_Range (L, E) then 3712 Apply_Compile_Time_Constraint_Error 3713 (L, "static value out of range", 3714 CE_Range_Check_Failed); 3715 end if; 3716 3717 if Is_Out_Of_Range (H, E) then 3718 Apply_Compile_Time_Constraint_Error 3719 (H, "static value out of range", 3720 CE_Range_Check_Failed); 3721 end if; 3722 end if; 3723 end if; 3724 3725 -- Check applicable predicate values within the 3726 -- bounds of the given range. 3727 3728 if Has_Static_Predicate (E) then 3729 Handle_Static_Predicate (E, L, H); 3730 3731 else 3732 Check (Choice, L, H); 3733 end if; 3734 end if; 3735 end; 3736 end if; 3737 3738 -- The others choice is only allowed for the last 3739 -- alternative and as its only choice. 3740 3741 elsif Kind = N_Others_Choice then 3742 if not (Choice = First (Discrete_Choices (Alt)) 3743 and then Choice = Last (Discrete_Choices (Alt)) 3744 and then Alt = Last (Alternatives)) 3745 then 3746 Error_Msg_N 3747 ("the choice OTHERS must appear alone and last", 3748 Choice); 3749 return; 3750 end if; 3751 3752 Others_Present := True; 3753 Others_Choice := Choice; 3754 3755 -- Only other possibility is an expression 3756 3757 else 3758 Check (Choice, Choice, Choice); 3759 end if; 3760 3761 -- Move to next choice 3762 3763 Next (Choice); 3764 end loop; 3765 3766 Process_Associated_Node (Alt); 3767 end if; 3768 3769 Next (Alt); 3770 end loop; 3771 3772 -- Now we can create the Choice_Table, since we know how long 3773 -- it needs to be so we can allocate exactly the right length. 3774 3775 declare 3776 Choice_Table : Choice_Table_Type (0 .. Num_Choices); 3777 3778 begin 3779 -- Now copy the items we collected in the linked list into this 3780 -- newly allocated table (leave entry 0 unused for sorting). 3781 3782 declare 3783 T : Link_Ptr; 3784 begin 3785 for J in 1 .. Num_Choices loop 3786 T := Choice_List; 3787 Choice_List := T.Nxt; 3788 Choice_Table (J) := T.Val; 3789 Free (T); 3790 end loop; 3791 end; 3792 3793 Check_Choice_Set 3794 (Choice_Table, 3795 Bounds_Type, 3796 Subtyp, 3797 Others_Present or else (Choice_Type = Universal_Integer), 3798 N); 3799 3800 -- If no others choice we are all done, otherwise we have one more 3801 -- step, which is to set the Others_Discrete_Choices field of the 3802 -- others choice (to contain all otherwise unspecified choices). 3803 -- Skip this if CE is known to be raised. 3804 3805 if Others_Present and not Raises_CE then 3806 Expand_Others_Choice 3807 (Case_Table => Choice_Table, 3808 Others_Choice => Others_Choice, 3809 Choice_Type => Bounds_Type); 3810 end if; 3811 end; 3812 end Check_Choices; 3813 3814 end Generic_Check_Choices; 3815 3816 ----------------------------------------- 3817 -- Has_Static_Discriminant_Constraint -- 3818 ----------------------------------------- 3819 3820 function Has_Static_Discriminant_Constraint 3821 (Subtyp : Entity_Id) return Boolean 3822 is 3823 begin 3824 if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then 3825 declare 3826 DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp)); 3827 begin 3828 while Present (DC_Elmt) loop 3829 if not All_Composite_Constraints_Static (Node (DC_Elmt)) then 3830 return False; 3831 end if; 3832 Next_Elmt (DC_Elmt); 3833 end loop; 3834 return True; 3835 end; 3836 end if; 3837 return False; 3838 end Has_Static_Discriminant_Constraint; 3839 3840 ---------------------------- 3841 -- Is_Case_Choice_Pattern -- 3842 ---------------------------- 3843 3844 function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is 3845 E : Node_Id := Expr; 3846 begin 3847 if not Extensions_Allowed then 3848 return False; 3849 end if; 3850 3851 loop 3852 case Nkind (E) is 3853 when N_Case_Statement_Alternative 3854 | N_Case_Expression_Alternative 3855 => 3856 -- We could return False if selecting expression is discrete, 3857 -- but this doesn't seem to be worth the bother. 3858 return True; 3859 3860 when N_Empty 3861 | N_Statement_Other_Than_Procedure_Call 3862 | N_Procedure_Call_Statement 3863 | N_Declaration 3864 => 3865 return False; 3866 3867 when others => 3868 E := Parent (E); 3869 end case; 3870 end loop; 3871 end Is_Case_Choice_Pattern; 3872 3873end Sem_Case; 3874