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