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