1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 5 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Expander; use Expander; 32with Exp_Ch6; use Exp_Ch6; 33with Exp_Util; use Exp_Util; 34with Freeze; use Freeze; 35with Lib; use Lib; 36with Lib.Xref; use Lib.Xref; 37with Namet; use Namet; 38with Nlists; use Nlists; 39with Nmake; use Nmake; 40with Opt; use Opt; 41with Restrict; use Restrict; 42with Rident; use Rident; 43with Rtsfind; use Rtsfind; 44with Sem; use Sem; 45with Sem_Aux; use Sem_Aux; 46with Sem_Case; use Sem_Case; 47with Sem_Ch3; use Sem_Ch3; 48with Sem_Ch6; use Sem_Ch6; 49with Sem_Ch8; use Sem_Ch8; 50with Sem_Dim; use Sem_Dim; 51with Sem_Disp; use Sem_Disp; 52with Sem_Elab; use Sem_Elab; 53with Sem_Eval; use Sem_Eval; 54with Sem_Res; use Sem_Res; 55with Sem_Type; use Sem_Type; 56with Sem_Util; use Sem_Util; 57with Sem_Warn; use Sem_Warn; 58with Snames; use Snames; 59with Stand; use Stand; 60with Sinfo; use Sinfo; 61with Targparm; use Targparm; 62with Tbuild; use Tbuild; 63with Uintp; use Uintp; 64 65package body Sem_Ch5 is 66 67 Unblocked_Exit_Count : Nat := 0; 68 -- This variable is used when processing if statements, case statements, 69 -- and block statements. It counts the number of exit points that are not 70 -- blocked by unconditional transfer instructions: for IF and CASE, these 71 -- are the branches of the conditional; for a block, they are the statement 72 -- sequence of the block, and the statement sequences of any exception 73 -- handlers that are part of the block. When processing is complete, if 74 -- this count is zero, it means that control cannot fall through the IF, 75 -- CASE or block statement. This is used for the generation of warning 76 -- messages. This variable is recursively saved on entry to processing the 77 -- construct, and restored on exit. 78 79 procedure Preanalyze_Range (R_Copy : Node_Id); 80 -- Determine expected type of range or domain of iteration of Ada 2012 81 -- loop by analyzing separate copy. Do the analysis and resolution of the 82 -- copy of the bound(s) with expansion disabled, to prevent the generation 83 -- of finalization actions. This prevents memory leaks when the bounds 84 -- contain calls to functions returning controlled arrays or when the 85 -- domain of iteration is a container. 86 87 ------------------------ 88 -- Analyze_Assignment -- 89 ------------------------ 90 91 procedure Analyze_Assignment (N : Node_Id) is 92 Lhs : constant Node_Id := Name (N); 93 Rhs : constant Node_Id := Expression (N); 94 T1 : Entity_Id; 95 T2 : Entity_Id; 96 Decl : Node_Id; 97 98 procedure Diagnose_Non_Variable_Lhs (N : Node_Id); 99 -- N is the node for the left hand side of an assignment, and it is not 100 -- a variable. This routine issues an appropriate diagnostic. 101 102 procedure Kill_Lhs; 103 -- This is called to kill current value settings of a simple variable 104 -- on the left hand side. We call it if we find any error in analyzing 105 -- the assignment, and at the end of processing before setting any new 106 -- current values in place. 107 108 procedure Set_Assignment_Type 109 (Opnd : Node_Id; 110 Opnd_Type : in out Entity_Id); 111 -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the 112 -- nominal subtype. This procedure is used to deal with cases where the 113 -- nominal subtype must be replaced by the actual subtype. 114 115 ------------------------------- 116 -- Diagnose_Non_Variable_Lhs -- 117 ------------------------------- 118 119 procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is 120 begin 121 -- Not worth posting another error if left hand side already flagged 122 -- as being illegal in some respect. 123 124 if Error_Posted (N) then 125 return; 126 127 -- Some special bad cases of entity names 128 129 elsif Is_Entity_Name (N) then 130 declare 131 Ent : constant Entity_Id := Entity (N); 132 133 begin 134 if Ekind (Ent) = E_In_Parameter then 135 Error_Msg_N 136 ("assignment to IN mode parameter not allowed", N); 137 138 -- Renamings of protected private components are turned into 139 -- constants when compiling a protected function. In the case 140 -- of single protected types, the private component appears 141 -- directly. 142 143 elsif (Is_Prival (Ent) 144 and then 145 (Ekind (Current_Scope) = E_Function 146 or else Ekind (Enclosing_Dynamic_Scope 147 (Current_Scope)) = E_Function)) 148 or else 149 (Ekind (Ent) = E_Component 150 and then Is_Protected_Type (Scope (Ent))) 151 then 152 Error_Msg_N 153 ("protected function cannot modify protected object", N); 154 155 elsif Ekind (Ent) = E_Loop_Parameter then 156 Error_Msg_N 157 ("assignment to loop parameter not allowed", N); 158 159 else 160 Error_Msg_N 161 ("left hand side of assignment must be a variable", N); 162 end if; 163 end; 164 165 -- For indexed components or selected components, test prefix 166 167 elsif Nkind (N) = N_Indexed_Component then 168 Diagnose_Non_Variable_Lhs (Prefix (N)); 169 170 -- Another special case for assignment to discriminant 171 172 elsif Nkind (N) = N_Selected_Component then 173 if Present (Entity (Selector_Name (N))) 174 and then Ekind (Entity (Selector_Name (N))) = E_Discriminant 175 then 176 Error_Msg_N 177 ("assignment to discriminant not allowed", N); 178 else 179 Diagnose_Non_Variable_Lhs (Prefix (N)); 180 end if; 181 182 else 183 -- If we fall through, we have no special message to issue! 184 185 Error_Msg_N ("left hand side of assignment must be a variable", N); 186 end if; 187 end Diagnose_Non_Variable_Lhs; 188 189 -------------- 190 -- Kill_LHS -- 191 -------------- 192 193 procedure Kill_Lhs is 194 begin 195 if Is_Entity_Name (Lhs) then 196 declare 197 Ent : constant Entity_Id := Entity (Lhs); 198 begin 199 if Present (Ent) then 200 Kill_Current_Values (Ent); 201 end if; 202 end; 203 end if; 204 end Kill_Lhs; 205 206 ------------------------- 207 -- Set_Assignment_Type -- 208 ------------------------- 209 210 procedure Set_Assignment_Type 211 (Opnd : Node_Id; 212 Opnd_Type : in out Entity_Id) 213 is 214 begin 215 Require_Entity (Opnd); 216 217 -- If the assignment operand is an in-out or out parameter, then we 218 -- get the actual subtype (needed for the unconstrained case). If the 219 -- operand is the actual in an entry declaration, then within the 220 -- accept statement it is replaced with a local renaming, which may 221 -- also have an actual subtype. 222 223 if Is_Entity_Name (Opnd) 224 and then (Ekind (Entity (Opnd)) = E_Out_Parameter 225 or else Ekind (Entity (Opnd)) = 226 E_In_Out_Parameter 227 or else Ekind (Entity (Opnd)) = 228 E_Generic_In_Out_Parameter 229 or else 230 (Ekind (Entity (Opnd)) = E_Variable 231 and then Nkind (Parent (Entity (Opnd))) = 232 N_Object_Renaming_Declaration 233 and then Nkind (Parent (Parent (Entity (Opnd)))) = 234 N_Accept_Statement)) 235 then 236 Opnd_Type := Get_Actual_Subtype (Opnd); 237 238 -- If assignment operand is a component reference, then we get the 239 -- actual subtype of the component for the unconstrained case. 240 241 elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference) 242 and then not Is_Unchecked_Union (Opnd_Type) 243 then 244 Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); 245 246 if Present (Decl) then 247 Insert_Action (N, Decl); 248 Mark_Rewrite_Insertion (Decl); 249 Analyze (Decl); 250 Opnd_Type := Defining_Identifier (Decl); 251 Set_Etype (Opnd, Opnd_Type); 252 Freeze_Itype (Opnd_Type, N); 253 254 elsif Is_Constrained (Etype (Opnd)) then 255 Opnd_Type := Etype (Opnd); 256 end if; 257 258 -- For slice, use the constrained subtype created for the slice 259 260 elsif Nkind (Opnd) = N_Slice then 261 Opnd_Type := Etype (Opnd); 262 end if; 263 end Set_Assignment_Type; 264 265 -- Start of processing for Analyze_Assignment 266 267 begin 268 Mark_Coextensions (N, Rhs); 269 270 Analyze (Rhs); 271 Analyze (Lhs); 272 273 -- Ensure that we never do an assignment on a variable marked as 274 -- as Safe_To_Reevaluate. 275 276 pragma Assert (not Is_Entity_Name (Lhs) 277 or else Ekind (Entity (Lhs)) /= E_Variable 278 or else not Is_Safe_To_Reevaluate (Entity (Lhs))); 279 280 -- Start type analysis for assignment 281 282 T1 := Etype (Lhs); 283 284 -- In the most general case, both Lhs and Rhs can be overloaded, and we 285 -- must compute the intersection of the possible types on each side. 286 287 if Is_Overloaded (Lhs) then 288 declare 289 I : Interp_Index; 290 It : Interp; 291 292 begin 293 T1 := Any_Type; 294 Get_First_Interp (Lhs, I, It); 295 296 while Present (It.Typ) loop 297 if Has_Compatible_Type (Rhs, It.Typ) then 298 if T1 /= Any_Type then 299 300 -- An explicit dereference is overloaded if the prefix 301 -- is. Try to remove the ambiguity on the prefix, the 302 -- error will be posted there if the ambiguity is real. 303 304 if Nkind (Lhs) = N_Explicit_Dereference then 305 declare 306 PI : Interp_Index; 307 PI1 : Interp_Index := 0; 308 PIt : Interp; 309 Found : Boolean; 310 311 begin 312 Found := False; 313 Get_First_Interp (Prefix (Lhs), PI, PIt); 314 315 while Present (PIt.Typ) loop 316 if Is_Access_Type (PIt.Typ) 317 and then Has_Compatible_Type 318 (Rhs, Designated_Type (PIt.Typ)) 319 then 320 if Found then 321 PIt := 322 Disambiguate (Prefix (Lhs), 323 PI1, PI, Any_Type); 324 325 if PIt = No_Interp then 326 Error_Msg_N 327 ("ambiguous left-hand side" 328 & " in assignment", Lhs); 329 exit; 330 else 331 Resolve (Prefix (Lhs), PIt.Typ); 332 end if; 333 334 exit; 335 else 336 Found := True; 337 PI1 := PI; 338 end if; 339 end if; 340 341 Get_Next_Interp (PI, PIt); 342 end loop; 343 end; 344 345 else 346 Error_Msg_N 347 ("ambiguous left-hand side in assignment", Lhs); 348 exit; 349 end if; 350 else 351 T1 := It.Typ; 352 end if; 353 end if; 354 355 Get_Next_Interp (I, It); 356 end loop; 357 end; 358 359 if T1 = Any_Type then 360 Error_Msg_N 361 ("no valid types for left-hand side for assignment", Lhs); 362 Kill_Lhs; 363 return; 364 end if; 365 end if; 366 367 -- The resulting assignment type is T1, so now we will resolve the left 368 -- hand side of the assignment using this determined type. 369 370 Resolve (Lhs, T1); 371 372 -- Cases where Lhs is not a variable 373 374 if not Is_Variable (Lhs) then 375 376 -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a 377 -- protected object. 378 379 declare 380 Ent : Entity_Id; 381 S : Entity_Id; 382 383 begin 384 if Ada_Version >= Ada_2005 then 385 386 -- Handle chains of renamings 387 388 Ent := Lhs; 389 while Nkind (Ent) in N_Has_Entity 390 and then Present (Entity (Ent)) 391 and then Present (Renamed_Object (Entity (Ent))) 392 loop 393 Ent := Renamed_Object (Entity (Ent)); 394 end loop; 395 396 if (Nkind (Ent) = N_Attribute_Reference 397 and then Attribute_Name (Ent) = Name_Priority) 398 399 -- Renamings of the attribute Priority applied to protected 400 -- objects have been previously expanded into calls to the 401 -- Get_Ceiling run-time subprogram. 402 403 or else 404 (Nkind (Ent) = N_Function_Call 405 and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) 406 or else 407 Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) 408 then 409 -- The enclosing subprogram cannot be a protected function 410 411 S := Current_Scope; 412 while not (Is_Subprogram (S) 413 and then Convention (S) = Convention_Protected) 414 and then S /= Standard_Standard 415 loop 416 S := Scope (S); 417 end loop; 418 419 if Ekind (S) = E_Function 420 and then Convention (S) = Convention_Protected 421 then 422 Error_Msg_N 423 ("protected function cannot modify protected object", 424 Lhs); 425 end if; 426 427 -- Changes of the ceiling priority of the protected object 428 -- are only effective if the Ceiling_Locking policy is in 429 -- effect (AARM D.5.2 (5/2)). 430 431 if Locking_Policy /= 'C' then 432 Error_Msg_N ("assignment to the attribute PRIORITY has " & 433 "no effect??", Lhs); 434 Error_Msg_N ("\since no Locking_Policy has been " & 435 "specified??", Lhs); 436 end if; 437 438 return; 439 end if; 440 end if; 441 end; 442 443 Diagnose_Non_Variable_Lhs (Lhs); 444 return; 445 446 -- Error of assigning to limited type. We do however allow this in 447 -- certain cases where the front end generates the assignments. 448 449 elsif Is_Limited_Type (T1) 450 and then not Assignment_OK (Lhs) 451 and then not Assignment_OK (Original_Node (Lhs)) 452 and then not Is_Value_Type (T1) 453 then 454 -- CPP constructors can only be called in declarations 455 456 if Is_CPP_Constructor_Call (Rhs) then 457 Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs); 458 else 459 Error_Msg_N 460 ("left hand of assignment must not be limited type", Lhs); 461 Explain_Limited_Type (T1, Lhs); 462 end if; 463 return; 464 465 -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be 466 -- abstract. This is only checked when the assignment Comes_From_Source, 467 -- because in some cases the expander generates such assignments (such 468 -- in the _assign operation for an abstract type). 469 470 elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then 471 Error_Msg_N 472 ("target of assignment operation must not be abstract", Lhs); 473 end if; 474 475 -- Resolution may have updated the subtype, in case the left-hand side 476 -- is a private protected component. Use the correct subtype to avoid 477 -- scoping issues in the back-end. 478 479 T1 := Etype (Lhs); 480 481 -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete 482 -- type. For example: 483 484 -- limited with P; 485 -- package Pkg is 486 -- type Acc is access P.T; 487 -- end Pkg; 488 489 -- with Pkg; use Acc; 490 -- procedure Example is 491 -- A, B : Acc; 492 -- begin 493 -- A.all := B.all; -- ERROR 494 -- end Example; 495 496 if Nkind (Lhs) = N_Explicit_Dereference 497 and then Ekind (T1) = E_Incomplete_Type 498 then 499 Error_Msg_N ("invalid use of incomplete type", Lhs); 500 Kill_Lhs; 501 return; 502 end if; 503 504 -- Now we can complete the resolution of the right hand side 505 506 Set_Assignment_Type (Lhs, T1); 507 Resolve (Rhs, T1); 508 509 -- This is the point at which we check for an unset reference 510 511 Check_Unset_Reference (Rhs); 512 Check_Unprotected_Access (Lhs, Rhs); 513 514 -- Remaining steps are skipped if Rhs was syntactically in error 515 516 if Rhs = Error then 517 Kill_Lhs; 518 return; 519 end if; 520 521 T2 := Etype (Rhs); 522 523 if not Covers (T1, T2) then 524 Wrong_Type (Rhs, Etype (Lhs)); 525 Kill_Lhs; 526 return; 527 end if; 528 529 -- Ada 2005 (AI-326): In case of explicit dereference of incomplete 530 -- types, use the non-limited view if available 531 532 if Nkind (Rhs) = N_Explicit_Dereference 533 and then Ekind (T2) = E_Incomplete_Type 534 and then Is_Tagged_Type (T2) 535 and then Present (Non_Limited_View (T2)) 536 then 537 T2 := Non_Limited_View (T2); 538 end if; 539 540 Set_Assignment_Type (Rhs, T2); 541 542 if Total_Errors_Detected /= 0 then 543 if No (T1) then 544 T1 := Any_Type; 545 end if; 546 547 if No (T2) then 548 T2 := Any_Type; 549 end if; 550 end if; 551 552 if T1 = Any_Type or else T2 = Any_Type then 553 Kill_Lhs; 554 return; 555 end if; 556 557 -- If the rhs is class-wide or dynamically tagged, then require the lhs 558 -- to be class-wide. The case where the rhs is a dynamically tagged call 559 -- to a dispatching operation with a controlling access result is 560 -- excluded from this check, since the target has an access type (and 561 -- no tag propagation occurs in that case). 562 563 if (Is_Class_Wide_Type (T2) 564 or else (Is_Dynamically_Tagged (Rhs) 565 and then not Is_Access_Type (T1))) 566 and then not Is_Class_Wide_Type (T1) 567 then 568 Error_Msg_N ("dynamically tagged expression not allowed!", Rhs); 569 570 elsif Is_Class_Wide_Type (T1) 571 and then not Is_Class_Wide_Type (T2) 572 and then not Is_Tag_Indeterminate (Rhs) 573 and then not Is_Dynamically_Tagged (Rhs) 574 then 575 Error_Msg_N ("dynamically tagged expression required!", Rhs); 576 end if; 577 578 -- Propagate the tag from a class-wide target to the rhs when the rhs 579 -- is a tag-indeterminate call. 580 581 if Is_Tag_Indeterminate (Rhs) then 582 if Is_Class_Wide_Type (T1) then 583 Propagate_Tag (Lhs, Rhs); 584 585 elsif Nkind (Rhs) = N_Function_Call 586 and then Is_Entity_Name (Name (Rhs)) 587 and then Is_Abstract_Subprogram (Entity (Name (Rhs))) 588 then 589 Error_Msg_N 590 ("call to abstract function must be dispatching", Name (Rhs)); 591 592 elsif Nkind (Rhs) = N_Qualified_Expression 593 and then Nkind (Expression (Rhs)) = N_Function_Call 594 and then Is_Entity_Name (Name (Expression (Rhs))) 595 and then 596 Is_Abstract_Subprogram (Entity (Name (Expression (Rhs)))) 597 then 598 Error_Msg_N 599 ("call to abstract function must be dispatching", 600 Name (Expression (Rhs))); 601 end if; 602 end if; 603 604 -- Ada 2005 (AI-385): When the lhs type is an anonymous access type, 605 -- apply an implicit conversion of the rhs to that type to force 606 -- appropriate static and run-time accessibility checks. This applies 607 -- as well to anonymous access-to-subprogram types that are component 608 -- subtypes or formal parameters. 609 610 if Ada_Version >= Ada_2005 611 and then Is_Access_Type (T1) 612 then 613 if Is_Local_Anonymous_Access (T1) 614 or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type 615 616 -- Handle assignment to an Ada 2012 stand-alone object 617 -- of an anonymous access type. 618 619 or else (Ekind (T1) = E_Anonymous_Access_Type 620 and then Nkind (Associated_Node_For_Itype (T1)) = 621 N_Object_Declaration) 622 623 then 624 Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); 625 Analyze_And_Resolve (Rhs, T1); 626 end if; 627 end if; 628 629 -- Ada 2005 (AI-231): Assignment to not null variable 630 631 if Ada_Version >= Ada_2005 632 and then Can_Never_Be_Null (T1) 633 and then not Assignment_OK (Lhs) 634 then 635 -- Case where we know the right hand side is null 636 637 if Known_Null (Rhs) then 638 Apply_Compile_Time_Constraint_Error 639 (N => Rhs, 640 Msg => 641 "(Ada 2005) null not allowed in null-excluding objects??", 642 Reason => CE_Null_Not_Allowed); 643 644 -- We still mark this as a possible modification, that's necessary 645 -- to reset Is_True_Constant, and desirable for xref purposes. 646 647 Note_Possible_Modification (Lhs, Sure => True); 648 return; 649 650 -- If we know the right hand side is non-null, then we convert to the 651 -- target type, since we don't need a run time check in that case. 652 653 elsif not Can_Never_Be_Null (T2) then 654 Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); 655 Analyze_And_Resolve (Rhs, T1); 656 end if; 657 end if; 658 659 if Is_Scalar_Type (T1) then 660 Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); 661 662 -- For array types, verify that lengths match. If the right hand side 663 -- is a function call that has been inlined, the assignment has been 664 -- rewritten as a block, and the constraint check will be applied to the 665 -- assignment within the block. 666 667 elsif Is_Array_Type (T1) 668 and then 669 (Nkind (Rhs) /= N_Type_Conversion 670 or else Is_Constrained (Etype (Rhs))) 671 and then 672 (Nkind (Rhs) /= N_Function_Call 673 or else Nkind (N) /= N_Block_Statement) 674 then 675 -- Assignment verifies that the length of the Lsh and Rhs are equal, 676 -- but of course the indexes do not have to match. If the right-hand 677 -- side is a type conversion to an unconstrained type, a length check 678 -- is performed on the expression itself during expansion. In rare 679 -- cases, the redundant length check is computed on an index type 680 -- with a different representation, triggering incorrect code in the 681 -- back end. 682 683 Apply_Length_Check (Rhs, Etype (Lhs)); 684 685 else 686 -- Discriminant checks are applied in the course of expansion 687 688 null; 689 end if; 690 691 -- Note: modifications of the Lhs may only be recorded after 692 -- checks have been applied. 693 694 Note_Possible_Modification (Lhs, Sure => True); 695 696 -- ??? a real accessibility check is needed when ??? 697 698 -- Post warning for redundant assignment or variable to itself 699 700 if Warn_On_Redundant_Constructs 701 702 -- We only warn for source constructs 703 704 and then Comes_From_Source (N) 705 706 -- Where the object is the same on both sides 707 708 and then Same_Object (Lhs, Original_Node (Rhs)) 709 710 -- But exclude the case where the right side was an operation that 711 -- got rewritten (e.g. JUNK + K, where K was known to be zero). We 712 -- don't want to warn in such a case, since it is reasonable to write 713 -- such expressions especially when K is defined symbolically in some 714 -- other package. 715 716 and then Nkind (Original_Node (Rhs)) not in N_Op 717 then 718 if Nkind (Lhs) in N_Has_Entity then 719 Error_Msg_NE -- CODEFIX 720 ("?r?useless assignment of & to itself!", N, Entity (Lhs)); 721 else 722 Error_Msg_N -- CODEFIX 723 ("?r?useless assignment of object to itself!", N); 724 end if; 725 end if; 726 727 -- Check for non-allowed composite assignment 728 729 if not Support_Composite_Assign_On_Target 730 and then (Is_Array_Type (T1) or else Is_Record_Type (T1)) 731 and then (not Has_Size_Clause (T1) or else Esize (T1) > 64) 732 then 733 Error_Msg_CRT ("composite assignment", N); 734 end if; 735 736 -- Check elaboration warning for left side if not in elab code 737 738 if not In_Subprogram_Or_Concurrent_Unit then 739 Check_Elab_Assign (Lhs); 740 end if; 741 742 -- Set Referenced_As_LHS if appropriate. We only set this flag if the 743 -- assignment is a source assignment in the extended main source unit. 744 -- We are not interested in any reference information outside this 745 -- context, or in compiler generated assignment statements. 746 747 if Comes_From_Source (N) 748 and then In_Extended_Main_Source_Unit (Lhs) 749 then 750 Set_Referenced_Modified (Lhs, Out_Param => False); 751 end if; 752 753 -- Final step. If left side is an entity, then we may be able to reset 754 -- the current tracked values to new safe values. We only have something 755 -- to do if the left side is an entity name, and expansion has not 756 -- modified the node into something other than an assignment, and of 757 -- course we only capture values if it is safe to do so. 758 759 if Is_Entity_Name (Lhs) 760 and then Nkind (N) = N_Assignment_Statement 761 then 762 declare 763 Ent : constant Entity_Id := Entity (Lhs); 764 765 begin 766 if Safe_To_Capture_Value (N, Ent) then 767 768 -- If simple variable on left side, warn if this assignment 769 -- blots out another one (rendering it useless). We only do 770 -- this for source assignments, otherwise we can generate bogus 771 -- warnings when an assignment is rewritten as another 772 -- assignment, and gets tied up with itself. 773 774 if Warn_On_Modified_Unread 775 and then Is_Assignable (Ent) 776 and then Comes_From_Source (N) 777 and then In_Extended_Main_Source_Unit (Ent) 778 then 779 Warn_On_Useless_Assignment (Ent, N); 780 end if; 781 782 -- If we are assigning an access type and the left side is an 783 -- entity, then make sure that the Is_Known_[Non_]Null flags 784 -- properly reflect the state of the entity after assignment. 785 786 if Is_Access_Type (T1) then 787 if Known_Non_Null (Rhs) then 788 Set_Is_Known_Non_Null (Ent, True); 789 790 elsif Known_Null (Rhs) 791 and then not Can_Never_Be_Null (Ent) 792 then 793 Set_Is_Known_Null (Ent, True); 794 795 else 796 Set_Is_Known_Null (Ent, False); 797 798 if not Can_Never_Be_Null (Ent) then 799 Set_Is_Known_Non_Null (Ent, False); 800 end if; 801 end if; 802 803 -- For discrete types, we may be able to set the current value 804 -- if the value is known at compile time. 805 806 elsif Is_Discrete_Type (T1) 807 and then Compile_Time_Known_Value (Rhs) 808 then 809 Set_Current_Value (Ent, Rhs); 810 else 811 Set_Current_Value (Ent, Empty); 812 end if; 813 814 -- If not safe to capture values, kill them 815 816 else 817 Kill_Lhs; 818 end if; 819 end; 820 end if; 821 822 -- If assigning to an object in whole or in part, note location of 823 -- assignment in case no one references value. We only do this for 824 -- source assignments, otherwise we can generate bogus warnings when an 825 -- assignment is rewritten as another assignment, and gets tied up with 826 -- itself. 827 828 declare 829 Ent : constant Entity_Id := Get_Enclosing_Object (Lhs); 830 begin 831 if Present (Ent) 832 and then Safe_To_Capture_Value (N, Ent) 833 and then Nkind (N) = N_Assignment_Statement 834 and then Warn_On_Modified_Unread 835 and then Is_Assignable (Ent) 836 and then Comes_From_Source (N) 837 and then In_Extended_Main_Source_Unit (Ent) 838 then 839 Set_Last_Assignment (Ent, Lhs); 840 end if; 841 end; 842 843 Analyze_Dimension (N); 844 end Analyze_Assignment; 845 846 ----------------------------- 847 -- Analyze_Block_Statement -- 848 ----------------------------- 849 850 procedure Analyze_Block_Statement (N : Node_Id) is 851 procedure Install_Return_Entities (Scop : Entity_Id); 852 -- Install all entities of return statement scope Scop in the visibility 853 -- chain except for the return object since its entity is reused in a 854 -- renaming. 855 856 ----------------------------- 857 -- Install_Return_Entities -- 858 ----------------------------- 859 860 procedure Install_Return_Entities (Scop : Entity_Id) is 861 Id : Entity_Id; 862 863 begin 864 Id := First_Entity (Scop); 865 while Present (Id) loop 866 867 -- Do not install the return object 868 869 if not Ekind_In (Id, E_Constant, E_Variable) 870 or else not Is_Return_Object (Id) 871 then 872 Install_Entity (Id); 873 end if; 874 875 Next_Entity (Id); 876 end loop; 877 end Install_Return_Entities; 878 879 -- Local constants and variables 880 881 Decls : constant List_Id := Declarations (N); 882 Id : constant Node_Id := Identifier (N); 883 HSS : constant Node_Id := Handled_Statement_Sequence (N); 884 885 Is_BIP_Return_Statement : Boolean; 886 887 -- Start of processing for Analyze_Block_Statement 888 889 begin 890 -- In SPARK mode, we reject block statements. Note that the case of 891 -- block statements generated by the expander is fine. 892 893 if Nkind (Original_Node (N)) = N_Block_Statement then 894 Check_SPARK_Restriction ("block statement is not allowed", N); 895 end if; 896 897 -- If no handled statement sequence is present, things are really messed 898 -- up, and we just return immediately (defence against previous errors). 899 900 if No (HSS) then 901 Check_Error_Detected; 902 return; 903 end if; 904 905 -- Detect whether the block is actually a rewritten return statement of 906 -- a build-in-place function. 907 908 Is_BIP_Return_Statement := 909 Present (Id) 910 and then Present (Entity (Id)) 911 and then Ekind (Entity (Id)) = E_Return_Statement 912 and then Is_Build_In_Place_Function 913 (Return_Applies_To (Entity (Id))); 914 915 -- Normal processing with HSS present 916 917 declare 918 EH : constant List_Id := Exception_Handlers (HSS); 919 Ent : Entity_Id := Empty; 920 S : Entity_Id; 921 922 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; 923 -- Recursively save value of this global, will be restored on exit 924 925 begin 926 -- Initialize unblocked exit count for statements of begin block 927 -- plus one for each exception handler that is present. 928 929 Unblocked_Exit_Count := 1; 930 931 if Present (EH) then 932 Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH); 933 end if; 934 935 -- If a label is present analyze it and mark it as referenced 936 937 if Present (Id) then 938 Analyze (Id); 939 Ent := Entity (Id); 940 941 -- An error defense. If we have an identifier, but no entity, then 942 -- something is wrong. If previous errors, then just remove the 943 -- identifier and continue, otherwise raise an exception. 944 945 if No (Ent) then 946 Check_Error_Detected; 947 Set_Identifier (N, Empty); 948 949 else 950 Set_Ekind (Ent, E_Block); 951 Generate_Reference (Ent, N, ' '); 952 Generate_Definition (Ent); 953 954 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then 955 Set_Label_Construct (Parent (Ent), N); 956 end if; 957 end if; 958 end if; 959 960 -- If no entity set, create a label entity 961 962 if No (Ent) then 963 Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); 964 Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N))); 965 Set_Parent (Ent, N); 966 end if; 967 968 Set_Etype (Ent, Standard_Void_Type); 969 Set_Block_Node (Ent, Identifier (N)); 970 Push_Scope (Ent); 971 972 -- The block served as an extended return statement. Ensure that any 973 -- entities created during the analysis and expansion of the return 974 -- object declaration are once again visible. 975 976 if Is_BIP_Return_Statement then 977 Install_Return_Entities (Ent); 978 end if; 979 980 if Present (Decls) then 981 Analyze_Declarations (Decls); 982 Check_Completion; 983 Inspect_Deferred_Constant_Completion (Decls); 984 end if; 985 986 Analyze (HSS); 987 Process_End_Label (HSS, 'e', Ent); 988 989 -- If exception handlers are present, then we indicate that enclosing 990 -- scopes contain a block with handlers. We only need to mark non- 991 -- generic scopes. 992 993 if Present (EH) then 994 S := Scope (Ent); 995 loop 996 Set_Has_Nested_Block_With_Handler (S); 997 exit when Is_Overloadable (S) 998 or else Ekind (S) = E_Package 999 or else Is_Generic_Unit (S); 1000 S := Scope (S); 1001 end loop; 1002 end if; 1003 1004 Check_References (Ent); 1005 Warn_On_Useless_Assignments (Ent); 1006 End_Scope; 1007 1008 if Unblocked_Exit_Count = 0 then 1009 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1010 Check_Unreachable_Code (N); 1011 else 1012 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1013 end if; 1014 end; 1015 end Analyze_Block_Statement; 1016 1017 ---------------------------- 1018 -- Analyze_Case_Statement -- 1019 ---------------------------- 1020 1021 procedure Analyze_Case_Statement (N : Node_Id) is 1022 Exp : Node_Id; 1023 Exp_Type : Entity_Id; 1024 Exp_Btype : Entity_Id; 1025 Last_Choice : Nat; 1026 Dont_Care : Boolean; 1027 Others_Present : Boolean; 1028 1029 pragma Warnings (Off, Last_Choice); 1030 pragma Warnings (Off, Dont_Care); 1031 -- Don't care about assigned values 1032 1033 Statements_Analyzed : Boolean := False; 1034 -- Set True if at least some statement sequences get analyzed. If False 1035 -- on exit, means we had a serious error that prevented full analysis of 1036 -- the case statement, and as a result it is not a good idea to output 1037 -- warning messages about unreachable code. 1038 1039 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; 1040 -- Recursively save value of this global, will be restored on exit 1041 1042 procedure Non_Static_Choice_Error (Choice : Node_Id); 1043 -- Error routine invoked by the generic instantiation below when the 1044 -- case statement has a non static choice. 1045 1046 procedure Process_Statements (Alternative : Node_Id); 1047 -- Analyzes all the statements associated with a case alternative. 1048 -- Needed by the generic instantiation below. 1049 1050 package Case_Choices_Processing is new 1051 Generic_Choices_Processing 1052 (Get_Alternatives => Alternatives, 1053 Get_Choices => Discrete_Choices, 1054 Process_Empty_Choice => No_OP, 1055 Process_Non_Static_Choice => Non_Static_Choice_Error, 1056 Process_Associated_Node => Process_Statements); 1057 use Case_Choices_Processing; 1058 -- Instantiation of the generic choice processing package 1059 1060 ----------------------------- 1061 -- Non_Static_Choice_Error -- 1062 ----------------------------- 1063 1064 procedure Non_Static_Choice_Error (Choice : Node_Id) is 1065 begin 1066 Flag_Non_Static_Expr 1067 ("choice given in case statement is not static!", Choice); 1068 end Non_Static_Choice_Error; 1069 1070 ------------------------ 1071 -- Process_Statements -- 1072 ------------------------ 1073 1074 procedure Process_Statements (Alternative : Node_Id) is 1075 Choices : constant List_Id := Discrete_Choices (Alternative); 1076 Ent : Entity_Id; 1077 1078 begin 1079 Unblocked_Exit_Count := Unblocked_Exit_Count + 1; 1080 Statements_Analyzed := True; 1081 1082 -- An interesting optimization. If the case statement expression 1083 -- is a simple entity, then we can set the current value within an 1084 -- alternative if the alternative has one possible value. 1085 1086 -- case N is 1087 -- when 1 => alpha 1088 -- when 2 | 3 => beta 1089 -- when others => gamma 1090 1091 -- Here we know that N is initially 1 within alpha, but for beta and 1092 -- gamma, we do not know anything more about the initial value. 1093 1094 if Is_Entity_Name (Exp) then 1095 Ent := Entity (Exp); 1096 1097 if Ekind_In (Ent, E_Variable, 1098 E_In_Out_Parameter, 1099 E_Out_Parameter) 1100 then 1101 if List_Length (Choices) = 1 1102 and then Nkind (First (Choices)) in N_Subexpr 1103 and then Compile_Time_Known_Value (First (Choices)) 1104 then 1105 Set_Current_Value (Entity (Exp), First (Choices)); 1106 end if; 1107 1108 Analyze_Statements (Statements (Alternative)); 1109 1110 -- After analyzing the case, set the current value to empty 1111 -- since we won't know what it is for the next alternative 1112 -- (unless reset by this same circuit), or after the case. 1113 1114 Set_Current_Value (Entity (Exp), Empty); 1115 return; 1116 end if; 1117 end if; 1118 1119 -- Case where expression is not an entity name of a variable 1120 1121 Analyze_Statements (Statements (Alternative)); 1122 end Process_Statements; 1123 1124 -- Start of processing for Analyze_Case_Statement 1125 1126 begin 1127 Unblocked_Exit_Count := 0; 1128 Exp := Expression (N); 1129 Analyze (Exp); 1130 1131 -- The expression must be of any discrete type. In rare cases, the 1132 -- expander constructs a case statement whose expression has a private 1133 -- type whose full view is discrete. This can happen when generating 1134 -- a stream operation for a variant type after the type is frozen, 1135 -- when the partial of view of the type of the discriminant is private. 1136 -- In that case, use the full view to analyze case alternatives. 1137 1138 if not Is_Overloaded (Exp) 1139 and then not Comes_From_Source (N) 1140 and then Is_Private_Type (Etype (Exp)) 1141 and then Present (Full_View (Etype (Exp))) 1142 and then Is_Discrete_Type (Full_View (Etype (Exp))) 1143 then 1144 Resolve (Exp, Etype (Exp)); 1145 Exp_Type := Full_View (Etype (Exp)); 1146 1147 else 1148 Analyze_And_Resolve (Exp, Any_Discrete); 1149 Exp_Type := Etype (Exp); 1150 end if; 1151 1152 Check_Unset_Reference (Exp); 1153 Exp_Btype := Base_Type (Exp_Type); 1154 1155 -- The expression must be of a discrete type which must be determinable 1156 -- independently of the context in which the expression occurs, but 1157 -- using the fact that the expression must be of a discrete type. 1158 -- Moreover, the type this expression must not be a character literal 1159 -- (which is always ambiguous) or, for Ada-83, a generic formal type. 1160 1161 -- If error already reported by Resolve, nothing more to do 1162 1163 if Exp_Btype = Any_Discrete 1164 or else Exp_Btype = Any_Type 1165 then 1166 return; 1167 1168 elsif Exp_Btype = Any_Character then 1169 Error_Msg_N 1170 ("character literal as case expression is ambiguous", Exp); 1171 return; 1172 1173 elsif Ada_Version = Ada_83 1174 and then (Is_Generic_Type (Exp_Btype) 1175 or else Is_Generic_Type (Root_Type (Exp_Btype))) 1176 then 1177 Error_Msg_N 1178 ("(Ada 83) case expression cannot be of a generic type", Exp); 1179 return; 1180 end if; 1181 1182 -- If the case expression is a formal object of mode in out, then treat 1183 -- it as having a nonstatic subtype by forcing use of the base type 1184 -- (which has to get passed to Check_Case_Choices below). Also use base 1185 -- type when the case expression is parenthesized. 1186 1187 if Paren_Count (Exp) > 0 1188 or else (Is_Entity_Name (Exp) 1189 and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter) 1190 then 1191 Exp_Type := Exp_Btype; 1192 end if; 1193 1194 -- Call instantiated Analyze_Choices which does the rest of the work 1195 1196 Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); 1197 1198 -- A case statement with a single OTHERS alternative is not allowed 1199 -- in SPARK. 1200 1201 if Others_Present 1202 and then List_Length (Alternatives (N)) = 1 1203 then 1204 Check_SPARK_Restriction 1205 ("OTHERS as unique case alternative is not allowed", N); 1206 end if; 1207 1208 if Exp_Type = Universal_Integer and then not Others_Present then 1209 Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); 1210 end if; 1211 1212 -- If all our exits were blocked by unconditional transfers of control, 1213 -- then the entire CASE statement acts as an unconditional transfer of 1214 -- control, so treat it like one, and check unreachable code. Skip this 1215 -- test if we had serious errors preventing any statement analysis. 1216 1217 if Unblocked_Exit_Count = 0 and then Statements_Analyzed then 1218 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1219 Check_Unreachable_Code (N); 1220 else 1221 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1222 end if; 1223 1224 if not Expander_Active 1225 and then Compile_Time_Known_Value (Expression (N)) 1226 and then Serious_Errors_Detected = 0 1227 then 1228 declare 1229 Chosen : constant Node_Id := Find_Static_Alternative (N); 1230 Alt : Node_Id; 1231 1232 begin 1233 Alt := First (Alternatives (N)); 1234 while Present (Alt) loop 1235 if Alt /= Chosen then 1236 Remove_Warning_Messages (Statements (Alt)); 1237 end if; 1238 1239 Next (Alt); 1240 end loop; 1241 end; 1242 end if; 1243 end Analyze_Case_Statement; 1244 1245 ---------------------------- 1246 -- Analyze_Exit_Statement -- 1247 ---------------------------- 1248 1249 -- If the exit includes a name, it must be the name of a currently open 1250 -- loop. Otherwise there must be an innermost open loop on the stack, to 1251 -- which the statement implicitly refers. 1252 1253 -- Additionally, in SPARK mode: 1254 1255 -- The exit can only name the closest enclosing loop; 1256 1257 -- An exit with a when clause must be directly contained in a loop; 1258 1259 -- An exit without a when clause must be directly contained in an 1260 -- if-statement with no elsif or else, which is itself directly contained 1261 -- in a loop. The exit must be the last statement in the if-statement. 1262 1263 procedure Analyze_Exit_Statement (N : Node_Id) is 1264 Target : constant Node_Id := Name (N); 1265 Cond : constant Node_Id := Condition (N); 1266 Scope_Id : Entity_Id; 1267 U_Name : Entity_Id; 1268 Kind : Entity_Kind; 1269 1270 begin 1271 if No (Cond) then 1272 Check_Unreachable_Code (N); 1273 end if; 1274 1275 if Present (Target) then 1276 Analyze (Target); 1277 U_Name := Entity (Target); 1278 1279 if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then 1280 Error_Msg_N ("invalid loop name in exit statement", N); 1281 return; 1282 1283 else 1284 if Has_Loop_In_Inner_Open_Scopes (U_Name) then 1285 Check_SPARK_Restriction 1286 ("exit label must name the closest enclosing loop", N); 1287 end if; 1288 1289 Set_Has_Exit (U_Name); 1290 end if; 1291 1292 else 1293 U_Name := Empty; 1294 end if; 1295 1296 for J in reverse 0 .. Scope_Stack.Last loop 1297 Scope_Id := Scope_Stack.Table (J).Entity; 1298 Kind := Ekind (Scope_Id); 1299 1300 if Kind = E_Loop 1301 and then (No (Target) or else Scope_Id = U_Name) 1302 then 1303 Set_Has_Exit (Scope_Id); 1304 exit; 1305 1306 elsif Kind = E_Block 1307 or else Kind = E_Loop 1308 or else Kind = E_Return_Statement 1309 then 1310 null; 1311 1312 else 1313 Error_Msg_N 1314 ("cannot exit from program unit or accept statement", N); 1315 return; 1316 end if; 1317 end loop; 1318 1319 -- Verify that if present the condition is a Boolean expression 1320 1321 if Present (Cond) then 1322 Analyze_And_Resolve (Cond, Any_Boolean); 1323 Check_Unset_Reference (Cond); 1324 end if; 1325 1326 -- In SPARK mode, verify that the exit statement respects the SPARK 1327 -- restrictions. 1328 1329 if Present (Cond) then 1330 if Nkind (Parent (N)) /= N_Loop_Statement then 1331 Check_SPARK_Restriction 1332 ("exit with when clause must be directly in loop", N); 1333 end if; 1334 1335 else 1336 if Nkind (Parent (N)) /= N_If_Statement then 1337 if Nkind (Parent (N)) = N_Elsif_Part then 1338 Check_SPARK_Restriction 1339 ("exit must be in IF without ELSIF", N); 1340 else 1341 Check_SPARK_Restriction ("exit must be directly in IF", N); 1342 end if; 1343 1344 elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then 1345 Check_SPARK_Restriction 1346 ("exit must be in IF directly in loop", N); 1347 1348 -- First test the presence of ELSE, so that an exit in an ELSE leads 1349 -- to an error mentioning the ELSE. 1350 1351 elsif Present (Else_Statements (Parent (N))) then 1352 Check_SPARK_Restriction ("exit must be in IF without ELSE", N); 1353 1354 -- An exit in an ELSIF does not reach here, as it would have been 1355 -- detected in the case (Nkind (Parent (N)) /= N_If_Statement). 1356 1357 elsif Present (Elsif_Parts (Parent (N))) then 1358 Check_SPARK_Restriction ("exit must be in IF without ELSIF", N); 1359 end if; 1360 end if; 1361 1362 -- Chain exit statement to associated loop entity 1363 1364 Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); 1365 Set_First_Exit_Statement (Scope_Id, N); 1366 1367 -- Since the exit may take us out of a loop, any previous assignment 1368 -- statement is not useless, so clear last assignment indications. It 1369 -- is OK to keep other current values, since if the exit statement 1370 -- does not exit, then the current values are still valid. 1371 1372 Kill_Current_Values (Last_Assignment_Only => True); 1373 end Analyze_Exit_Statement; 1374 1375 ---------------------------- 1376 -- Analyze_Goto_Statement -- 1377 ---------------------------- 1378 1379 procedure Analyze_Goto_Statement (N : Node_Id) is 1380 Label : constant Node_Id := Name (N); 1381 Scope_Id : Entity_Id; 1382 Label_Scope : Entity_Id; 1383 Label_Ent : Entity_Id; 1384 1385 begin 1386 Check_SPARK_Restriction ("goto statement is not allowed", N); 1387 1388 -- Actual semantic checks 1389 1390 Check_Unreachable_Code (N); 1391 Kill_Current_Values (Last_Assignment_Only => True); 1392 1393 Analyze (Label); 1394 Label_Ent := Entity (Label); 1395 1396 -- Ignore previous error 1397 1398 if Label_Ent = Any_Id then 1399 Check_Error_Detected; 1400 return; 1401 1402 -- We just have a label as the target of a goto 1403 1404 elsif Ekind (Label_Ent) /= E_Label then 1405 Error_Msg_N ("target of goto statement must be a label", Label); 1406 return; 1407 1408 -- Check that the target of the goto is reachable according to Ada 1409 -- scoping rules. Note: the special gotos we generate for optimizing 1410 -- local handling of exceptions would violate these rules, but we mark 1411 -- such gotos as analyzed when built, so this code is never entered. 1412 1413 elsif not Reachable (Label_Ent) then 1414 Error_Msg_N ("target of goto statement is not reachable", Label); 1415 return; 1416 end if; 1417 1418 -- Here if goto passes initial validity checks 1419 1420 Label_Scope := Enclosing_Scope (Label_Ent); 1421 1422 for J in reverse 0 .. Scope_Stack.Last loop 1423 Scope_Id := Scope_Stack.Table (J).Entity; 1424 1425 if Label_Scope = Scope_Id 1426 or else (Ekind (Scope_Id) /= E_Block 1427 and then Ekind (Scope_Id) /= E_Loop 1428 and then Ekind (Scope_Id) /= E_Return_Statement) 1429 then 1430 if Scope_Id /= Label_Scope then 1431 Error_Msg_N 1432 ("cannot exit from program unit or accept statement", N); 1433 end if; 1434 1435 return; 1436 end if; 1437 end loop; 1438 1439 raise Program_Error; 1440 end Analyze_Goto_Statement; 1441 1442 -------------------------- 1443 -- Analyze_If_Statement -- 1444 -------------------------- 1445 1446 -- A special complication arises in the analysis of if statements 1447 1448 -- The expander has circuitry to completely delete code that it can tell 1449 -- will not be executed (as a result of compile time known conditions). In 1450 -- the analyzer, we ensure that code that will be deleted in this manner is 1451 -- analyzed but not expanded. This is obviously more efficient, but more 1452 -- significantly, difficulties arise if code is expanded and then 1453 -- eliminated (e.g. exception table entries disappear). Similarly, itypes 1454 -- generated in deleted code must be frozen from start, because the nodes 1455 -- on which they depend will not be available at the freeze point. 1456 1457 procedure Analyze_If_Statement (N : Node_Id) is 1458 E : Node_Id; 1459 1460 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; 1461 -- Recursively save value of this global, will be restored on exit 1462 1463 Save_In_Deleted_Code : Boolean; 1464 1465 Del : Boolean := False; 1466 -- This flag gets set True if a True condition has been found, which 1467 -- means that remaining ELSE/ELSIF parts are deleted. 1468 1469 procedure Analyze_Cond_Then (Cnode : Node_Id); 1470 -- This is applied to either the N_If_Statement node itself or to an 1471 -- N_Elsif_Part node. It deals with analyzing the condition and the THEN 1472 -- statements associated with it. 1473 1474 ----------------------- 1475 -- Analyze_Cond_Then -- 1476 ----------------------- 1477 1478 procedure Analyze_Cond_Then (Cnode : Node_Id) is 1479 Cond : constant Node_Id := Condition (Cnode); 1480 Tstm : constant List_Id := Then_Statements (Cnode); 1481 1482 begin 1483 Unblocked_Exit_Count := Unblocked_Exit_Count + 1; 1484 Analyze_And_Resolve (Cond, Any_Boolean); 1485 Check_Unset_Reference (Cond); 1486 Set_Current_Value_Condition (Cnode); 1487 1488 -- If already deleting, then just analyze then statements 1489 1490 if Del then 1491 Analyze_Statements (Tstm); 1492 1493 -- Compile time known value, not deleting yet 1494 1495 elsif Compile_Time_Known_Value (Cond) then 1496 Save_In_Deleted_Code := In_Deleted_Code; 1497 1498 -- If condition is True, then analyze the THEN statements and set 1499 -- no expansion for ELSE and ELSIF parts. 1500 1501 if Is_True (Expr_Value (Cond)) then 1502 Analyze_Statements (Tstm); 1503 Del := True; 1504 Expander_Mode_Save_And_Set (False); 1505 In_Deleted_Code := True; 1506 1507 -- If condition is False, analyze THEN with expansion off 1508 1509 else -- Is_False (Expr_Value (Cond)) 1510 Expander_Mode_Save_And_Set (False); 1511 In_Deleted_Code := True; 1512 Analyze_Statements (Tstm); 1513 Expander_Mode_Restore; 1514 In_Deleted_Code := Save_In_Deleted_Code; 1515 end if; 1516 1517 -- Not known at compile time, not deleting, normal analysis 1518 1519 else 1520 Analyze_Statements (Tstm); 1521 end if; 1522 end Analyze_Cond_Then; 1523 1524 -- Start of Analyze_If_Statement 1525 1526 begin 1527 -- Initialize exit count for else statements. If there is no else part, 1528 -- this count will stay non-zero reflecting the fact that the uncovered 1529 -- else case is an unblocked exit. 1530 1531 Unblocked_Exit_Count := 1; 1532 Analyze_Cond_Then (N); 1533 1534 -- Now to analyze the elsif parts if any are present 1535 1536 if Present (Elsif_Parts (N)) then 1537 E := First (Elsif_Parts (N)); 1538 while Present (E) loop 1539 Analyze_Cond_Then (E); 1540 Next (E); 1541 end loop; 1542 end if; 1543 1544 if Present (Else_Statements (N)) then 1545 Analyze_Statements (Else_Statements (N)); 1546 end if; 1547 1548 -- If all our exits were blocked by unconditional transfers of control, 1549 -- then the entire IF statement acts as an unconditional transfer of 1550 -- control, so treat it like one, and check unreachable code. 1551 1552 if Unblocked_Exit_Count = 0 then 1553 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1554 Check_Unreachable_Code (N); 1555 else 1556 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1557 end if; 1558 1559 if Del then 1560 Expander_Mode_Restore; 1561 In_Deleted_Code := Save_In_Deleted_Code; 1562 end if; 1563 1564 if not Expander_Active 1565 and then Compile_Time_Known_Value (Condition (N)) 1566 and then Serious_Errors_Detected = 0 1567 then 1568 if Is_True (Expr_Value (Condition (N))) then 1569 Remove_Warning_Messages (Else_Statements (N)); 1570 1571 if Present (Elsif_Parts (N)) then 1572 E := First (Elsif_Parts (N)); 1573 while Present (E) loop 1574 Remove_Warning_Messages (Then_Statements (E)); 1575 Next (E); 1576 end loop; 1577 end if; 1578 1579 else 1580 Remove_Warning_Messages (Then_Statements (N)); 1581 end if; 1582 end if; 1583 end Analyze_If_Statement; 1584 1585 ---------------------------------------- 1586 -- Analyze_Implicit_Label_Declaration -- 1587 ---------------------------------------- 1588 1589 -- An implicit label declaration is generated in the innermost enclosing 1590 -- declarative part. This is done for labels, and block and loop names. 1591 1592 -- Note: any changes in this routine may need to be reflected in 1593 -- Analyze_Label_Entity. 1594 1595 procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is 1596 Id : constant Node_Id := Defining_Identifier (N); 1597 begin 1598 Enter_Name (Id); 1599 Set_Ekind (Id, E_Label); 1600 Set_Etype (Id, Standard_Void_Type); 1601 Set_Enclosing_Scope (Id, Current_Scope); 1602 end Analyze_Implicit_Label_Declaration; 1603 1604 ------------------------------ 1605 -- Analyze_Iteration_Scheme -- 1606 ------------------------------ 1607 1608 procedure Analyze_Iteration_Scheme (N : Node_Id) is 1609 Cond : Node_Id; 1610 Iter_Spec : Node_Id; 1611 Loop_Spec : Node_Id; 1612 1613 begin 1614 -- For an infinite loop, there is no iteration scheme 1615 1616 if No (N) then 1617 return; 1618 end if; 1619 1620 Cond := Condition (N); 1621 Iter_Spec := Iterator_Specification (N); 1622 Loop_Spec := Loop_Parameter_Specification (N); 1623 1624 if Present (Cond) then 1625 Analyze_And_Resolve (Cond, Any_Boolean); 1626 Check_Unset_Reference (Cond); 1627 Set_Current_Value_Condition (N); 1628 1629 elsif Present (Iter_Spec) then 1630 Analyze_Iterator_Specification (Iter_Spec); 1631 1632 else 1633 Analyze_Loop_Parameter_Specification (Loop_Spec); 1634 end if; 1635 end Analyze_Iteration_Scheme; 1636 1637 ------------------------------------ 1638 -- Analyze_Iterator_Specification -- 1639 ------------------------------------ 1640 1641 procedure Analyze_Iterator_Specification (N : Node_Id) is 1642 Loc : constant Source_Ptr := Sloc (N); 1643 Def_Id : constant Node_Id := Defining_Identifier (N); 1644 Subt : constant Node_Id := Subtype_Indication (N); 1645 Iter_Name : constant Node_Id := Name (N); 1646 1647 Ent : Entity_Id; 1648 Typ : Entity_Id; 1649 1650 begin 1651 Enter_Name (Def_Id); 1652 1653 if Present (Subt) then 1654 Analyze (Subt); 1655 end if; 1656 1657 Preanalyze_Range (Iter_Name); 1658 1659 -- Set the kind of the loop variable, which is not visible within 1660 -- the iterator name. 1661 1662 Set_Ekind (Def_Id, E_Variable); 1663 1664 -- If the domain of iteration is an expression, create a declaration for 1665 -- it, so that finalization actions are introduced outside of the loop. 1666 -- The declaration must be a renaming because the body of the loop may 1667 -- assign to elements. 1668 1669 if not Is_Entity_Name (Iter_Name) 1670 1671 -- When the context is a quantified expression, the renaming 1672 -- declaration is delayed until the expansion phase if we are 1673 -- doing expansion. 1674 1675 and then (Nkind (Parent (N)) /= N_Quantified_Expression 1676 or else Operating_Mode = Check_Semantics) 1677 1678 -- Do not perform this expansion in Alfa mode, since the formal 1679 -- verification directly deals with the source form of the iterator. 1680 1681 and then not Alfa_Mode 1682 then 1683 declare 1684 Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); 1685 Decl : Node_Id; 1686 1687 begin 1688 Typ := Etype (Iter_Name); 1689 1690 -- Protect against malformed iterator 1691 1692 if Typ = Any_Type then 1693 Error_Msg_N ("invalid expression in loop iterator", Iter_Name); 1694 return; 1695 end if; 1696 1697 -- The name in the renaming declaration may be a function call. 1698 -- Indicate that it does not come from source, to suppress 1699 -- spurious warnings on renamings of parameterless functions, 1700 -- a common enough idiom in user-defined iterators. 1701 1702 Decl := 1703 Make_Object_Renaming_Declaration (Loc, 1704 Defining_Identifier => Id, 1705 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 1706 Name => 1707 New_Copy_Tree (Iter_Name, New_Sloc => Loc)); 1708 1709 Insert_Actions (Parent (Parent (N)), New_List (Decl)); 1710 Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); 1711 Set_Etype (Id, Typ); 1712 Set_Etype (Name (N), Typ); 1713 end; 1714 1715 -- Container is an entity or an array with uncontrolled components, or 1716 -- else it is a container iterator given by a function call, typically 1717 -- called Iterate in the case of predefined containers, even though 1718 -- Iterate is not a reserved name. What matters is that the return type 1719 -- of the function is an iterator type. 1720 1721 elsif Is_Entity_Name (Iter_Name) then 1722 Analyze (Iter_Name); 1723 1724 if Nkind (Iter_Name) = N_Function_Call then 1725 declare 1726 C : constant Node_Id := Name (Iter_Name); 1727 I : Interp_Index; 1728 It : Interp; 1729 1730 begin 1731 if not Is_Overloaded (Iter_Name) then 1732 Resolve (Iter_Name, Etype (C)); 1733 1734 else 1735 Get_First_Interp (C, I, It); 1736 while It.Typ /= Empty loop 1737 if Reverse_Present (N) then 1738 if Is_Reversible_Iterator (It.Typ) then 1739 Resolve (Iter_Name, It.Typ); 1740 exit; 1741 end if; 1742 1743 elsif Is_Iterator (It.Typ) then 1744 Resolve (Iter_Name, It.Typ); 1745 exit; 1746 end if; 1747 1748 Get_Next_Interp (I, It); 1749 end loop; 1750 end if; 1751 end; 1752 1753 -- Domain of iteration is not overloaded 1754 1755 else 1756 Resolve (Iter_Name, Etype (Iter_Name)); 1757 end if; 1758 end if; 1759 1760 Typ := Etype (Iter_Name); 1761 1762 if Is_Array_Type (Typ) then 1763 if Of_Present (N) then 1764 Set_Etype (Def_Id, Component_Type (Typ)); 1765 1766 -- Here we have a missing Range attribute 1767 1768 else 1769 Error_Msg_N 1770 ("missing Range attribute in iteration over an array", N); 1771 1772 -- In Ada 2012 mode, this may be an attempt at an iterator 1773 1774 if Ada_Version >= Ada_2012 then 1775 Error_Msg_NE 1776 ("\if& is meant to designate an element of the array, use OF", 1777 N, Def_Id); 1778 end if; 1779 1780 -- Prevent cascaded errors 1781 1782 Set_Ekind (Def_Id, E_Loop_Parameter); 1783 Set_Etype (Def_Id, Etype (First_Index (Typ))); 1784 end if; 1785 1786 -- Check for type error in iterator 1787 1788 elsif Typ = Any_Type then 1789 return; 1790 1791 -- Iteration over a container 1792 1793 else 1794 Set_Ekind (Def_Id, E_Loop_Parameter); 1795 1796 if Of_Present (N) then 1797 1798 -- The type of the loop variable is the Iterator_Element aspect of 1799 -- the container type. 1800 1801 declare 1802 Element : constant Entity_Id := 1803 Find_Aspect (Typ, Aspect_Iterator_Element); 1804 begin 1805 if No (Element) then 1806 Error_Msg_NE ("cannot iterate over&", N, Typ); 1807 return; 1808 else 1809 Set_Etype (Def_Id, Entity (Element)); 1810 1811 -- If the container has a variable indexing aspect, the 1812 -- element is a variable and is modifiable in the loop. 1813 1814 if Present (Find_Aspect (Typ, Aspect_Variable_Indexing)) then 1815 Set_Ekind (Def_Id, E_Variable); 1816 end if; 1817 end if; 1818 end; 1819 1820 else 1821 -- For an iteration of the form IN, the name must denote an 1822 -- iterator, typically the result of a call to Iterate. Give a 1823 -- useful error message when the name is a container by itself. 1824 1825 if Is_Entity_Name (Original_Node (Name (N))) 1826 and then not Is_Iterator (Typ) 1827 then 1828 if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then 1829 Error_Msg_NE 1830 ("cannot iterate over&", Name (N), Typ); 1831 else 1832 Error_Msg_N 1833 ("name must be an iterator, not a container", Name (N)); 1834 end if; 1835 1836 Error_Msg_NE 1837 ("\to iterate directly over the elements of a container, " & 1838 "write `of &`", Name (N), Original_Node (Name (N))); 1839 end if; 1840 1841 -- The result type of Iterate function is the classwide type of 1842 -- the interface parent. We need the specific Cursor type defined 1843 -- in the container package. 1844 1845 Ent := First_Entity (Scope (Typ)); 1846 while Present (Ent) loop 1847 if Chars (Ent) = Name_Cursor then 1848 Set_Etype (Def_Id, Etype (Ent)); 1849 exit; 1850 end if; 1851 1852 Next_Entity (Ent); 1853 end loop; 1854 end if; 1855 end if; 1856 end Analyze_Iterator_Specification; 1857 1858 ------------------- 1859 -- Analyze_Label -- 1860 ------------------- 1861 1862 -- Note: the semantic work required for analyzing labels (setting them as 1863 -- reachable) was done in a prepass through the statements in the block, 1864 -- so that forward gotos would be properly handled. See Analyze_Statements 1865 -- for further details. The only processing required here is to deal with 1866 -- optimizations that depend on an assumption of sequential control flow, 1867 -- since of course the occurrence of a label breaks this assumption. 1868 1869 procedure Analyze_Label (N : Node_Id) is 1870 pragma Warnings (Off, N); 1871 begin 1872 Kill_Current_Values; 1873 end Analyze_Label; 1874 1875 -------------------------- 1876 -- Analyze_Label_Entity -- 1877 -------------------------- 1878 1879 procedure Analyze_Label_Entity (E : Entity_Id) is 1880 begin 1881 Set_Ekind (E, E_Label); 1882 Set_Etype (E, Standard_Void_Type); 1883 Set_Enclosing_Scope (E, Current_Scope); 1884 Set_Reachable (E, True); 1885 end Analyze_Label_Entity; 1886 1887 ------------------------------------------ 1888 -- Analyze_Loop_Parameter_Specification -- 1889 ------------------------------------------ 1890 1891 procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is 1892 Loop_Nod : constant Node_Id := Parent (Parent (N)); 1893 1894 procedure Check_Controlled_Array_Attribute (DS : Node_Id); 1895 -- If the bounds are given by a 'Range reference on a function call 1896 -- that returns a controlled array, introduce an explicit declaration 1897 -- to capture the bounds, so that the function result can be finalized 1898 -- in timely fashion. 1899 1900 function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; 1901 -- N is the node for an arbitrary construct. This function searches the 1902 -- construct N to see if any expressions within it contain function 1903 -- calls that use the secondary stack, returning True if any such call 1904 -- is found, and False otherwise. 1905 1906 procedure Process_Bounds (R : Node_Id); 1907 -- If the iteration is given by a range, create temporaries and 1908 -- assignment statements block to capture the bounds and perform 1909 -- required finalization actions in case a bound includes a function 1910 -- call that uses the temporary stack. We first pre-analyze a copy of 1911 -- the range in order to determine the expected type, and analyze and 1912 -- resolve the original bounds. 1913 1914 -------------------------------------- 1915 -- Check_Controlled_Array_Attribute -- 1916 -------------------------------------- 1917 1918 procedure Check_Controlled_Array_Attribute (DS : Node_Id) is 1919 begin 1920 if Nkind (DS) = N_Attribute_Reference 1921 and then Is_Entity_Name (Prefix (DS)) 1922 and then Ekind (Entity (Prefix (DS))) = E_Function 1923 and then Is_Array_Type (Etype (Entity (Prefix (DS)))) 1924 and then 1925 Is_Controlled (Component_Type (Etype (Entity (Prefix (DS))))) 1926 and then Expander_Active 1927 then 1928 declare 1929 Loc : constant Source_Ptr := Sloc (N); 1930 Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); 1931 Indx : constant Entity_Id := 1932 Base_Type (Etype (First_Index (Arr))); 1933 Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); 1934 Decl : Node_Id; 1935 1936 begin 1937 Decl := 1938 Make_Subtype_Declaration (Loc, 1939 Defining_Identifier => Subt, 1940 Subtype_Indication => 1941 Make_Subtype_Indication (Loc, 1942 Subtype_Mark => New_Reference_To (Indx, Loc), 1943 Constraint => 1944 Make_Range_Constraint (Loc, Relocate_Node (DS)))); 1945 Insert_Before (Loop_Nod, Decl); 1946 Analyze (Decl); 1947 1948 Rewrite (DS, 1949 Make_Attribute_Reference (Loc, 1950 Prefix => New_Reference_To (Subt, Loc), 1951 Attribute_Name => Attribute_Name (DS))); 1952 1953 Analyze (DS); 1954 end; 1955 end if; 1956 end Check_Controlled_Array_Attribute; 1957 1958 ------------------------------------ 1959 -- Has_Call_Using_Secondary_Stack -- 1960 ------------------------------------ 1961 1962 function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is 1963 1964 function Check_Call (N : Node_Id) return Traverse_Result; 1965 -- Check if N is a function call which uses the secondary stack 1966 1967 ---------------- 1968 -- Check_Call -- 1969 ---------------- 1970 1971 function Check_Call (N : Node_Id) return Traverse_Result is 1972 Nam : Node_Id; 1973 Subp : Entity_Id; 1974 Return_Typ : Entity_Id; 1975 1976 begin 1977 if Nkind (N) = N_Function_Call then 1978 Nam := Name (N); 1979 1980 -- Call using access to subprogram with explicit dereference 1981 1982 if Nkind (Nam) = N_Explicit_Dereference then 1983 Subp := Etype (Nam); 1984 1985 -- Call using a selected component notation or Ada 2005 object 1986 -- operation notation 1987 1988 elsif Nkind (Nam) = N_Selected_Component then 1989 Subp := Entity (Selector_Name (Nam)); 1990 1991 -- Common case 1992 1993 else 1994 Subp := Entity (Nam); 1995 end if; 1996 1997 Return_Typ := Etype (Subp); 1998 1999 if Is_Composite_Type (Return_Typ) 2000 and then not Is_Constrained (Return_Typ) 2001 then 2002 return Abandon; 2003 2004 elsif Sec_Stack_Needed_For_Return (Subp) then 2005 return Abandon; 2006 end if; 2007 end if; 2008 2009 -- Continue traversing the tree 2010 2011 return OK; 2012 end Check_Call; 2013 2014 function Check_Calls is new Traverse_Func (Check_Call); 2015 2016 -- Start of processing for Has_Call_Using_Secondary_Stack 2017 2018 begin 2019 return Check_Calls (N) = Abandon; 2020 end Has_Call_Using_Secondary_Stack; 2021 2022 -------------------- 2023 -- Process_Bounds -- 2024 -------------------- 2025 2026 procedure Process_Bounds (R : Node_Id) is 2027 Loc : constant Source_Ptr := Sloc (N); 2028 2029 function One_Bound 2030 (Original_Bound : Node_Id; 2031 Analyzed_Bound : Node_Id; 2032 Typ : Entity_Id) return Node_Id; 2033 -- Capture value of bound and return captured value 2034 2035 --------------- 2036 -- One_Bound -- 2037 --------------- 2038 2039 function One_Bound 2040 (Original_Bound : Node_Id; 2041 Analyzed_Bound : Node_Id; 2042 Typ : Entity_Id) return Node_Id 2043 is 2044 Assign : Node_Id; 2045 Decl : Node_Id; 2046 Id : Entity_Id; 2047 2048 begin 2049 -- If the bound is a constant or an object, no need for a separate 2050 -- declaration. If the bound is the result of previous expansion 2051 -- it is already analyzed and should not be modified. Note that 2052 -- the Bound will be resolved later, if needed, as part of the 2053 -- call to Make_Index (literal bounds may need to be resolved to 2054 -- type Integer). 2055 2056 if Analyzed (Original_Bound) then 2057 return Original_Bound; 2058 2059 elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, 2060 N_Character_Literal) 2061 or else Is_Entity_Name (Analyzed_Bound) 2062 then 2063 Analyze_And_Resolve (Original_Bound, Typ); 2064 return Original_Bound; 2065 end if; 2066 2067 -- Normally, the best approach is simply to generate a constant 2068 -- declaration that captures the bound. However, there is a nasty 2069 -- case where this is wrong. If the bound is complex, and has a 2070 -- possible use of the secondary stack, we need to generate a 2071 -- separate assignment statement to ensure the creation of a block 2072 -- which will release the secondary stack. 2073 2074 -- We prefer the constant declaration, since it leaves us with a 2075 -- proper trace of the value, useful in optimizations that get rid 2076 -- of junk range checks. 2077 2078 if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then 2079 Analyze_And_Resolve (Original_Bound, Typ); 2080 Force_Evaluation (Original_Bound); 2081 return Original_Bound; 2082 end if; 2083 2084 Id := Make_Temporary (Loc, 'R', Original_Bound); 2085 2086 -- Here we make a declaration with a separate assignment 2087 -- statement, and insert before loop header. 2088 2089 Decl := 2090 Make_Object_Declaration (Loc, 2091 Defining_Identifier => Id, 2092 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2093 2094 Assign := 2095 Make_Assignment_Statement (Loc, 2096 Name => New_Occurrence_Of (Id, Loc), 2097 Expression => Relocate_Node (Original_Bound)); 2098 2099 Insert_Actions (Loop_Nod, New_List (Decl, Assign)); 2100 2101 -- Now that this temporary variable is initialized we decorate it 2102 -- as safe-to-reevaluate to inform to the backend that no further 2103 -- asignment will be issued and hence it can be handled as side 2104 -- effect free. Note that this decoration must be done when the 2105 -- assignment has been analyzed because otherwise it will be 2106 -- rejected (see Analyze_Assignment). 2107 2108 Set_Is_Safe_To_Reevaluate (Id); 2109 2110 Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); 2111 2112 if Nkind (Assign) = N_Assignment_Statement then 2113 return Expression (Assign); 2114 else 2115 return Original_Bound; 2116 end if; 2117 end One_Bound; 2118 2119 Hi : constant Node_Id := High_Bound (R); 2120 Lo : constant Node_Id := Low_Bound (R); 2121 R_Copy : constant Node_Id := New_Copy_Tree (R); 2122 New_Hi : Node_Id; 2123 New_Lo : Node_Id; 2124 Typ : Entity_Id; 2125 2126 -- Start of processing for Process_Bounds 2127 2128 begin 2129 Set_Parent (R_Copy, Parent (R)); 2130 Preanalyze_Range (R_Copy); 2131 Typ := Etype (R_Copy); 2132 2133 -- If the type of the discrete range is Universal_Integer, then the 2134 -- bound's type must be resolved to Integer, and any object used to 2135 -- hold the bound must also have type Integer, unless the literal 2136 -- bounds are constant-folded expressions with a user-defined type. 2137 2138 if Typ = Universal_Integer then 2139 if Nkind (Lo) = N_Integer_Literal 2140 and then Present (Etype (Lo)) 2141 and then Scope (Etype (Lo)) /= Standard_Standard 2142 then 2143 Typ := Etype (Lo); 2144 2145 elsif Nkind (Hi) = N_Integer_Literal 2146 and then Present (Etype (Hi)) 2147 and then Scope (Etype (Hi)) /= Standard_Standard 2148 then 2149 Typ := Etype (Hi); 2150 2151 else 2152 Typ := Standard_Integer; 2153 end if; 2154 end if; 2155 2156 Set_Etype (R, Typ); 2157 2158 New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ); 2159 New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ); 2160 2161 -- Propagate staticness to loop range itself, in case the 2162 -- corresponding subtype is static. 2163 2164 if New_Lo /= Lo 2165 and then Is_Static_Expression (New_Lo) 2166 then 2167 Rewrite (Low_Bound (R), New_Copy (New_Lo)); 2168 end if; 2169 2170 if New_Hi /= Hi 2171 and then Is_Static_Expression (New_Hi) 2172 then 2173 Rewrite (High_Bound (R), New_Copy (New_Hi)); 2174 end if; 2175 end Process_Bounds; 2176 2177 -- Local variables 2178 2179 DS : constant Node_Id := Discrete_Subtype_Definition (N); 2180 Id : constant Entity_Id := Defining_Identifier (N); 2181 2182 DS_Copy : Node_Id; 2183 2184 -- Start of processing for Analyze_Loop_Parameter_Specification 2185 2186 begin 2187 Enter_Name (Id); 2188 2189 -- We always consider the loop variable to be referenced, since the loop 2190 -- may be used just for counting purposes. 2191 2192 Generate_Reference (Id, N, ' '); 2193 2194 -- Check for the case of loop variable hiding a local variable (used 2195 -- later on to give a nice warning if the hidden variable is never 2196 -- assigned). 2197 2198 declare 2199 H : constant Entity_Id := Homonym (Id); 2200 begin 2201 if Present (H) 2202 and then Ekind (H) = E_Variable 2203 and then Is_Discrete_Type (Etype (H)) 2204 and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id) 2205 then 2206 Set_Hiding_Loop_Variable (H, Id); 2207 end if; 2208 end; 2209 2210 -- Loop parameter specification must include subtype mark in SPARK 2211 2212 if Nkind (DS) = N_Range then 2213 Check_SPARK_Restriction 2214 ("loop parameter specification must include subtype mark", N); 2215 end if; 2216 2217 -- Analyze the subtype definition and create temporaries for the bounds. 2218 -- Do not evaluate the range when preanalyzing a quantified expression 2219 -- because bounds expressed as function calls with side effects will be 2220 -- erroneously replicated. 2221 2222 if Nkind (DS) = N_Range 2223 and then Expander_Active 2224 and then Nkind (Parent (N)) /= N_Quantified_Expression 2225 then 2226 Process_Bounds (DS); 2227 2228 -- Either the expander not active or the range of iteration is a subtype 2229 -- indication, an entity, or a function call that yields an aggregate or 2230 -- a container. 2231 2232 else 2233 DS_Copy := New_Copy_Tree (DS); 2234 Set_Parent (DS_Copy, Parent (DS)); 2235 Preanalyze_Range (DS_Copy); 2236 2237 -- Ada 2012: If the domain of iteration is a function call, it is the 2238 -- new iterator form. 2239 2240 if Nkind (DS_Copy) = N_Function_Call 2241 or else 2242 (Is_Entity_Name (DS_Copy) 2243 and then not Is_Type (Entity (DS_Copy))) 2244 then 2245 -- This is an iterator specification. Rewrite it as such and 2246 -- analyze it to capture function calls that may require 2247 -- finalization actions. 2248 2249 declare 2250 I_Spec : constant Node_Id := 2251 Make_Iterator_Specification (Sloc (N), 2252 Defining_Identifier => Relocate_Node (Id), 2253 Name => DS_Copy, 2254 Subtype_Indication => Empty, 2255 Reverse_Present => Reverse_Present (N)); 2256 Scheme : constant Node_Id := Parent (N); 2257 2258 begin 2259 Set_Iterator_Specification (Scheme, I_Spec); 2260 Set_Loop_Parameter_Specification (Scheme, Empty); 2261 Analyze_Iterator_Specification (I_Spec); 2262 2263 -- In a generic context, analyze the original domain of 2264 -- iteration, for name capture. 2265 2266 if not Expander_Active then 2267 Analyze (DS); 2268 end if; 2269 2270 -- Set kind of loop parameter, which may be used in the 2271 -- subsequent analysis of the condition in a quantified 2272 -- expression. 2273 2274 Set_Ekind (Id, E_Loop_Parameter); 2275 return; 2276 end; 2277 2278 -- Domain of iteration is not a function call, and is side-effect 2279 -- free. 2280 2281 else 2282 -- A quantified expression that appears in a pre/post condition 2283 -- is pre-analyzed several times. If the range is given by an 2284 -- attribute reference it is rewritten as a range, and this is 2285 -- done even with expansion disabled. If the type is already set 2286 -- do not reanalyze, because a range with static bounds may be 2287 -- typed Integer by default. 2288 2289 if Nkind (Parent (N)) = N_Quantified_Expression 2290 and then Present (Etype (DS)) 2291 then 2292 null; 2293 else 2294 Analyze (DS); 2295 end if; 2296 end if; 2297 end if; 2298 2299 if DS = Error then 2300 return; 2301 end if; 2302 2303 -- Some additional checks if we are iterating through a type 2304 2305 if Is_Entity_Name (DS) 2306 and then Present (Entity (DS)) 2307 and then Is_Type (Entity (DS)) 2308 then 2309 -- The subtype indication may denote the completion of an incomplete 2310 -- type declaration. 2311 2312 if Ekind (Entity (DS)) = E_Incomplete_Type then 2313 Set_Entity (DS, Get_Full_View (Entity (DS))); 2314 Set_Etype (DS, Entity (DS)); 2315 end if; 2316 2317 -- Attempt to iterate through non-static predicate 2318 2319 if Is_Discrete_Type (Entity (DS)) 2320 and then Present (Predicate_Function (Entity (DS))) 2321 and then No (Static_Predicate (Entity (DS))) 2322 then 2323 Bad_Predicated_Subtype_Use 2324 ("cannot use subtype& with non-static predicate for loop " & 2325 "iteration", DS, Entity (DS)); 2326 end if; 2327 end if; 2328 2329 -- Error if not discrete type 2330 2331 if not Is_Discrete_Type (Etype (DS)) then 2332 Wrong_Type (DS, Any_Discrete); 2333 Set_Etype (DS, Any_Type); 2334 end if; 2335 2336 Check_Controlled_Array_Attribute (DS); 2337 2338 Make_Index (DS, N, In_Iter_Schm => True); 2339 Set_Ekind (Id, E_Loop_Parameter); 2340 2341 -- A quantified expression which appears in a pre- or post-condition may 2342 -- be analyzed multiple times. The analysis of the range creates several 2343 -- itypes which reside in different scopes depending on whether the pre- 2344 -- or post-condition has been expanded. Update the type of the loop 2345 -- variable to reflect the proper itype at each stage of analysis. 2346 2347 if No (Etype (Id)) 2348 or else Etype (Id) = Any_Type 2349 or else 2350 (Present (Etype (Id)) 2351 and then Is_Itype (Etype (Id)) 2352 and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions 2353 and then Nkind (Original_Node (Parent (Loop_Nod))) = 2354 N_Quantified_Expression) 2355 then 2356 Set_Etype (Id, Etype (DS)); 2357 end if; 2358 2359 -- Treat a range as an implicit reference to the type, to inhibit 2360 -- spurious warnings. 2361 2362 Generate_Reference (Base_Type (Etype (DS)), N, ' '); 2363 Set_Is_Known_Valid (Id, True); 2364 2365 -- The loop is not a declarative part, so the loop variable must be 2366 -- frozen explicitly. Do not freeze while preanalyzing a quantified 2367 -- expression because the freeze node will not be inserted into the 2368 -- tree due to flag Is_Spec_Expression being set. 2369 2370 if Nkind (Parent (N)) /= N_Quantified_Expression then 2371 declare 2372 Flist : constant List_Id := Freeze_Entity (Id, N); 2373 begin 2374 if Is_Non_Empty_List (Flist) then 2375 Insert_Actions (N, Flist); 2376 end if; 2377 end; 2378 end if; 2379 2380 -- Check for null or possibly null range and issue warning. We suppress 2381 -- such messages in generic templates and instances, because in practice 2382 -- they tend to be dubious in these cases. 2383 2384 if Nkind (DS) = N_Range and then Comes_From_Source (N) then 2385 declare 2386 L : constant Node_Id := Low_Bound (DS); 2387 H : constant Node_Id := High_Bound (DS); 2388 2389 begin 2390 -- If range of loop is null, issue warning 2391 2392 if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then 2393 2394 -- Suppress the warning if inside a generic template or 2395 -- instance, since in practice they tend to be dubious in these 2396 -- cases since they can result from intended parametrization. 2397 2398 if not Inside_A_Generic 2399 and then not In_Instance 2400 then 2401 -- Specialize msg if invalid values could make the loop 2402 -- non-null after all. 2403 2404 if Compile_Time_Compare 2405 (L, H, Assume_Valid => False) = GT 2406 then 2407 Error_Msg_N 2408 ("??loop range is null, loop will not execute", DS); 2409 2410 -- Since we know the range of the loop is null, set the 2411 -- appropriate flag to remove the loop entirely during 2412 -- expansion. 2413 2414 Set_Is_Null_Loop (Loop_Nod); 2415 2416 -- Here is where the loop could execute because of invalid 2417 -- values, so issue appropriate message and in this case we 2418 -- do not set the Is_Null_Loop flag since the loop may 2419 -- execute. 2420 2421 else 2422 Error_Msg_N 2423 ("??loop range may be null, loop may not execute", 2424 DS); 2425 Error_Msg_N 2426 ("??can only execute if invalid values are present", 2427 DS); 2428 end if; 2429 end if; 2430 2431 -- In either case, suppress warnings in the body of the loop, 2432 -- since it is likely that these warnings will be inappropriate 2433 -- if the loop never actually executes, which is likely. 2434 2435 Set_Suppress_Loop_Warnings (Loop_Nod); 2436 2437 -- The other case for a warning is a reverse loop where the 2438 -- upper bound is the integer literal zero or one, and the 2439 -- lower bound can be positive. 2440 2441 -- For example, we have 2442 2443 -- for J in reverse N .. 1 loop 2444 2445 -- In practice, this is very likely to be a case of reversing 2446 -- the bounds incorrectly in the range. 2447 2448 elsif Reverse_Present (N) 2449 and then Nkind (Original_Node (H)) = N_Integer_Literal 2450 and then 2451 (Intval (Original_Node (H)) = Uint_0 2452 or else Intval (Original_Node (H)) = Uint_1) 2453 then 2454 Error_Msg_N ("??loop range may be null", DS); 2455 Error_Msg_N ("\??bounds may be wrong way round", DS); 2456 end if; 2457 end; 2458 end if; 2459 end Analyze_Loop_Parameter_Specification; 2460 2461 ---------------------------- 2462 -- Analyze_Loop_Statement -- 2463 ---------------------------- 2464 2465 procedure Analyze_Loop_Statement (N : Node_Id) is 2466 2467 function Is_Container_Iterator (Iter : Node_Id) return Boolean; 2468 -- Given a loop iteration scheme, determine whether it is an Ada 2012 2469 -- container iteration. 2470 2471 function Is_Wrapped_In_Block (N : Node_Id) return Boolean; 2472 -- Determine whether node N is the sole statement of a block 2473 2474 --------------------------- 2475 -- Is_Container_Iterator -- 2476 --------------------------- 2477 2478 function Is_Container_Iterator (Iter : Node_Id) return Boolean is 2479 begin 2480 -- Infinite loop 2481 2482 if No (Iter) then 2483 return False; 2484 2485 -- While loop 2486 2487 elsif Present (Condition (Iter)) then 2488 return False; 2489 2490 -- for Def_Id in [reverse] Name loop 2491 -- for Def_Id [: Subtype_Indication] of [reverse] Name loop 2492 2493 elsif Present (Iterator_Specification (Iter)) then 2494 declare 2495 Nam : constant Node_Id := Name (Iterator_Specification (Iter)); 2496 Nam_Copy : Node_Id; 2497 2498 begin 2499 Nam_Copy := New_Copy_Tree (Nam); 2500 Set_Parent (Nam_Copy, Parent (Nam)); 2501 Preanalyze_Range (Nam_Copy); 2502 2503 -- The only two options here are iteration over a container or 2504 -- an array. 2505 2506 return not Is_Array_Type (Etype (Nam_Copy)); 2507 end; 2508 2509 -- for Def_Id in [reverse] Discrete_Subtype_Definition loop 2510 2511 else 2512 declare 2513 LP : constant Node_Id := Loop_Parameter_Specification (Iter); 2514 DS : constant Node_Id := Discrete_Subtype_Definition (LP); 2515 DS_Copy : Node_Id; 2516 2517 begin 2518 DS_Copy := New_Copy_Tree (DS); 2519 Set_Parent (DS_Copy, Parent (DS)); 2520 Preanalyze_Range (DS_Copy); 2521 2522 -- Check for a call to Iterate () 2523 2524 return 2525 Nkind (DS_Copy) = N_Function_Call 2526 and then Needs_Finalization (Etype (DS_Copy)); 2527 end; 2528 end if; 2529 end Is_Container_Iterator; 2530 2531 ------------------------- 2532 -- Is_Wrapped_In_Block -- 2533 ------------------------- 2534 2535 function Is_Wrapped_In_Block (N : Node_Id) return Boolean is 2536 HSS : constant Node_Id := Parent (N); 2537 2538 begin 2539 return 2540 Nkind (HSS) = N_Handled_Sequence_Of_Statements 2541 and then Nkind (Parent (HSS)) = N_Block_Statement 2542 and then First (Statements (HSS)) = N 2543 and then No (Next (First (Statements (HSS)))); 2544 end Is_Wrapped_In_Block; 2545 2546 -- Local declarations 2547 2548 Id : constant Node_Id := Identifier (N); 2549 Iter : constant Node_Id := Iteration_Scheme (N); 2550 Loc : constant Source_Ptr := Sloc (N); 2551 Ent : Entity_Id; 2552 2553 -- Start of processing for Analyze_Loop_Statement 2554 2555 begin 2556 if Present (Id) then 2557 2558 -- Make name visible, e.g. for use in exit statements. Loop labels 2559 -- are always considered to be referenced. 2560 2561 Analyze (Id); 2562 Ent := Entity (Id); 2563 2564 -- Guard against serious error (typically, a scope mismatch when 2565 -- semantic analysis is requested) by creating loop entity to 2566 -- continue analysis. 2567 2568 if No (Ent) then 2569 if Total_Errors_Detected /= 0 then 2570 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 2571 else 2572 raise Program_Error; 2573 end if; 2574 2575 else 2576 Generate_Reference (Ent, N, ' '); 2577 Generate_Definition (Ent); 2578 2579 -- If we found a label, mark its type. If not, ignore it, since it 2580 -- means we have a conflicting declaration, which would already 2581 -- have been diagnosed at declaration time. Set Label_Construct 2582 -- of the implicit label declaration, which is not created by the 2583 -- parser for generic units. 2584 2585 if Ekind (Ent) = E_Label then 2586 Set_Ekind (Ent, E_Loop); 2587 2588 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then 2589 Set_Label_Construct (Parent (Ent), N); 2590 end if; 2591 end if; 2592 end if; 2593 2594 -- Case of no identifier present 2595 2596 else 2597 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 2598 Set_Etype (Ent, Standard_Void_Type); 2599 Set_Parent (Ent, N); 2600 end if; 2601 2602 -- Iteration over a container in Ada 2012 involves the creation of a 2603 -- controlled iterator object. Wrap the loop in a block to ensure the 2604 -- timely finalization of the iterator and release of container locks. 2605 2606 if Ada_Version >= Ada_2012 2607 and then Is_Container_Iterator (Iter) 2608 and then not Is_Wrapped_In_Block (N) 2609 then 2610 Rewrite (N, 2611 Make_Block_Statement (Loc, 2612 Declarations => New_List, 2613 Handled_Statement_Sequence => 2614 Make_Handled_Sequence_Of_Statements (Loc, 2615 Statements => New_List (Relocate_Node (N))))); 2616 2617 Analyze (N); 2618 return; 2619 end if; 2620 2621 -- Kill current values on entry to loop, since statements in the body of 2622 -- the loop may have been executed before the loop is entered. Similarly 2623 -- we kill values after the loop, since we do not know that the body of 2624 -- the loop was executed. 2625 2626 Kill_Current_Values; 2627 Push_Scope (Ent); 2628 Analyze_Iteration_Scheme (Iter); 2629 2630 -- Check for following case which merits a warning if the type E of is 2631 -- a multi-dimensional array (and no explicit subscript ranges present). 2632 2633 -- for J in E'Range 2634 -- for K in E'Range 2635 2636 if Present (Iter) 2637 and then Present (Loop_Parameter_Specification (Iter)) 2638 then 2639 declare 2640 LPS : constant Node_Id := Loop_Parameter_Specification (Iter); 2641 DSD : constant Node_Id := 2642 Original_Node (Discrete_Subtype_Definition (LPS)); 2643 begin 2644 if Nkind (DSD) = N_Attribute_Reference 2645 and then Attribute_Name (DSD) = Name_Range 2646 and then No (Expressions (DSD)) 2647 then 2648 declare 2649 Typ : constant Entity_Id := Etype (Prefix (DSD)); 2650 begin 2651 if Is_Array_Type (Typ) 2652 and then Number_Dimensions (Typ) > 1 2653 and then Nkind (Parent (N)) = N_Loop_Statement 2654 and then Present (Iteration_Scheme (Parent (N))) 2655 then 2656 declare 2657 OIter : constant Node_Id := 2658 Iteration_Scheme (Parent (N)); 2659 OLPS : constant Node_Id := 2660 Loop_Parameter_Specification (OIter); 2661 ODSD : constant Node_Id := 2662 Original_Node (Discrete_Subtype_Definition (OLPS)); 2663 begin 2664 if Nkind (ODSD) = N_Attribute_Reference 2665 and then Attribute_Name (ODSD) = Name_Range 2666 and then No (Expressions (ODSD)) 2667 and then Etype (Prefix (ODSD)) = Typ 2668 then 2669 Error_Msg_Sloc := Sloc (ODSD); 2670 Error_Msg_N 2671 ("inner range same as outer range#??", DSD); 2672 end if; 2673 end; 2674 end if; 2675 end; 2676 end if; 2677 end; 2678 end if; 2679 2680 -- Analyze the statements of the body except in the case of an Ada 2012 2681 -- iterator with the expander active. In this case the expander will do 2682 -- a rewrite of the loop into a while loop. We will then analyze the 2683 -- loop body when we analyze this while loop. 2684 2685 -- We need to do this delay because if the container is for indefinite 2686 -- types the actual subtype of the components will only be determined 2687 -- when the cursor declaration is analyzed. 2688 2689 -- If the expander is not active, or in Alfa mode, then we want to 2690 -- analyze the loop body now even in the Ada 2012 iterator case, since 2691 -- the rewriting will not be done. Insert the loop variable in the 2692 -- current scope, if not done when analysing the iteration scheme. 2693 2694 if No (Iter) 2695 or else No (Iterator_Specification (Iter)) 2696 or else not Full_Expander_Active 2697 then 2698 if Present (Iter) 2699 and then Present (Iterator_Specification (Iter)) 2700 then 2701 declare 2702 Id : constant Entity_Id := 2703 Defining_Identifier (Iterator_Specification (Iter)); 2704 begin 2705 if Scope (Id) /= Current_Scope then 2706 Enter_Name (Id); 2707 end if; 2708 end; 2709 end if; 2710 2711 Analyze_Statements (Statements (N)); 2712 end if; 2713 2714 -- Finish up processing for the loop. We kill all current values, since 2715 -- in general we don't know if the statements in the loop have been 2716 -- executed. We could do a bit better than this with a loop that we 2717 -- know will execute at least once, but it's not worth the trouble and 2718 -- the front end is not in the business of flow tracing. 2719 2720 Process_End_Label (N, 'e', Ent); 2721 End_Scope; 2722 Kill_Current_Values; 2723 2724 -- Check for infinite loop. Skip check for generated code, since it 2725 -- justs waste time and makes debugging the routine called harder. 2726 2727 -- Note that we have to wait till the body of the loop is fully analyzed 2728 -- before making this call, since Check_Infinite_Loop_Warning relies on 2729 -- being able to use semantic visibility information to find references. 2730 2731 if Comes_From_Source (N) then 2732 Check_Infinite_Loop_Warning (N); 2733 end if; 2734 2735 -- Code after loop is unreachable if the loop has no WHILE or FOR and 2736 -- contains no EXIT statements within the body of the loop. 2737 2738 if No (Iter) and then not Has_Exit (Ent) then 2739 Check_Unreachable_Code (N); 2740 end if; 2741 end Analyze_Loop_Statement; 2742 2743 ---------------------------- 2744 -- Analyze_Null_Statement -- 2745 ---------------------------- 2746 2747 -- Note: the semantics of the null statement is implemented by a single 2748 -- null statement, too bad everything isn't as simple as this! 2749 2750 procedure Analyze_Null_Statement (N : Node_Id) is 2751 pragma Warnings (Off, N); 2752 begin 2753 null; 2754 end Analyze_Null_Statement; 2755 2756 ------------------------ 2757 -- Analyze_Statements -- 2758 ------------------------ 2759 2760 procedure Analyze_Statements (L : List_Id) is 2761 S : Node_Id; 2762 Lab : Entity_Id; 2763 2764 begin 2765 -- The labels declared in the statement list are reachable from 2766 -- statements in the list. We do this as a prepass so that any goto 2767 -- statement will be properly flagged if its target is not reachable. 2768 -- This is not required, but is nice behavior! 2769 2770 S := First (L); 2771 while Present (S) loop 2772 if Nkind (S) = N_Label then 2773 Analyze (Identifier (S)); 2774 Lab := Entity (Identifier (S)); 2775 2776 -- If we found a label mark it as reachable 2777 2778 if Ekind (Lab) = E_Label then 2779 Generate_Definition (Lab); 2780 Set_Reachable (Lab); 2781 2782 if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then 2783 Set_Label_Construct (Parent (Lab), S); 2784 end if; 2785 2786 -- If we failed to find a label, it means the implicit declaration 2787 -- of the label was hidden. A for-loop parameter can do this to 2788 -- a label with the same name inside the loop, since the implicit 2789 -- label declaration is in the innermost enclosing body or block 2790 -- statement. 2791 2792 else 2793 Error_Msg_Sloc := Sloc (Lab); 2794 Error_Msg_N 2795 ("implicit label declaration for & is hidden#", 2796 Identifier (S)); 2797 end if; 2798 end if; 2799 2800 Next (S); 2801 end loop; 2802 2803 -- Perform semantic analysis on all statements 2804 2805 Conditional_Statements_Begin; 2806 2807 S := First (L); 2808 while Present (S) loop 2809 Analyze (S); 2810 2811 -- Remove dimension in all statements 2812 2813 Remove_Dimension_In_Statement (S); 2814 Next (S); 2815 end loop; 2816 2817 Conditional_Statements_End; 2818 2819 -- Make labels unreachable. Visibility is not sufficient, because labels 2820 -- in one if-branch for example are not reachable from the other branch, 2821 -- even though their declarations are in the enclosing declarative part. 2822 2823 S := First (L); 2824 while Present (S) loop 2825 if Nkind (S) = N_Label then 2826 Set_Reachable (Entity (Identifier (S)), False); 2827 end if; 2828 2829 Next (S); 2830 end loop; 2831 end Analyze_Statements; 2832 2833 ---------------------------- 2834 -- Check_Unreachable_Code -- 2835 ---------------------------- 2836 2837 procedure Check_Unreachable_Code (N : Node_Id) is 2838 Error_Node : Node_Id; 2839 P : Node_Id; 2840 2841 begin 2842 if Is_List_Member (N) 2843 and then Comes_From_Source (N) 2844 then 2845 declare 2846 Nxt : Node_Id; 2847 2848 begin 2849 Nxt := Original_Node (Next (N)); 2850 2851 -- Skip past pragmas 2852 2853 while Nkind (Nxt) = N_Pragma loop 2854 Nxt := Original_Node (Next (Nxt)); 2855 end loop; 2856 2857 -- If a label follows us, then we never have dead code, since 2858 -- someone could branch to the label, so we just ignore it, unless 2859 -- we are in formal mode where goto statements are not allowed. 2860 2861 if Nkind (Nxt) = N_Label 2862 and then not Restriction_Check_Required (SPARK) 2863 then 2864 return; 2865 2866 -- Otherwise see if we have a real statement following us 2867 2868 elsif Present (Nxt) 2869 and then Comes_From_Source (Nxt) 2870 and then Is_Statement (Nxt) 2871 then 2872 -- Special very annoying exception. If we have a return that 2873 -- follows a raise, then we allow it without a warning, since 2874 -- the Ada RM annoyingly requires a useless return here! 2875 2876 if Nkind (Original_Node (N)) /= N_Raise_Statement 2877 or else Nkind (Nxt) /= N_Simple_Return_Statement 2878 then 2879 -- The rather strange shenanigans with the warning message 2880 -- here reflects the fact that Kill_Dead_Code is very good 2881 -- at removing warnings in deleted code, and this is one 2882 -- warning we would prefer NOT to have removed. 2883 2884 Error_Node := Nxt; 2885 2886 -- If we have unreachable code, analyze and remove the 2887 -- unreachable code, since it is useless and we don't 2888 -- want to generate junk warnings. 2889 2890 -- We skip this step if we are not in code generation mode. 2891 -- This is the one case where we remove dead code in the 2892 -- semantics as opposed to the expander, and we do not want 2893 -- to remove code if we are not in code generation mode, 2894 -- since this messes up the ASIS trees. 2895 2896 -- Note that one might react by moving the whole circuit to 2897 -- exp_ch5, but then we lose the warning in -gnatc mode. 2898 2899 if Operating_Mode = Generate_Code then 2900 loop 2901 Nxt := Next (N); 2902 2903 -- Quit deleting when we have nothing more to delete 2904 -- or if we hit a label (since someone could transfer 2905 -- control to a label, so we should not delete it). 2906 2907 exit when No (Nxt) or else Nkind (Nxt) = N_Label; 2908 2909 -- Statement/declaration is to be deleted 2910 2911 Analyze (Nxt); 2912 Remove (Nxt); 2913 Kill_Dead_Code (Nxt); 2914 end loop; 2915 end if; 2916 2917 -- Now issue the warning (or error in formal mode) 2918 2919 if Restriction_Check_Required (SPARK) then 2920 Check_SPARK_Restriction 2921 ("unreachable code is not allowed", Error_Node); 2922 else 2923 Error_Msg ("??unreachable code!", Sloc (Error_Node)); 2924 end if; 2925 end if; 2926 2927 -- If the unconditional transfer of control instruction is the 2928 -- last statement of a sequence, then see if our parent is one of 2929 -- the constructs for which we count unblocked exits, and if so, 2930 -- adjust the count. 2931 2932 else 2933 P := Parent (N); 2934 2935 -- Statements in THEN part or ELSE part of IF statement 2936 2937 if Nkind (P) = N_If_Statement then 2938 null; 2939 2940 -- Statements in ELSIF part of an IF statement 2941 2942 elsif Nkind (P) = N_Elsif_Part then 2943 P := Parent (P); 2944 pragma Assert (Nkind (P) = N_If_Statement); 2945 2946 -- Statements in CASE statement alternative 2947 2948 elsif Nkind (P) = N_Case_Statement_Alternative then 2949 P := Parent (P); 2950 pragma Assert (Nkind (P) = N_Case_Statement); 2951 2952 -- Statements in body of block 2953 2954 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 2955 and then Nkind (Parent (P)) = N_Block_Statement 2956 then 2957 null; 2958 2959 -- Statements in exception handler in a block 2960 2961 elsif Nkind (P) = N_Exception_Handler 2962 and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements 2963 and then Nkind (Parent (Parent (P))) = N_Block_Statement 2964 then 2965 null; 2966 2967 -- None of these cases, so return 2968 2969 else 2970 return; 2971 end if; 2972 2973 -- This was one of the cases we are looking for (i.e. the 2974 -- parent construct was IF, CASE or block) so decrement count. 2975 2976 Unblocked_Exit_Count := Unblocked_Exit_Count - 1; 2977 end if; 2978 end; 2979 end if; 2980 end Check_Unreachable_Code; 2981 2982 ---------------------- 2983 -- Preanalyze_Range -- 2984 ---------------------- 2985 2986 procedure Preanalyze_Range (R_Copy : Node_Id) is 2987 Save_Analysis : constant Boolean := Full_Analysis; 2988 Typ : Entity_Id; 2989 2990 begin 2991 Full_Analysis := False; 2992 Expander_Mode_Save_And_Set (False); 2993 2994 Analyze (R_Copy); 2995 2996 if Nkind (R_Copy) in N_Subexpr 2997 and then Is_Overloaded (R_Copy) 2998 then 2999 -- Apply preference rules for range of predefined integer types, or 3000 -- diagnose true ambiguity. 3001 3002 declare 3003 I : Interp_Index; 3004 It : Interp; 3005 Found : Entity_Id := Empty; 3006 3007 begin 3008 Get_First_Interp (R_Copy, I, It); 3009 while Present (It.Typ) loop 3010 if Is_Discrete_Type (It.Typ) then 3011 if No (Found) then 3012 Found := It.Typ; 3013 else 3014 if Scope (Found) = Standard_Standard then 3015 null; 3016 3017 elsif Scope (It.Typ) = Standard_Standard then 3018 Found := It.Typ; 3019 3020 else 3021 -- Both of them are user-defined 3022 3023 Error_Msg_N 3024 ("ambiguous bounds in range of iteration", R_Copy); 3025 Error_Msg_N ("\possible interpretations:", R_Copy); 3026 Error_Msg_NE ("\\} ", R_Copy, Found); 3027 Error_Msg_NE ("\\} ", R_Copy, It.Typ); 3028 exit; 3029 end if; 3030 end if; 3031 end if; 3032 3033 Get_Next_Interp (I, It); 3034 end loop; 3035 end; 3036 end if; 3037 3038 -- Subtype mark in iteration scheme 3039 3040 if Is_Entity_Name (R_Copy) 3041 and then Is_Type (Entity (R_Copy)) 3042 then 3043 null; 3044 3045 -- Expression in range, or Ada 2012 iterator 3046 3047 elsif Nkind (R_Copy) in N_Subexpr then 3048 Resolve (R_Copy); 3049 Typ := Etype (R_Copy); 3050 3051 if Is_Discrete_Type (Typ) then 3052 null; 3053 3054 -- Check that the resulting object is an iterable container 3055 3056 elsif Present (Find_Aspect (Typ, Aspect_Iterator_Element)) 3057 or else Present (Find_Aspect (Typ, Aspect_Constant_Indexing)) 3058 or else Present (Find_Aspect (Typ, Aspect_Variable_Indexing)) 3059 then 3060 null; 3061 3062 -- The expression may yield an implicit reference to an iterable 3063 -- container. Insert explicit dereference so that proper type is 3064 -- visible in the loop. 3065 3066 elsif Has_Implicit_Dereference (Etype (R_Copy)) then 3067 declare 3068 Disc : Entity_Id; 3069 3070 begin 3071 Disc := First_Discriminant (Typ); 3072 while Present (Disc) loop 3073 if Has_Implicit_Dereference (Disc) then 3074 Build_Explicit_Dereference (R_Copy, Disc); 3075 exit; 3076 end if; 3077 3078 Next_Discriminant (Disc); 3079 end loop; 3080 end; 3081 3082 end if; 3083 end if; 3084 3085 Expander_Mode_Restore; 3086 Full_Analysis := Save_Analysis; 3087 end Preanalyze_Range; 3088 3089end Sem_Ch5; 3090