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-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Errout; use Errout; 29with Namet; use Namet; 30with Nlists; use Nlists; 31with Nmake; use Nmake; 32with Opt; use Opt; 33with Sem; use Sem; 34with Sem_Aux; use Sem_Aux; 35with Sem_Eval; use Sem_Eval; 36with Sem_Res; use Sem_Res; 37with Sem_Util; use Sem_Util; 38with Sem_Type; use Sem_Type; 39with Snames; use Snames; 40with Stand; use Stand; 41with Sinfo; use Sinfo; 42with Tbuild; use Tbuild; 43with Uintp; use Uintp; 44 45with Ada.Unchecked_Deallocation; 46 47with GNAT.Heap_Sort_G; 48 49package body Sem_Case is 50 51 type Choice_Bounds is record 52 Lo : Node_Id; 53 Hi : Node_Id; 54 Node : Node_Id; 55 end record; 56 -- Represent one choice bounds entry with Lo and Hi values, Node points 57 -- to the choice node itself. 58 59 type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; 60 -- Table type used to sort the choices present in a case statement, array 61 -- aggregate or record variant. The actual entries are stored in 1 .. Last, 62 -- but we have a 0 entry for convenience in sorting. 63 64 ----------------------- 65 -- Local Subprograms -- 66 ----------------------- 67 68 procedure Check_Choices 69 (Choice_Table : in out Choice_Table_Type; 70 Bounds_Type : Entity_Id; 71 Subtyp : Entity_Id; 72 Others_Present : Boolean; 73 Case_Node : Node_Id); 74 -- This is the procedure which verifies that a set of case alternatives 75 -- or record variant choices has no duplicates, and covers the range 76 -- specified by Bounds_Type. Choice_Table contains the discrete choices 77 -- to check. These must start at position 1. 78 -- 79 -- Furthermore Choice_Table (0) must exist. This element is used by 80 -- the sorting algorithm as a temporary. Others_Present is a flag 81 -- indicating whether or not an Others choice is present. Finally 82 -- Msg_Sloc gives the source location of the construct containing the 83 -- choices in the Choice_Table. 84 -- 85 -- Bounds_Type is the type whose range must be covered by the alternatives 86 -- 87 -- Subtyp is the subtype of the expression. If its bounds are non-static 88 -- the alternatives must cover its base type. 89 90 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; 91 -- Given a Pos value of enumeration type Ctype, returns the name 92 -- ID of an appropriate string to be used in error message output. 93 94 procedure Expand_Others_Choice 95 (Case_Table : Choice_Table_Type; 96 Others_Choice : Node_Id; 97 Choice_Type : Entity_Id); 98 -- The case table is the table generated by a call to Analyze_Choices 99 -- (with just 1 .. Last_Choice entries present). Others_Choice is a 100 -- pointer to the N_Others_Choice node (this routine is only called if 101 -- an others choice is present), and Choice_Type is the discrete type 102 -- of the bounds. The effect of this call is to analyze the cases and 103 -- determine the set of values covered by others. This choice list is 104 -- set in the Others_Discrete_Choices field of the N_Others_Choice node. 105 106 ------------------- 107 -- Check_Choices -- 108 ------------------- 109 110 procedure Check_Choices 111 (Choice_Table : in out Choice_Table_Type; 112 Bounds_Type : Entity_Id; 113 Subtyp : Entity_Id; 114 Others_Present : Boolean; 115 Case_Node : Node_Id) 116 is 117 procedure Explain_Non_Static_Bound; 118 -- Called when we find a non-static bound, requiring the base type to 119 -- be covered. Provides where possible a helpful explanation of why the 120 -- bounds are non-static, since this is not always obvious. 121 122 function Lt_Choice (C1, C2 : Natural) return Boolean; 123 -- Comparison routine for comparing Choice_Table entries. Use the lower 124 -- bound of each Choice as the key. 125 126 procedure Move_Choice (From : Natural; To : Natural); 127 -- Move routine for sorting the Choice_Table 128 129 package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); 130 131 procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id); 132 procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint); 133 procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id); 134 procedure Issue_Msg (Value1 : Uint; Value2 : Uint); 135 -- Issue an error message indicating that there are missing choices, 136 -- followed by the image of the missing choices themselves which lie 137 -- between Value1 and Value2 inclusive. 138 139 --------------- 140 -- Issue_Msg -- 141 --------------- 142 143 procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is 144 begin 145 Issue_Msg (Expr_Value (Value1), Expr_Value (Value2)); 146 end Issue_Msg; 147 148 procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is 149 begin 150 Issue_Msg (Expr_Value (Value1), Value2); 151 end Issue_Msg; 152 153 procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is 154 begin 155 Issue_Msg (Value1, Expr_Value (Value2)); 156 end Issue_Msg; 157 158 procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is 159 Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); 160 161 begin 162 -- AI05-0188 : within an instance the non-others choices do not 163 -- have to belong to the actual subtype. 164 165 if Ada_Version >= Ada_2012 and then In_Instance then 166 return; 167 end if; 168 169 -- In some situations, we call this with a null range, and 170 -- obviously we don't want to complain in this case! 171 172 if Value1 > Value2 then 173 return; 174 end if; 175 176 -- Case of only one value that is missing 177 178 if Value1 = Value2 then 179 if Is_Integer_Type (Bounds_Type) then 180 Error_Msg_Uint_1 := Value1; 181 Error_Msg ("missing case value: ^!", Msg_Sloc); 182 else 183 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); 184 Error_Msg ("missing case value: %!", Msg_Sloc); 185 end if; 186 187 -- More than one choice value, so print range of values 188 189 else 190 if Is_Integer_Type (Bounds_Type) then 191 Error_Msg_Uint_1 := Value1; 192 Error_Msg_Uint_2 := Value2; 193 Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); 194 else 195 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); 196 Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); 197 Error_Msg ("missing case values: % .. %!", Msg_Sloc); 198 end if; 199 end if; 200 end Issue_Msg; 201 202 --------------- 203 -- Lt_Choice -- 204 --------------- 205 206 function Lt_Choice (C1, C2 : Natural) return Boolean is 207 begin 208 return 209 Expr_Value (Choice_Table (Nat (C1)).Lo) 210 < 211 Expr_Value (Choice_Table (Nat (C2)).Lo); 212 end Lt_Choice; 213 214 ----------------- 215 -- Move_Choice -- 216 ----------------- 217 218 procedure Move_Choice (From : Natural; To : Natural) is 219 begin 220 Choice_Table (Nat (To)) := Choice_Table (Nat (From)); 221 end Move_Choice; 222 223 ------------------------------ 224 -- Explain_Non_Static_Bound -- 225 ------------------------------ 226 227 procedure Explain_Non_Static_Bound is 228 Expr : Node_Id; 229 230 begin 231 if Nkind (Case_Node) = N_Variant_Part then 232 Expr := Name (Case_Node); 233 else 234 Expr := Expression (Case_Node); 235 end if; 236 237 if Bounds_Type /= Subtyp then 238 239 -- If the case is a variant part, the expression is given by 240 -- the discriminant itself, and the bounds are the culprits. 241 242 if Nkind (Case_Node) = N_Variant_Part then 243 Error_Msg_NE 244 ("bounds of & are not static," & 245 " alternatives must cover base type", Expr, Expr); 246 247 -- If this is a case statement, the expression may be 248 -- non-static or else the subtype may be at fault. 249 250 elsif Is_Entity_Name (Expr) then 251 Error_Msg_NE 252 ("bounds of & are not static," & 253 " alternatives must cover base type", Expr, Expr); 254 255 else 256 Error_Msg_N 257 ("subtype of expression is not static," 258 & " alternatives must cover base type!", Expr); 259 end if; 260 261 -- Otherwise the expression is not static, even if the bounds of the 262 -- type are, or else there are missing alternatives. If both, the 263 -- additional information may be redundant but harmless. 264 265 elsif not Is_Entity_Name (Expr) then 266 Error_Msg_N 267 ("subtype of expression is not static, " 268 & "alternatives must cover base type!", Expr); 269 end if; 270 end Explain_Non_Static_Bound; 271 272 -- Variables local to Check_Choices 273 274 Choice : Node_Id; 275 Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); 276 Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); 277 278 Prev_Choice : Node_Id; 279 280 Hi : Uint; 281 Lo : Uint; 282 Prev_Hi : Uint; 283 284 -- Start of processing for Check_Choices 285 286 begin 287 -- Choice_Table must start at 0 which is an unused location used 288 -- by the sorting algorithm. However the first valid position for 289 -- a discrete choice is 1. 290 291 pragma Assert (Choice_Table'First = 0); 292 293 if Choice_Table'Last = 0 then 294 if not Others_Present then 295 Issue_Msg (Bounds_Lo, Bounds_Hi); 296 end if; 297 298 return; 299 end if; 300 301 Sorting.Sort (Positive (Choice_Table'Last)); 302 303 Lo := Expr_Value (Choice_Table (1).Lo); 304 Hi := Expr_Value (Choice_Table (1).Hi); 305 Prev_Hi := Hi; 306 307 if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then 308 Issue_Msg (Bounds_Lo, Lo - 1); 309 310 -- If values are missing outside of the subtype, add explanation. 311 -- No additional message if only one value is missing. 312 313 if Expr_Value (Bounds_Lo) < Lo - 1 then 314 Explain_Non_Static_Bound; 315 end if; 316 end if; 317 318 for J in 2 .. Choice_Table'Last loop 319 Lo := Expr_Value (Choice_Table (J).Lo); 320 Hi := Expr_Value (Choice_Table (J).Hi); 321 322 if Lo <= Prev_Hi then 323 Choice := Choice_Table (J).Node; 324 325 -- Find first previous choice that overlaps 326 327 for K in 1 .. J - 1 loop 328 if Lo <= Expr_Value (Choice_Table (K).Hi) then 329 Prev_Choice := Choice_Table (K).Node; 330 exit; 331 end if; 332 end loop; 333 334 if Sloc (Prev_Choice) <= Sloc (Choice) then 335 Error_Msg_Sloc := Sloc (Prev_Choice); 336 Error_Msg_N ("duplication of choice value#", Choice); 337 else 338 Error_Msg_Sloc := Sloc (Choice); 339 Error_Msg_N ("duplication of choice value#", Prev_Choice); 340 end if; 341 342 elsif not Others_Present and then Lo /= Prev_Hi + 1 then 343 Issue_Msg (Prev_Hi + 1, Lo - 1); 344 end if; 345 346 if Hi > Prev_Hi then 347 Prev_Hi := Hi; 348 end if; 349 end loop; 350 351 if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then 352 Issue_Msg (Hi + 1, Bounds_Hi); 353 354 if Expr_Value (Bounds_Hi) > Hi + 1 then 355 Explain_Non_Static_Bound; 356 end if; 357 end if; 358 end Check_Choices; 359 360 ------------------ 361 -- Choice_Image -- 362 ------------------ 363 364 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is 365 Rtp : constant Entity_Id := Root_Type (Ctype); 366 Lit : Entity_Id; 367 C : Int; 368 369 begin 370 -- For character, or wide [wide] character. If 7-bit ASCII graphic 371 -- range, then build and return appropriate character literal name 372 373 if Is_Standard_Character_Type (Ctype) then 374 C := UI_To_Int (Value); 375 376 if C in 16#20# .. 16#7E# then 377 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 378 return Name_Find; 379 end if; 380 381 -- For user defined enumeration type, find enum/char literal 382 383 else 384 Lit := First_Literal (Rtp); 385 386 for J in 1 .. UI_To_Int (Value) loop 387 Next_Literal (Lit); 388 end loop; 389 390 -- If enumeration literal, just return its value 391 392 if Nkind (Lit) = N_Defining_Identifier then 393 return Chars (Lit); 394 395 -- For character literal, get the name and use it if it is 396 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. 397 398 else 399 Get_Decoded_Name_String (Chars (Lit)); 400 401 if Name_Len = 3 402 and then Name_Buffer (2) in 403 Character'Val (16#20#) .. Character'Val (16#7E#) 404 then 405 return Chars (Lit); 406 end if; 407 end if; 408 end if; 409 410 -- If we fall through, we have a character literal which is not in 411 -- the 7-bit ASCII graphic set. For such cases, we construct the 412 -- name "type'val(nnn)" where type is the choice type, and nnn is 413 -- the pos value passed as an argument to Choice_Image. 414 415 Get_Name_String (Chars (First_Subtype (Ctype))); 416 417 Add_Str_To_Name_Buffer ("'val("); 418 UI_Image (Value); 419 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); 420 Add_Char_To_Name_Buffer (')'); 421 return Name_Find; 422 end Choice_Image; 423 424 -------------------------- 425 -- Expand_Others_Choice -- 426 -------------------------- 427 428 procedure Expand_Others_Choice 429 (Case_Table : Choice_Table_Type; 430 Others_Choice : Node_Id; 431 Choice_Type : Entity_Id) 432 is 433 Loc : constant Source_Ptr := Sloc (Others_Choice); 434 Choice_List : constant List_Id := New_List; 435 Choice : Node_Id; 436 Exp_Lo : Node_Id; 437 Exp_Hi : Node_Id; 438 Hi : Uint; 439 Lo : Uint; 440 Previous_Hi : Uint; 441 442 function Build_Choice (Value1, Value2 : Uint) return Node_Id; 443 -- Builds a node representing the missing choices given by the 444 -- Value1 and Value2. A N_Range node is built if there is more than 445 -- one literal value missing. Otherwise a single N_Integer_Literal, 446 -- N_Identifier or N_Character_Literal is built depending on what 447 -- Choice_Type is. 448 449 function Lit_Of (Value : Uint) return Node_Id; 450 -- Returns the Node_Id for the enumeration literal corresponding to the 451 -- position given by Value within the enumeration type Choice_Type. 452 453 ------------------ 454 -- Build_Choice -- 455 ------------------ 456 457 function Build_Choice (Value1, Value2 : Uint) return Node_Id is 458 Lit_Node : Node_Id; 459 Lo, Hi : Node_Id; 460 461 begin 462 -- If there is only one choice value missing between Value1 and 463 -- Value2, build an integer or enumeration literal to represent it. 464 465 if (Value2 - Value1) = 0 then 466 if Is_Integer_Type (Choice_Type) then 467 Lit_Node := Make_Integer_Literal (Loc, Value1); 468 Set_Etype (Lit_Node, Choice_Type); 469 else 470 Lit_Node := Lit_Of (Value1); 471 end if; 472 473 -- Otherwise is more that one choice value that is missing between 474 -- Value1 and Value2, therefore build a N_Range node of either 475 -- integer or enumeration literals. 476 477 else 478 if Is_Integer_Type (Choice_Type) then 479 Lo := Make_Integer_Literal (Loc, Value1); 480 Set_Etype (Lo, Choice_Type); 481 Hi := Make_Integer_Literal (Loc, Value2); 482 Set_Etype (Hi, Choice_Type); 483 Lit_Node := 484 Make_Range (Loc, 485 Low_Bound => Lo, 486 High_Bound => Hi); 487 488 else 489 Lit_Node := 490 Make_Range (Loc, 491 Low_Bound => Lit_Of (Value1), 492 High_Bound => Lit_Of (Value2)); 493 end if; 494 end if; 495 496 return Lit_Node; 497 end Build_Choice; 498 499 ------------ 500 -- Lit_Of -- 501 ------------ 502 503 function Lit_Of (Value : Uint) return Node_Id is 504 Lit : Entity_Id; 505 506 begin 507 -- In the case where the literal is of type Character, there needs 508 -- to be some special handling since there is no explicit chain 509 -- of literals to search. Instead, a N_Character_Literal node 510 -- is created with the appropriate Char_Code and Chars fields. 511 512 if Is_Standard_Character_Type (Choice_Type) then 513 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); 514 Lit := New_Node (N_Character_Literal, Loc); 515 Set_Chars (Lit, Name_Find); 516 Set_Char_Literal_Value (Lit, Value); 517 Set_Etype (Lit, Choice_Type); 518 Set_Is_Static_Expression (Lit, True); 519 return Lit; 520 521 -- Otherwise, iterate through the literals list of Choice_Type 522 -- "Value" number of times until the desired literal is reached 523 -- and then return an occurrence of it. 524 525 else 526 Lit := First_Literal (Choice_Type); 527 for J in 1 .. UI_To_Int (Value) loop 528 Next_Literal (Lit); 529 end loop; 530 531 return New_Occurrence_Of (Lit, Loc); 532 end if; 533 end Lit_Of; 534 535 -- Start of processing for Expand_Others_Choice 536 537 begin 538 if Case_Table'Last = 0 then 539 540 -- Special case: only an others case is present. The others case 541 -- covers the full range of the type. 542 543 if Is_Static_Subtype (Choice_Type) then 544 Choice := New_Occurrence_Of (Choice_Type, Loc); 545 else 546 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); 547 end if; 548 549 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); 550 return; 551 end if; 552 553 -- Establish the bound values for the choice depending upon whether the 554 -- type of the case statement is static or not. 555 556 if Is_OK_Static_Subtype (Choice_Type) then 557 Exp_Lo := Type_Low_Bound (Choice_Type); 558 Exp_Hi := Type_High_Bound (Choice_Type); 559 else 560 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); 561 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); 562 end if; 563 564 Lo := Expr_Value (Case_Table (1).Lo); 565 Hi := Expr_Value (Case_Table (1).Hi); 566 Previous_Hi := Expr_Value (Case_Table (1).Hi); 567 568 -- Build the node for any missing choices that are smaller than any 569 -- explicit choices given in the case. 570 571 if Expr_Value (Exp_Lo) < Lo then 572 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); 573 end if; 574 575 -- Build the nodes representing any missing choices that lie between 576 -- the explicit ones given in the case. 577 578 for J in 2 .. Case_Table'Last loop 579 Lo := Expr_Value (Case_Table (J).Lo); 580 Hi := Expr_Value (Case_Table (J).Hi); 581 582 if Lo /= (Previous_Hi + 1) then 583 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); 584 end if; 585 586 Previous_Hi := Hi; 587 end loop; 588 589 -- Build the node for any missing choices that are greater than any 590 -- explicit choices given in the case. 591 592 if Expr_Value (Exp_Hi) > Hi then 593 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); 594 end if; 595 596 Set_Others_Discrete_Choices (Others_Choice, Choice_List); 597 598 -- Warn on null others list if warning option set 599 600 if Warn_On_Redundant_Constructs 601 and then Comes_From_Source (Others_Choice) 602 and then Is_Empty_List (Choice_List) 603 then 604 Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice); 605 Error_Msg_N ("\?r?previous choices cover all values", Others_Choice); 606 end if; 607 end Expand_Others_Choice; 608 609 ----------- 610 -- No_OP -- 611 ----------- 612 613 procedure No_OP (C : Node_Id) is 614 pragma Warnings (Off, C); 615 begin 616 null; 617 end No_OP; 618 619 -------------------------------- 620 -- Generic_Choices_Processing -- 621 -------------------------------- 622 623 package body Generic_Choices_Processing is 624 625 -- The following type is used to gather the entries for the choice 626 -- table, so that we can then allocate the right length. 627 628 type Link; 629 type Link_Ptr is access all Link; 630 631 type Link is record 632 Val : Choice_Bounds; 633 Nxt : Link_Ptr; 634 end record; 635 636 procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); 637 638 --------------------- 639 -- Analyze_Choices -- 640 --------------------- 641 642 procedure Analyze_Choices 643 (N : Node_Id; 644 Subtyp : Entity_Id; 645 Raises_CE : out Boolean; 646 Others_Present : out Boolean) 647 is 648 E : Entity_Id; 649 650 Enode : Node_Id; 651 -- This is where we post error messages for bounds out of range 652 653 Choice_List : Link_Ptr := null; 654 -- Gather list of choices 655 656 Num_Choices : Nat := 0; 657 -- Number of entries in Choice_List 658 659 Choice_Type : constant Entity_Id := Base_Type (Subtyp); 660 -- The actual type against which the discrete choices are resolved. 661 -- Note that this type is always the base type not the subtype of the 662 -- ruling expression, index or discriminant. 663 664 Bounds_Type : Entity_Id; 665 -- The type from which are derived the bounds of the values covered 666 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice 667 -- specifies a value outside of these bounds we have an error. 668 669 Bounds_Lo : Uint; 670 Bounds_Hi : Uint; 671 -- The actual bounds of the above type 672 673 Expected_Type : Entity_Id; 674 -- The expected type of each choice. Equal to Choice_Type, except if 675 -- the expression is universal, in which case the choices can be of 676 -- any integer type. 677 678 Alt : Node_Id; 679 -- A case statement alternative or a variant in a record type 680 -- declaration. 681 682 Choice : Node_Id; 683 Kind : Node_Kind; 684 -- The node kind of the current Choice 685 686 Delete_Choice : Boolean; 687 -- Set to True to delete the current choice 688 689 Others_Choice : Node_Id := Empty; 690 -- Remember others choice if it is present (empty otherwise) 691 692 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); 693 -- Checks the validity of the bounds of a choice. When the bounds 694 -- are static and no error occurred the bounds are collected for 695 -- later entry into the choices table so that they can be sorted 696 -- later on. 697 698 ----------- 699 -- Check -- 700 ----------- 701 702 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is 703 Lo_Val : Uint; 704 Hi_Val : Uint; 705 706 begin 707 -- First check if an error was already detected on either bounds 708 709 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then 710 return; 711 712 -- Do not insert non static choices in the table to be sorted 713 714 elsif not Is_Static_Expression (Lo) 715 or else 716 not Is_Static_Expression (Hi) 717 then 718 Process_Non_Static_Choice (Choice); 719 return; 720 721 -- Ignore range which raise constraint error 722 723 elsif Raises_Constraint_Error (Lo) 724 or else Raises_Constraint_Error (Hi) 725 then 726 Raises_CE := True; 727 return; 728 729 -- AI05-0188 : Within an instance the non-others choices do not 730 -- have to belong to the actual subtype. 731 732 elsif Ada_Version >= Ada_2012 and then In_Instance then 733 return; 734 735 -- Otherwise we have an OK static choice 736 737 else 738 Lo_Val := Expr_Value (Lo); 739 Hi_Val := Expr_Value (Hi); 740 741 -- Do not insert null ranges in the choices table 742 743 if Lo_Val > Hi_Val then 744 Process_Empty_Choice (Choice); 745 return; 746 end if; 747 end if; 748 749 -- Check for low bound out of range 750 751 if Lo_Val < Bounds_Lo then 752 753 -- If the choice is an entity name, then it is a type, and we 754 -- want to post the message on the reference to this entity. 755 -- Otherwise post it on the lower bound of the range. 756 757 if Is_Entity_Name (Choice) then 758 Enode := Choice; 759 else 760 Enode := Lo; 761 end if; 762 763 -- Specialize message for integer/enum type 764 765 if Is_Integer_Type (Bounds_Type) then 766 Error_Msg_Uint_1 := Bounds_Lo; 767 Error_Msg_N ("minimum allowed choice value is^", Enode); 768 else 769 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); 770 Error_Msg_N ("minimum allowed choice value is%", Enode); 771 end if; 772 end if; 773 774 -- Check for high bound out of range 775 776 if Hi_Val > Bounds_Hi then 777 778 -- If the choice is an entity name, then it is a type, and we 779 -- want to post the message on the reference to this entity. 780 -- Otherwise post it on the upper bound of the range. 781 782 if Is_Entity_Name (Choice) then 783 Enode := Choice; 784 else 785 Enode := Hi; 786 end if; 787 788 -- Specialize message for integer/enum type 789 790 if Is_Integer_Type (Bounds_Type) then 791 Error_Msg_Uint_1 := Bounds_Hi; 792 Error_Msg_N ("maximum allowed choice value is^", Enode); 793 else 794 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); 795 Error_Msg_N ("maximum allowed choice value is%", Enode); 796 end if; 797 end if; 798 799 -- Collect bounds in the list 800 801 -- Note: we still store the bounds, even if they are out of range, 802 -- since this may prevent unnecessary cascaded errors for values 803 -- that are covered by such an excessive range. 804 805 Choice_List := 806 new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); 807 Num_Choices := Num_Choices + 1; 808 end Check; 809 810 -- Start of processing for Analyze_Choices 811 812 begin 813 Raises_CE := False; 814 Others_Present := False; 815 816 -- If Subtyp is not a static subtype Ada 95 requires then we use the 817 -- bounds of its base type to determine the values covered by the 818 -- discrete choices. 819 820 -- In Ada 2012, if the subtype has a non-static predicate the full 821 -- range of the base type must be covered as well. 822 823 if Is_OK_Static_Subtype (Subtyp) then 824 if not Has_Predicates (Subtyp) 825 or else Present (Static_Predicate (Subtyp)) 826 then 827 Bounds_Type := Subtyp; 828 else 829 Bounds_Type := Choice_Type; 830 end if; 831 832 else 833 Bounds_Type := Choice_Type; 834 end if; 835 836 -- Obtain static bounds of type, unless this is a generic formal 837 -- discrete type for which all choices will be non-static. 838 839 if not Is_Generic_Type (Root_Type (Bounds_Type)) 840 or else Ekind (Bounds_Type) /= E_Enumeration_Type 841 then 842 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); 843 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); 844 end if; 845 846 if Choice_Type = Universal_Integer then 847 Expected_Type := Any_Integer; 848 else 849 Expected_Type := Choice_Type; 850 end if; 851 852 -- Now loop through the case alternatives or record variants 853 854 Alt := First (Get_Alternatives (N)); 855 while Present (Alt) loop 856 857 -- If pragma, just analyze it 858 859 if Nkind (Alt) = N_Pragma then 860 Analyze (Alt); 861 862 -- Otherwise check each choice against its base type 863 864 else 865 Choice := First (Get_Choices (Alt)); 866 while Present (Choice) loop 867 Delete_Choice := False; 868 Analyze (Choice); 869 Kind := Nkind (Choice); 870 871 -- Choice is a Range 872 873 if Kind = N_Range 874 or else (Kind = N_Attribute_Reference 875 and then Attribute_Name (Choice) = Name_Range) 876 then 877 Resolve (Choice, Expected_Type); 878 Check (Choice, Low_Bound (Choice), High_Bound (Choice)); 879 880 -- Choice is a subtype name 881 882 elsif Is_Entity_Name (Choice) 883 and then Is_Type (Entity (Choice)) 884 then 885 if not Covers (Expected_Type, Etype (Choice)) then 886 Wrong_Type (Choice, Choice_Type); 887 888 else 889 E := Entity (Choice); 890 891 -- Case of predicated subtype 892 893 if Has_Predicates (E) then 894 895 -- Use of non-static predicate is an error 896 897 if not Is_Discrete_Type (E) 898 or else No (Static_Predicate (E)) 899 then 900 Bad_Predicated_Subtype_Use 901 ("cannot use subtype& with non-static " 902 & "predicate as case alternative", Choice, E); 903 904 -- Static predicate case 905 906 else 907 declare 908 Copy : constant List_Id := Empty_List; 909 P : Node_Id; 910 C : Node_Id; 911 912 begin 913 -- Loop through entries in predicate list, 914 -- converting to choices. Note that if the 915 -- list is empty, corresponding to a False 916 -- predicate, then no choices are inserted. 917 918 P := First (Static_Predicate (E)); 919 while Present (P) loop 920 C := New_Copy (P); 921 Set_Sloc (C, Sloc (Choice)); 922 Append_To (Copy, C); 923 Next (P); 924 end loop; 925 926 Insert_List_After (Choice, Copy); 927 Delete_Choice := True; 928 end; 929 end if; 930 931 -- Not predicated subtype case 932 933 elsif not Is_Static_Subtype (E) then 934 Process_Non_Static_Choice (Choice); 935 else 936 Check 937 (Choice, Type_Low_Bound (E), Type_High_Bound (E)); 938 end if; 939 end if; 940 941 -- Choice is a subtype indication 942 943 elsif Kind = N_Subtype_Indication then 944 Resolve_Discrete_Subtype_Indication 945 (Choice, Expected_Type); 946 947 -- Here for other than predicated subtype case 948 949 if Etype (Choice) /= Any_Type then 950 declare 951 C : constant Node_Id := Constraint (Choice); 952 R : constant Node_Id := Range_Expression (C); 953 L : constant Node_Id := Low_Bound (R); 954 H : constant Node_Id := High_Bound (R); 955 956 begin 957 E := Entity (Subtype_Mark (Choice)); 958 959 if not Is_Static_Subtype (E) then 960 Process_Non_Static_Choice (Choice); 961 962 else 963 if Is_OK_Static_Expression (L) 964 and then Is_OK_Static_Expression (H) 965 then 966 if Expr_Value (L) > Expr_Value (H) then 967 Process_Empty_Choice (Choice); 968 else 969 if Is_Out_Of_Range (L, E) then 970 Apply_Compile_Time_Constraint_Error 971 (L, "static value out of range", 972 CE_Range_Check_Failed); 973 end if; 974 975 if Is_Out_Of_Range (H, E) then 976 Apply_Compile_Time_Constraint_Error 977 (H, "static value out of range", 978 CE_Range_Check_Failed); 979 end if; 980 end if; 981 end if; 982 983 Check (Choice, L, H); 984 end if; 985 end; 986 end if; 987 988 -- The others choice is only allowed for the last 989 -- alternative and as its only choice. 990 991 elsif Kind = N_Others_Choice then 992 if not (Choice = First (Get_Choices (Alt)) 993 and then Choice = Last (Get_Choices (Alt)) 994 and then Alt = Last (Get_Alternatives (N))) 995 then 996 Error_Msg_N 997 ("the choice OTHERS must appear alone and last", 998 Choice); 999 return; 1000 end if; 1001 1002 Others_Present := True; 1003 Others_Choice := Choice; 1004 1005 -- Only other possibility is an expression 1006 1007 else 1008 Resolve (Choice, Expected_Type); 1009 Check (Choice, Choice, Choice); 1010 end if; 1011 1012 -- Move to next choice, deleting the current one if the 1013 -- flag requesting this deletion is set True. 1014 1015 declare 1016 C : constant Node_Id := Choice; 1017 begin 1018 Next (Choice); 1019 1020 if Delete_Choice then 1021 Remove (C); 1022 end if; 1023 end; 1024 end loop; 1025 1026 Process_Associated_Node (Alt); 1027 end if; 1028 1029 Next (Alt); 1030 end loop; 1031 1032 -- Now we can create the Choice_Table, since we know how long 1033 -- it needs to be so we can allocate exactly the right length. 1034 1035 declare 1036 Choice_Table : Choice_Table_Type (0 .. Num_Choices); 1037 1038 begin 1039 -- Now copy the items we collected in the linked list into this 1040 -- newly allocated table (leave entry 0 unused for sorting). 1041 1042 declare 1043 T : Link_Ptr; 1044 begin 1045 for J in 1 .. Num_Choices loop 1046 T := Choice_List; 1047 Choice_List := T.Nxt; 1048 Choice_Table (J) := T.Val; 1049 Free (T); 1050 end loop; 1051 end; 1052 1053 Check_Choices 1054 (Choice_Table, 1055 Bounds_Type, 1056 Subtyp, 1057 Others_Present or else (Choice_Type = Universal_Integer), 1058 N); 1059 1060 -- If no others choice we are all done, otherwise we have one more 1061 -- step, which is to set the Others_Discrete_Choices field of the 1062 -- others choice (to contain all otherwise unspecified choices). 1063 -- Skip this if CE is known to be raised. 1064 1065 if Others_Present and not Raises_CE then 1066 Expand_Others_Choice 1067 (Case_Table => Choice_Table, 1068 Others_Choice => Others_Choice, 1069 Choice_Type => Bounds_Type); 1070 end if; 1071 end; 1072 end Analyze_Choices; 1073 1074 end Generic_Choices_Processing; 1075 1076end Sem_Case; 1077