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-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Einfo.Entities; use Einfo.Entities; 32with Einfo.Utils; use Einfo.Utils; 33with Errout; use Errout; 34with Expander; use Expander; 35with Exp_Ch6; use Exp_Ch6; 36with Exp_Tss; use Exp_Tss; 37with Exp_Util; use Exp_Util; 38with Freeze; use Freeze; 39with Ghost; use Ghost; 40with Lib; use Lib; 41with Lib.Xref; use Lib.Xref; 42with Namet; use Namet; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Opt; use Opt; 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 Sinfo.Nodes; use Sinfo.Nodes; 64with Sinfo.Utils; use Sinfo.Utils; 65with Targparm; use Targparm; 66with Tbuild; use Tbuild; 67with Ttypes; use Ttypes; 68with Uintp; use Uintp; 69 70package body Sem_Ch5 is 71 72 Current_Assignment : Node_Id := Empty; 73 -- This variable holds the node for an assignment that contains target 74 -- names. The corresponding flag has been set by the parser, and when 75 -- set the analysis of the RHS must be done with all expansion disabled, 76 -- because the assignment is reanalyzed after expansion has replaced all 77 -- occurrences of the target name appropriately. 78 79 Unblocked_Exit_Count : Nat := 0; 80 -- This variable is used when processing if statements, case statements, 81 -- and block statements. It counts the number of exit points that are not 82 -- blocked by unconditional transfer instructions: for IF and CASE, these 83 -- are the branches of the conditional; for a block, they are the statement 84 -- sequence of the block, and the statement sequences of any exception 85 -- handlers that are part of the block. When processing is complete, if 86 -- this count is zero, it means that control cannot fall through the IF, 87 -- CASE or block statement. This is used for the generation of warning 88 -- messages. This variable is recursively saved on entry to processing the 89 -- construct, and restored on exit. 90 91 function Has_Sec_Stack_Call (N : Node_Id) return Boolean; 92 -- N is the node for an arbitrary construct. This function searches the 93 -- construct N to see if any expressions within it contain function 94 -- calls that use the secondary stack, returning True if any such call 95 -- is found, and False otherwise. 96 97 procedure Preanalyze_Range (R_Copy : Node_Id); 98 -- Determine expected type of range or domain of iteration of Ada 2012 99 -- loop by analyzing separate copy. Do the analysis and resolution of the 100 -- copy of the bound(s) with expansion disabled, to prevent the generation 101 -- of finalization actions. This prevents memory leaks when the bounds 102 -- contain calls to functions returning controlled arrays or when the 103 -- domain of iteration is a container. 104 105 ------------------------ 106 -- Analyze_Assignment -- 107 ------------------------ 108 109 -- WARNING: This routine manages Ghost regions. Return statements must be 110 -- replaced by gotos which jump to the end of the routine and restore the 111 -- Ghost mode. 112 113 procedure Analyze_Assignment (N : Node_Id) is 114 Lhs : constant Node_Id := Name (N); 115 Rhs : Node_Id := Expression (N); 116 117 procedure Diagnose_Non_Variable_Lhs (N : Node_Id); 118 -- N is the node for the left hand side of an assignment, and it is not 119 -- a variable. This routine issues an appropriate diagnostic. 120 121 function Is_Protected_Part_Of_Constituent 122 (Nod : Node_Id) return Boolean; 123 -- Determine whether arbitrary node Nod denotes a Part_Of constituent of 124 -- a single protected type. 125 126 procedure Kill_Lhs; 127 -- This is called to kill current value settings of a simple variable 128 -- on the left hand side. We call it if we find any error in analyzing 129 -- the assignment, and at the end of processing before setting any new 130 -- current values in place. 131 132 procedure Set_Assignment_Type 133 (Opnd : Node_Id; 134 Opnd_Type : in out Entity_Id); 135 -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the 136 -- nominal subtype. This procedure is used to deal with cases where the 137 -- nominal subtype must be replaced by the actual subtype. 138 139 procedure Transform_BIP_Assignment (Typ : Entity_Id); 140 function Should_Transform_BIP_Assignment 141 (Typ : Entity_Id) return Boolean; 142 -- If the right-hand side of an assignment statement is a build-in-place 143 -- call we cannot build in place, so we insert a temp initialized with 144 -- the call, and transform the assignment statement to copy the temp. 145 -- Transform_BIP_Assignment does the tranformation, and 146 -- Should_Transform_BIP_Assignment determines whether we should. 147 -- The same goes for qualified expressions and conversions whose 148 -- operand is such a call. 149 -- 150 -- This is only for nonlimited types; assignment statements are illegal 151 -- for limited types, but are generated internally for aggregates and 152 -- init procs. These limited-type are not really assignment statements 153 -- -- conceptually, they are initializations, so should not be 154 -- transformed. 155 -- 156 -- Similarly, for nonlimited types, aggregates and init procs generate 157 -- assignment statements that are really initializations. These are 158 -- marked No_Ctrl_Actions. 159 160 function Within_Function return Boolean; 161 -- Determine whether the current scope is a function or appears within 162 -- one. 163 164 ------------------------------- 165 -- Diagnose_Non_Variable_Lhs -- 166 ------------------------------- 167 168 procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is 169 begin 170 -- Not worth posting another error if left hand side already flagged 171 -- as being illegal in some respect. 172 173 if Error_Posted (N) then 174 return; 175 176 -- Some special bad cases of entity names 177 178 elsif Is_Entity_Name (N) then 179 declare 180 Ent : constant Entity_Id := Entity (N); 181 182 begin 183 if Ekind (Ent) = E_Loop_Parameter 184 or else Is_Loop_Parameter (Ent) 185 then 186 Error_Msg_N ("assignment to loop parameter not allowed", N); 187 return; 188 189 elsif Ekind (Ent) = E_In_Parameter then 190 Error_Msg_N 191 ("assignment to IN mode parameter not allowed", N); 192 return; 193 194 -- Renamings of protected private components are turned into 195 -- constants when compiling a protected function. In the case 196 -- of single protected types, the private component appears 197 -- directly. 198 199 elsif (Is_Prival (Ent) and then Within_Function) 200 or else Is_Protected_Component (Ent) 201 then 202 Error_Msg_N 203 ("protected function cannot modify its protected object", 204 N); 205 return; 206 end if; 207 end; 208 209 -- For indexed components, test prefix if it is in array. We do not 210 -- want to recurse for cases where the prefix is a pointer, since we 211 -- may get a message confusing the pointer and what it references. 212 213 elsif Nkind (N) = N_Indexed_Component 214 and then Is_Array_Type (Etype (Prefix (N))) 215 then 216 Diagnose_Non_Variable_Lhs (Prefix (N)); 217 return; 218 219 -- Another special case for assignment to discriminant 220 221 elsif Nkind (N) = N_Selected_Component then 222 if Present (Entity (Selector_Name (N))) 223 and then Ekind (Entity (Selector_Name (N))) = E_Discriminant 224 then 225 Error_Msg_N ("assignment to discriminant not allowed", N); 226 return; 227 228 -- For selection from record, diagnose prefix, but note that again 229 -- we only do this for a record, not e.g. for a pointer. 230 231 elsif Is_Record_Type (Etype (Prefix (N))) then 232 Diagnose_Non_Variable_Lhs (Prefix (N)); 233 return; 234 end if; 235 end if; 236 237 -- If we fall through, we have no special message to issue 238 239 Error_Msg_N ("left hand side of assignment must be a variable", N); 240 end Diagnose_Non_Variable_Lhs; 241 242 -------------------------------------- 243 -- Is_Protected_Part_Of_Constituent -- 244 -------------------------------------- 245 246 function Is_Protected_Part_Of_Constituent 247 (Nod : Node_Id) return Boolean 248 is 249 Encap_Id : Entity_Id; 250 Var_Id : Entity_Id; 251 252 begin 253 -- Abstract states and variables may act as Part_Of constituents of 254 -- single protected types, however only variables can be modified by 255 -- an assignment. 256 257 if Is_Entity_Name (Nod) then 258 Var_Id := Entity (Nod); 259 260 if Present (Var_Id) and then Ekind (Var_Id) = E_Variable then 261 Encap_Id := Encapsulating_State (Var_Id); 262 263 -- To qualify, the node must denote a reference to a variable 264 -- whose encapsulating state is a single protected object. 265 266 return 267 Present (Encap_Id) 268 and then Is_Single_Protected_Object (Encap_Id); 269 end if; 270 end if; 271 272 return False; 273 end Is_Protected_Part_Of_Constituent; 274 275 -------------- 276 -- Kill_Lhs -- 277 -------------- 278 279 procedure Kill_Lhs is 280 begin 281 if Is_Entity_Name (Lhs) then 282 declare 283 Ent : constant Entity_Id := Entity (Lhs); 284 begin 285 if Present (Ent) then 286 Kill_Current_Values (Ent); 287 end if; 288 end; 289 end if; 290 end Kill_Lhs; 291 292 ------------------------- 293 -- Set_Assignment_Type -- 294 ------------------------- 295 296 procedure Set_Assignment_Type 297 (Opnd : Node_Id; 298 Opnd_Type : in out Entity_Id) 299 is 300 Decl : Node_Id; 301 302 begin 303 Require_Entity (Opnd); 304 305 -- If the assignment operand is an in-out or out parameter, then we 306 -- get the actual subtype (needed for the unconstrained case). If the 307 -- operand is the actual in an entry declaration, then within the 308 -- accept statement it is replaced with a local renaming, which may 309 -- also have an actual subtype. 310 311 if Is_Entity_Name (Opnd) 312 and then (Ekind (Entity (Opnd)) in E_Out_Parameter 313 | E_In_Out_Parameter 314 | E_Generic_In_Out_Parameter 315 or else 316 (Ekind (Entity (Opnd)) = E_Variable 317 and then Nkind (Parent (Entity (Opnd))) = 318 N_Object_Renaming_Declaration 319 and then Nkind (Parent (Parent (Entity (Opnd)))) = 320 N_Accept_Statement)) 321 then 322 Opnd_Type := Get_Actual_Subtype (Opnd); 323 324 -- If assignment operand is a component reference, then we get the 325 -- actual subtype of the component for the unconstrained case. 326 327 elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference 328 and then not Is_Unchecked_Union (Opnd_Type) 329 then 330 Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); 331 332 if Present (Decl) then 333 Insert_Action (N, Decl); 334 Mark_Rewrite_Insertion (Decl); 335 Analyze (Decl); 336 Opnd_Type := Defining_Identifier (Decl); 337 Set_Etype (Opnd, Opnd_Type); 338 Freeze_Itype (Opnd_Type, N); 339 340 elsif Is_Constrained (Etype (Opnd)) then 341 Opnd_Type := Etype (Opnd); 342 end if; 343 344 -- For slice, use the constrained subtype created for the slice 345 346 elsif Nkind (Opnd) = N_Slice then 347 Opnd_Type := Etype (Opnd); 348 end if; 349 end Set_Assignment_Type; 350 351 ------------------------------------- 352 -- Should_Transform_BIP_Assignment -- 353 ------------------------------------- 354 355 function Should_Transform_BIP_Assignment 356 (Typ : Entity_Id) return Boolean 357 is 358 begin 359 if Expander_Active 360 and then not Is_Limited_View (Typ) 361 and then Is_Build_In_Place_Result_Type (Typ) 362 and then not No_Ctrl_Actions (N) 363 then 364 -- This function is called early, before name resolution is 365 -- complete, so we have to deal with things that might turn into 366 -- function calls later. N_Function_Call and N_Op nodes are the 367 -- obvious case. An N_Identifier or N_Expanded_Name is a 368 -- parameterless function call if it denotes a function. 369 -- Finally, an attribute reference can be a function call. 370 371 declare 372 Unqual_Rhs : constant Node_Id := Unqual_Conv (Rhs); 373 begin 374 case Nkind (Unqual_Rhs) is 375 when N_Function_Call 376 | N_Op 377 => 378 return True; 379 380 when N_Expanded_Name 381 | N_Identifier 382 => 383 return 384 Ekind (Entity (Unqual_Rhs)) in E_Function | E_Operator; 385 386 -- T'Input will turn into a call whose result type is T 387 388 when N_Attribute_Reference => 389 return Attribute_Name (Unqual_Rhs) = Name_Input; 390 391 when others => 392 return False; 393 end case; 394 end; 395 else 396 return False; 397 end if; 398 end Should_Transform_BIP_Assignment; 399 400 ------------------------------ 401 -- Transform_BIP_Assignment -- 402 ------------------------------ 403 404 procedure Transform_BIP_Assignment (Typ : Entity_Id) is 405 406 -- Tranform "X : [constant] T := F (...);" into: 407 -- 408 -- Temp : constant T := F (...); 409 -- X := Temp; 410 411 Loc : constant Source_Ptr := Sloc (N); 412 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); 413 Obj_Decl : constant Node_Id := 414 Make_Object_Declaration (Loc, 415 Defining_Identifier => Def_Id, 416 Constant_Present => True, 417 Object_Definition => New_Occurrence_Of (Typ, Loc), 418 Expression => Rhs, 419 Has_Init_Expression => True); 420 421 begin 422 Set_Etype (Def_Id, Typ); 423 Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); 424 425 -- At this point, Rhs is no longer equal to Expression (N), so: 426 427 Rhs := Expression (N); 428 429 Insert_Action (N, Obj_Decl); 430 end Transform_BIP_Assignment; 431 432 --------------------- 433 -- Within_Function -- 434 --------------------- 435 436 function Within_Function return Boolean is 437 Scop_Id : constant Entity_Id := Current_Scope; 438 439 begin 440 if Ekind (Scop_Id) = E_Function then 441 return True; 442 443 elsif Ekind (Enclosing_Dynamic_Scope (Scop_Id)) = E_Function then 444 return True; 445 end if; 446 447 return False; 448 end Within_Function; 449 450 -- Local variables 451 452 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 453 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 454 -- Save the Ghost-related attributes to restore on exit 455 456 T1 : Entity_Id; 457 T2 : Entity_Id; 458 459 Save_Full_Analysis : Boolean := False; 460 -- Force initialization to facilitate static analysis 461 462 -- Start of processing for Analyze_Assignment 463 464 begin 465 Mark_Coextensions (N, Rhs); 466 467 -- Preserve relevant elaboration-related attributes of the context which 468 -- are no longer available or very expensive to recompute once analysis, 469 -- resolution, and expansion are over. 470 471 Mark_Elaboration_Attributes 472 (N_Id => N, 473 Checks => True, 474 Modes => True); 475 476 -- An assignment statement is Ghost when the left hand side denotes a 477 -- Ghost entity. Set the mode now to ensure that any nodes generated 478 -- during analysis and expansion are properly marked as Ghost. 479 480 Mark_And_Set_Ghost_Assignment (N); 481 482 if Has_Target_Names (N) then 483 pragma Assert (No (Current_Assignment)); 484 Current_Assignment := N; 485 Expander_Mode_Save_And_Set (False); 486 Save_Full_Analysis := Full_Analysis; 487 Full_Analysis := False; 488 end if; 489 490 Analyze (Lhs); 491 Analyze (Rhs); 492 493 -- Ensure that we never do an assignment on a variable marked as 494 -- Is_Safe_To_Reevaluate. 495 496 pragma Assert 497 (not Is_Entity_Name (Lhs) 498 or else Ekind (Entity (Lhs)) /= E_Variable 499 or else not Is_Safe_To_Reevaluate (Entity (Lhs))); 500 501 -- Start type analysis for assignment 502 503 T1 := Etype (Lhs); 504 505 -- In the most general case, both Lhs and Rhs can be overloaded, and we 506 -- must compute the intersection of the possible types on each side. 507 508 if Is_Overloaded (Lhs) then 509 declare 510 I : Interp_Index; 511 It : Interp; 512 513 begin 514 T1 := Any_Type; 515 Get_First_Interp (Lhs, I, It); 516 517 while Present (It.Typ) loop 518 519 -- An indexed component with generalized indexing is always 520 -- overloaded with the corresponding dereference. Discard the 521 -- interpretation that yields a reference type, which is not 522 -- assignable. 523 524 if Nkind (Lhs) = N_Indexed_Component 525 and then Present (Generalized_Indexing (Lhs)) 526 and then Has_Implicit_Dereference (It.Typ) 527 then 528 null; 529 530 -- This may be a call to a parameterless function through an 531 -- implicit dereference, so discard interpretation as well. 532 533 elsif Is_Entity_Name (Lhs) 534 and then Has_Implicit_Dereference (It.Typ) 535 then 536 null; 537 538 elsif Has_Compatible_Type (Rhs, It.Typ) then 539 if T1 = Any_Type then 540 T1 := It.Typ; 541 else 542 -- An explicit dereference is overloaded if the prefix 543 -- is. Try to remove the ambiguity on the prefix, the 544 -- error will be posted there if the ambiguity is real. 545 546 if Nkind (Lhs) = N_Explicit_Dereference then 547 declare 548 PI : Interp_Index; 549 PI1 : Interp_Index := 0; 550 PIt : Interp; 551 Found : Boolean; 552 553 begin 554 Found := False; 555 Get_First_Interp (Prefix (Lhs), PI, PIt); 556 557 while Present (PIt.Typ) loop 558 if Is_Access_Type (PIt.Typ) 559 and then Has_Compatible_Type 560 (Rhs, Designated_Type (PIt.Typ)) 561 then 562 if Found then 563 PIt := 564 Disambiguate (Prefix (Lhs), 565 PI1, PI, Any_Type); 566 567 if PIt = No_Interp then 568 Error_Msg_N 569 ("ambiguous left-hand side in " 570 & "assignment", Lhs); 571 exit; 572 else 573 Resolve (Prefix (Lhs), PIt.Typ); 574 end if; 575 576 exit; 577 else 578 Found := True; 579 PI1 := PI; 580 end if; 581 end if; 582 583 Get_Next_Interp (PI, PIt); 584 end loop; 585 end; 586 587 else 588 Error_Msg_N 589 ("ambiguous left-hand side in assignment", Lhs); 590 exit; 591 end if; 592 end if; 593 end if; 594 595 Get_Next_Interp (I, It); 596 end loop; 597 end; 598 599 if T1 = Any_Type then 600 Error_Msg_N 601 ("no valid types for left-hand side for assignment", Lhs); 602 Kill_Lhs; 603 goto Leave; 604 end if; 605 end if; 606 607 -- Deal with build-in-place calls for nonlimited types. We don't do this 608 -- later, because resolving the rhs tranforms it incorrectly for build- 609 -- in-place. 610 611 if Should_Transform_BIP_Assignment (Typ => T1) then 612 613 -- In certain cases involving user-defined concatenation operators, 614 -- we need to resolve the right-hand side before transforming the 615 -- assignment. 616 617 case Nkind (Unqual_Conv (Rhs)) is 618 when N_Function_Call => 619 declare 620 Actual : Node_Id := 621 First (Parameter_Associations (Unqual_Conv (Rhs))); 622 Actual_Exp : Node_Id; 623 624 begin 625 while Present (Actual) loop 626 if Nkind (Actual) = N_Parameter_Association then 627 Actual_Exp := Explicit_Actual_Parameter (Actual); 628 else 629 Actual_Exp := Actual; 630 end if; 631 632 if Nkind (Actual_Exp) = N_Op_Concat then 633 Resolve (Rhs, T1); 634 exit; 635 end if; 636 637 Next (Actual); 638 end loop; 639 end; 640 641 when N_Attribute_Reference 642 | N_Expanded_Name 643 | N_Identifier 644 | N_Op 645 => 646 null; 647 648 when others => 649 raise Program_Error; 650 end case; 651 652 Transform_BIP_Assignment (Typ => T1); 653 end if; 654 655 pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); 656 657 -- The resulting assignment type is T1, so now we will resolve the left 658 -- hand side of the assignment using this determined type. 659 660 Resolve (Lhs, T1); 661 662 -- Cases where Lhs is not a variable. In an instance or an inlined body 663 -- no need for further check because assignment was legal in template. 664 665 if In_Inlined_Body then 666 null; 667 668 elsif not Is_Variable (Lhs) then 669 670 -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a 671 -- protected object. 672 673 declare 674 Ent : Entity_Id; 675 S : Entity_Id; 676 677 begin 678 if Ada_Version >= Ada_2005 then 679 680 -- Handle chains of renamings 681 682 Ent := Lhs; 683 while Nkind (Ent) in N_Has_Entity 684 and then Present (Entity (Ent)) 685 and then Is_Object (Entity (Ent)) 686 and then Present (Renamed_Object (Entity (Ent))) 687 loop 688 Ent := Renamed_Object (Entity (Ent)); 689 end loop; 690 691 if (Nkind (Ent) = N_Attribute_Reference 692 and then Attribute_Name (Ent) = Name_Priority) 693 694 -- Renamings of the attribute Priority applied to protected 695 -- objects have been previously expanded into calls to the 696 -- Get_Ceiling run-time subprogram. 697 698 or else Is_Expanded_Priority_Attribute (Ent) 699 then 700 -- The enclosing subprogram cannot be a protected function 701 702 S := Current_Scope; 703 while not (Is_Subprogram (S) 704 and then Convention (S) = Convention_Protected) 705 and then S /= Standard_Standard 706 loop 707 S := Scope (S); 708 end loop; 709 710 if Ekind (S) = E_Function 711 and then Convention (S) = Convention_Protected 712 then 713 Error_Msg_N 714 ("protected function cannot modify its protected " & 715 "object", 716 Lhs); 717 end if; 718 719 -- Changes of the ceiling priority of the protected object 720 -- are only effective if the Ceiling_Locking policy is in 721 -- effect (AARM D.5.2 (5/2)). 722 723 if Locking_Policy /= 'C' then 724 Error_Msg_N 725 ("assignment to the attribute PRIORITY has no effect??", 726 Lhs); 727 Error_Msg_N 728 ("\since no Locking_Policy has been specified??", Lhs); 729 end if; 730 731 goto Leave; 732 end if; 733 end if; 734 end; 735 736 Diagnose_Non_Variable_Lhs (Lhs); 737 goto Leave; 738 739 -- Error of assigning to limited type. We do however allow this in 740 -- certain cases where the front end generates the assignments. 741 742 elsif Is_Limited_Type (T1) 743 and then not Assignment_OK (Lhs) 744 and then not Assignment_OK (Original_Node (Lhs)) 745 then 746 -- CPP constructors can only be called in declarations 747 748 if Is_CPP_Constructor_Call (Rhs) then 749 Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs); 750 else 751 Error_Msg_N 752 ("left hand of assignment must not be limited type", Lhs); 753 Explain_Limited_Type (T1, Lhs); 754 end if; 755 756 goto Leave; 757 758 -- A class-wide type may be a limited view. This illegal case is not 759 -- caught by previous checks. 760 761 elsif Ekind (T1) = E_Class_Wide_Type and then From_Limited_With (T1) then 762 Error_Msg_NE ("invalid use of limited view of&", Lhs, T1); 763 goto Leave; 764 765 -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be 766 -- abstract. This is only checked when the assignment Comes_From_Source, 767 -- because in some cases the expander generates such assignments (such 768 -- in the _assign operation for an abstract type). 769 770 elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then 771 Error_Msg_N 772 ("target of assignment operation must not be abstract", Lhs); 773 end if; 774 775 -- Variables which are Part_Of constituents of single protected types 776 -- behave in similar fashion to protected components. Such variables 777 -- cannot be modified by protected functions. 778 779 if Is_Protected_Part_Of_Constituent (Lhs) and then Within_Function then 780 Error_Msg_N 781 ("protected function cannot modify its protected object", Lhs); 782 end if; 783 784 -- Resolution may have updated the subtype, in case the left-hand side 785 -- is a private protected component. Use the correct subtype to avoid 786 -- scoping issues in the back-end. 787 788 T1 := Etype (Lhs); 789 790 -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete 791 -- type. For example: 792 793 -- limited with P; 794 -- package Pkg is 795 -- type Acc is access P.T; 796 -- end Pkg; 797 798 -- with Pkg; use Acc; 799 -- procedure Example is 800 -- A, B : Acc; 801 -- begin 802 -- A.all := B.all; -- ERROR 803 -- end Example; 804 805 if Nkind (Lhs) = N_Explicit_Dereference 806 and then Ekind (T1) = E_Incomplete_Type 807 then 808 Error_Msg_N ("invalid use of incomplete type", Lhs); 809 Kill_Lhs; 810 goto Leave; 811 end if; 812 813 -- Now we can complete the resolution of the right hand side 814 815 Set_Assignment_Type (Lhs, T1); 816 817 -- If the target of the assignment is an entity of a mutable type and 818 -- the expression is a conditional expression, its alternatives can be 819 -- of different subtypes of the nominal type of the LHS, so they must be 820 -- resolved with the base type, given that their subtype may differ from 821 -- that of the target mutable object. 822 823 if Is_Entity_Name (Lhs) 824 and then Is_Assignable (Entity (Lhs)) 825 and then Is_Composite_Type (T1) 826 and then not Is_Constrained (Etype (Entity (Lhs))) 827 and then Nkind (Rhs) in N_If_Expression | N_Case_Expression 828 then 829 Resolve (Rhs, Base_Type (T1)); 830 831 else 832 Resolve (Rhs, T1); 833 end if; 834 835 -- This is the point at which we check for an unset reference 836 837 Check_Unset_Reference (Rhs); 838 Check_Unprotected_Access (Lhs, Rhs); 839 840 -- Remaining steps are skipped if Rhs was syntactically in error 841 842 if Rhs = Error then 843 Kill_Lhs; 844 goto Leave; 845 end if; 846 847 T2 := Etype (Rhs); 848 849 if not Covers (T1, T2) then 850 Wrong_Type (Rhs, Etype (Lhs)); 851 Kill_Lhs; 852 goto Leave; 853 end if; 854 855 -- Ada 2005 (AI-326): In case of explicit dereference of incomplete 856 -- types, use the non-limited view if available 857 858 if Nkind (Rhs) = N_Explicit_Dereference 859 and then Is_Tagged_Type (T2) 860 and then Has_Non_Limited_View (T2) 861 then 862 T2 := Non_Limited_View (T2); 863 end if; 864 865 Set_Assignment_Type (Rhs, T2); 866 867 if Total_Errors_Detected /= 0 then 868 if No (T1) then 869 T1 := Any_Type; 870 end if; 871 872 if No (T2) then 873 T2 := Any_Type; 874 end if; 875 end if; 876 877 if T1 = Any_Type or else T2 = Any_Type then 878 Kill_Lhs; 879 goto Leave; 880 end if; 881 882 -- If the rhs is class-wide or dynamically tagged, then require the lhs 883 -- to be class-wide. The case where the rhs is a dynamically tagged call 884 -- to a dispatching operation with a controlling access result is 885 -- excluded from this check, since the target has an access type (and 886 -- no tag propagation occurs in that case). 887 888 if (Is_Class_Wide_Type (T2) 889 or else (Is_Dynamically_Tagged (Rhs) 890 and then not Is_Access_Type (T1))) 891 and then not Is_Class_Wide_Type (T1) 892 then 893 Error_Msg_N ("dynamically tagged expression not allowed!", Rhs); 894 895 elsif Is_Class_Wide_Type (T1) 896 and then not Is_Class_Wide_Type (T2) 897 and then not Is_Tag_Indeterminate (Rhs) 898 and then not Is_Dynamically_Tagged (Rhs) 899 then 900 Error_Msg_N ("dynamically tagged expression required!", Rhs); 901 end if; 902 903 -- Propagate the tag from a class-wide target to the rhs when the rhs 904 -- is a tag-indeterminate call. 905 906 if Is_Tag_Indeterminate (Rhs) then 907 if Is_Class_Wide_Type (T1) then 908 Propagate_Tag (Lhs, Rhs); 909 910 elsif Nkind (Rhs) = N_Function_Call 911 and then Is_Entity_Name (Name (Rhs)) 912 and then Is_Abstract_Subprogram (Entity (Name (Rhs))) 913 then 914 Error_Msg_N 915 ("call to abstract function must be dispatching", Name (Rhs)); 916 917 elsif Nkind (Rhs) = N_Qualified_Expression 918 and then Nkind (Expression (Rhs)) = N_Function_Call 919 and then Is_Entity_Name (Name (Expression (Rhs))) 920 and then 921 Is_Abstract_Subprogram (Entity (Name (Expression (Rhs)))) 922 then 923 Error_Msg_N 924 ("call to abstract function must be dispatching", 925 Name (Expression (Rhs))); 926 end if; 927 end if; 928 929 -- Ada 2005 (AI-385): When the lhs type is an anonymous access type, 930 -- apply an implicit conversion of the rhs to that type to force 931 -- appropriate static and run-time accessibility checks. This applies 932 -- as well to anonymous access-to-subprogram types that are component 933 -- subtypes or formal parameters. 934 935 if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then 936 if Is_Local_Anonymous_Access (T1) 937 or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type 938 939 -- Handle assignment to an Ada 2012 stand-alone object 940 -- of an anonymous access type. 941 942 or else (Ekind (T1) = E_Anonymous_Access_Type 943 and then Nkind (Associated_Node_For_Itype (T1)) = 944 N_Object_Declaration) 945 946 then 947 Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); 948 Analyze_And_Resolve (Rhs, T1); 949 end if; 950 end if; 951 952 -- Ada 2005 (AI-231): Assignment to not null variable 953 954 if Ada_Version >= Ada_2005 955 and then Can_Never_Be_Null (T1) 956 and then not Assignment_OK (Lhs) 957 then 958 -- Case where we know the right hand side is null 959 960 if Known_Null (Rhs) then 961 Apply_Compile_Time_Constraint_Error 962 (N => Rhs, 963 Msg => 964 "(Ada 2005) NULL not allowed in null-excluding objects??", 965 Reason => CE_Null_Not_Allowed); 966 967 -- We still mark this as a possible modification, that's necessary 968 -- to reset Is_True_Constant, and desirable for xref purposes. 969 970 Note_Possible_Modification (Lhs, Sure => True); 971 goto Leave; 972 973 -- If we know the right hand side is non-null, then we convert to the 974 -- target type, since we don't need a run time check in that case. 975 976 elsif not Can_Never_Be_Null (T2) then 977 Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); 978 Analyze_And_Resolve (Rhs, T1); 979 end if; 980 end if; 981 982 if Is_Scalar_Type (T1) then 983 declare 984 985 function Omit_Range_Check_For_Streaming return Boolean; 986 -- Return True if this assignment statement is the expansion of 987 -- a Some_Scalar_Type'Read procedure call such that all conditions 988 -- of 13.3.2(35)'s "no check is made" rule are met. 989 990 ------------------------------------ 991 -- Omit_Range_Check_For_Streaming -- 992 ------------------------------------ 993 994 function Omit_Range_Check_For_Streaming return Boolean is 995 begin 996 -- Have we got an implicitly generated assignment to a 997 -- component of a composite object? If not, return False. 998 999 if Comes_From_Source (N) 1000 or else Serious_Errors_Detected > 0 1001 or else Nkind (Lhs) 1002 not in N_Selected_Component | N_Indexed_Component 1003 then 1004 return False; 1005 end if; 1006 1007 declare 1008 Pref : constant Node_Id := Prefix (Lhs); 1009 begin 1010 -- Are we in the implicitly-defined Read subprogram 1011 -- for a composite type, reading the value of a scalar 1012 -- component from the stream? If not, return False. 1013 1014 if Nkind (Pref) /= N_Identifier 1015 or else not Is_TSS (Scope (Entity (Pref)), TSS_Stream_Read) 1016 then 1017 return False; 1018 end if; 1019 1020 -- Return False if Default_Value or Default_Component_Value 1021 -- aspect applies. 1022 1023 if Has_Default_Aspect (Etype (Lhs)) 1024 or else Has_Default_Aspect (Etype (Pref)) 1025 then 1026 return False; 1027 1028 -- Are we assigning to a record component (as opposed to 1029 -- an array component)? 1030 1031 elsif Nkind (Lhs) = N_Selected_Component then 1032 1033 -- Are we assigning to a nondiscriminant component 1034 -- that lacks a default initial value expression? 1035 -- If so, return True. 1036 1037 declare 1038 Comp_Id : constant Entity_Id := 1039 Original_Record_Component 1040 (Entity (Selector_Name (Lhs))); 1041 begin 1042 if Ekind (Comp_Id) = E_Component 1043 and then Nkind (Parent (Comp_Id)) 1044 = N_Component_Declaration 1045 and then 1046 not Present (Expression (Parent (Comp_Id))) 1047 then 1048 return True; 1049 end if; 1050 return False; 1051 end; 1052 1053 -- We are assigning to a component of an array 1054 -- (and we tested for both Default_Value and 1055 -- Default_Component_Value above), so return True. 1056 1057 else 1058 pragma Assert (Nkind (Lhs) = N_Indexed_Component); 1059 return True; 1060 end if; 1061 end; 1062 end Omit_Range_Check_For_Streaming; 1063 1064 begin 1065 if not Omit_Range_Check_For_Streaming then 1066 Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); 1067 end if; 1068 end; 1069 1070 -- For array types, verify that lengths match. If the right hand side 1071 -- is a function call that has been inlined, the assignment has been 1072 -- rewritten as a block, and the constraint check will be applied to the 1073 -- assignment within the block. 1074 1075 elsif Is_Array_Type (T1) 1076 and then (Nkind (Rhs) /= N_Type_Conversion 1077 or else Is_Constrained (Etype (Rhs))) 1078 and then (Nkind (Rhs) /= N_Function_Call 1079 or else Nkind (N) /= N_Block_Statement) 1080 then 1081 -- Assignment verifies that the length of the Lhs and Rhs are equal, 1082 -- but of course the indexes do not have to match. If the right-hand 1083 -- side is a type conversion to an unconstrained type, a length check 1084 -- is performed on the expression itself during expansion. In rare 1085 -- cases, the redundant length check is computed on an index type 1086 -- with a different representation, triggering incorrect code in the 1087 -- back end. 1088 1089 Apply_Length_Check_On_Assignment (Rhs, Etype (Lhs), Lhs); 1090 1091 else 1092 -- Discriminant checks are applied in the course of expansion 1093 1094 null; 1095 end if; 1096 1097 -- Note: modifications of the Lhs may only be recorded after 1098 -- checks have been applied. 1099 1100 Note_Possible_Modification (Lhs, Sure => True); 1101 1102 -- ??? a real accessibility check is needed when ??? 1103 1104 -- Post warning for redundant assignment or variable to itself 1105 1106 if Warn_On_Redundant_Constructs 1107 1108 -- We only warn for source constructs 1109 1110 and then Comes_From_Source (N) 1111 1112 -- Where the object is the same on both sides 1113 1114 and then Same_Object (Lhs, Original_Node (Rhs)) 1115 1116 -- But exclude the case where the right side was an operation that 1117 -- got rewritten (e.g. JUNK + K, where K was known to be zero). We 1118 -- don't want to warn in such a case, since it is reasonable to write 1119 -- such expressions especially when K is defined symbolically in some 1120 -- other package. 1121 1122 and then Nkind (Original_Node (Rhs)) not in N_Op 1123 then 1124 if Nkind (Lhs) in N_Has_Entity then 1125 Error_Msg_NE -- CODEFIX 1126 ("?r?useless assignment of & to itself!", N, Entity (Lhs)); 1127 else 1128 Error_Msg_N -- CODEFIX 1129 ("?r?useless assignment of object to itself!", N); 1130 end if; 1131 end if; 1132 1133 -- Check for non-allowed composite assignment 1134 1135 if not Support_Composite_Assign_On_Target 1136 and then (Is_Array_Type (T1) or else Is_Record_Type (T1)) 1137 and then (not Has_Size_Clause (T1) 1138 or else Esize (T1) > Ttypes.System_Max_Integer_Size) 1139 then 1140 Error_Msg_CRT ("composite assignment", N); 1141 end if; 1142 1143 -- Check elaboration warning for left side if not in elab code 1144 1145 if Legacy_Elaboration_Checks 1146 and not In_Subprogram_Or_Concurrent_Unit 1147 then 1148 Check_Elab_Assign (Lhs); 1149 end if; 1150 1151 -- Save the scenario for later examination by the ABE Processing phase 1152 1153 Record_Elaboration_Scenario (N); 1154 1155 -- Set Referenced_As_LHS if appropriate. We only set this flag if the 1156 -- assignment is a source assignment in the extended main source unit. 1157 -- We are not interested in any reference information outside this 1158 -- context, or in compiler generated assignment statements. 1159 1160 if Comes_From_Source (N) 1161 and then In_Extended_Main_Source_Unit (Lhs) 1162 then 1163 Set_Referenced_Modified (Lhs, Out_Param => False); 1164 end if; 1165 1166 -- RM 7.3.2 (12/3): An assignment to a view conversion (from a type to 1167 -- one of its ancestors) requires an invariant check. Apply check only 1168 -- if expression comes from source, otherwise it will be applied when 1169 -- value is assigned to source entity. This is not done in GNATprove 1170 -- mode, as GNATprove handles invariant checks itself. 1171 1172 if Nkind (Lhs) = N_Type_Conversion 1173 and then Has_Invariants (Etype (Expression (Lhs))) 1174 and then Comes_From_Source (Expression (Lhs)) 1175 and then not GNATprove_Mode 1176 then 1177 Insert_After (N, Make_Invariant_Call (Expression (Lhs))); 1178 end if; 1179 1180 -- Final step. If left side is an entity, then we may be able to reset 1181 -- the current tracked values to new safe values. We only have something 1182 -- to do if the left side is an entity name, and expansion has not 1183 -- modified the node into something other than an assignment, and of 1184 -- course we only capture values if it is safe to do so. 1185 1186 if Is_Entity_Name (Lhs) 1187 and then Nkind (N) = N_Assignment_Statement 1188 then 1189 declare 1190 Ent : constant Entity_Id := Entity (Lhs); 1191 1192 begin 1193 if Safe_To_Capture_Value (N, Ent) then 1194 1195 -- If simple variable on left side, warn if this assignment 1196 -- blots out another one (rendering it useless). We only do 1197 -- this for source assignments, otherwise we can generate bogus 1198 -- warnings when an assignment is rewritten as another 1199 -- assignment, and gets tied up with itself. 1200 1201 -- We also omit the warning if the RHS includes target names, 1202 -- that is to say the Ada 2022 "@" that denotes an instance of 1203 -- the LHS, which indicates that the current value is being 1204 -- used. Note that this implicit reference to the entity on 1205 -- the RHS is not treated as a source reference. 1206 1207 -- There may have been a previous reference to a component of 1208 -- the variable, which in general removes the Last_Assignment 1209 -- field of the variable to indicate a relevant use of the 1210 -- previous assignment. However, if the assignment is to a 1211 -- subcomponent the reference may not have registered, because 1212 -- it is not possible to determine whether the context is an 1213 -- assignment. In those cases we generate a Deferred_Reference, 1214 -- to be used at the end of compilation to generate the right 1215 -- kind of reference, and we suppress a potential warning for 1216 -- a useless assignment, which might be premature. This may 1217 -- lose a warning in rare cases, but seems preferable to a 1218 -- misleading warning. 1219 1220 if Warn_On_Modified_Unread 1221 and then Is_Assignable (Ent) 1222 and then Comes_From_Source (N) 1223 and then In_Extended_Main_Source_Unit (Ent) 1224 and then not Has_Deferred_Reference (Ent) 1225 and then not Has_Target_Names (N) 1226 then 1227 Warn_On_Useless_Assignment (Ent, N); 1228 end if; 1229 1230 -- If we are assigning an access type and the left side is an 1231 -- entity, then make sure that the Is_Known_[Non_]Null flags 1232 -- properly reflect the state of the entity after assignment. 1233 1234 if Is_Access_Type (T1) then 1235 if Known_Non_Null (Rhs) then 1236 Set_Is_Known_Non_Null (Ent, True); 1237 1238 elsif Known_Null (Rhs) 1239 and then not Can_Never_Be_Null (Ent) 1240 then 1241 Set_Is_Known_Null (Ent, True); 1242 1243 else 1244 Set_Is_Known_Null (Ent, False); 1245 1246 if not Can_Never_Be_Null (Ent) then 1247 Set_Is_Known_Non_Null (Ent, False); 1248 end if; 1249 end if; 1250 1251 -- For discrete types, we may be able to set the current value 1252 -- if the value is known at compile time. 1253 1254 elsif Is_Discrete_Type (T1) 1255 and then Compile_Time_Known_Value (Rhs) 1256 then 1257 Set_Current_Value (Ent, Rhs); 1258 else 1259 Set_Current_Value (Ent, Empty); 1260 end if; 1261 1262 -- If not safe to capture values, kill them 1263 1264 else 1265 Kill_Lhs; 1266 end if; 1267 end; 1268 end if; 1269 1270 -- If assigning to an object in whole or in part, note location of 1271 -- assignment in case no one references value. We only do this for 1272 -- source assignments, otherwise we can generate bogus warnings when an 1273 -- assignment is rewritten as another assignment, and gets tied up with 1274 -- itself. 1275 1276 declare 1277 Ent : constant Entity_Id := Get_Enclosing_Object (Lhs); 1278 begin 1279 if Present (Ent) 1280 and then Safe_To_Capture_Value (N, Ent) 1281 and then Nkind (N) = N_Assignment_Statement 1282 and then Warn_On_Modified_Unread 1283 and then Is_Assignable (Ent) 1284 and then Comes_From_Source (N) 1285 and then In_Extended_Main_Source_Unit (Ent) 1286 then 1287 Set_Last_Assignment (Ent, Lhs); 1288 end if; 1289 end; 1290 1291 Analyze_Dimension (N); 1292 1293 <<Leave>> 1294 Restore_Ghost_Region (Saved_GM, Saved_IGR); 1295 1296 -- If the right-hand side contains target names, expansion has been 1297 -- disabled to prevent expansion that might move target names out of 1298 -- the context of the assignment statement. Restore the expander mode 1299 -- now so that assignment statement can be properly expanded. 1300 1301 if Nkind (N) = N_Assignment_Statement then 1302 if Has_Target_Names (N) then 1303 Expander_Mode_Restore; 1304 Full_Analysis := Save_Full_Analysis; 1305 Current_Assignment := Empty; 1306 end if; 1307 1308 pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); 1309 end if; 1310 end Analyze_Assignment; 1311 1312 ----------------------------- 1313 -- Analyze_Block_Statement -- 1314 ----------------------------- 1315 1316 procedure Analyze_Block_Statement (N : Node_Id) is 1317 procedure Install_Return_Entities (Scop : Entity_Id); 1318 -- Install all entities of return statement scope Scop in the visibility 1319 -- chain except for the return object since its entity is reused in a 1320 -- renaming. 1321 1322 ----------------------------- 1323 -- Install_Return_Entities -- 1324 ----------------------------- 1325 1326 procedure Install_Return_Entities (Scop : Entity_Id) is 1327 Id : Entity_Id; 1328 1329 begin 1330 Id := First_Entity (Scop); 1331 while Present (Id) loop 1332 1333 -- Do not install the return object 1334 1335 if Ekind (Id) not in E_Constant | E_Variable 1336 or else not Is_Return_Object (Id) 1337 then 1338 Install_Entity (Id); 1339 end if; 1340 1341 Next_Entity (Id); 1342 end loop; 1343 end Install_Return_Entities; 1344 1345 -- Local constants and variables 1346 1347 Decls : constant List_Id := Declarations (N); 1348 Id : constant Node_Id := Identifier (N); 1349 HSS : constant Node_Id := Handled_Statement_Sequence (N); 1350 1351 Is_BIP_Return_Statement : Boolean; 1352 1353 -- Start of processing for Analyze_Block_Statement 1354 1355 begin 1356 -- If no handled statement sequence is present, things are really messed 1357 -- up, and we just return immediately (defence against previous errors). 1358 1359 if No (HSS) then 1360 Check_Error_Detected; 1361 return; 1362 end if; 1363 1364 -- Detect whether the block is actually a rewritten return statement of 1365 -- a build-in-place function. 1366 1367 Is_BIP_Return_Statement := 1368 Present (Id) 1369 and then Present (Entity (Id)) 1370 and then Ekind (Entity (Id)) = E_Return_Statement 1371 and then Is_Build_In_Place_Function 1372 (Return_Applies_To (Entity (Id))); 1373 1374 -- Normal processing with HSS present 1375 1376 declare 1377 EH : constant List_Id := Exception_Handlers (HSS); 1378 Ent : Entity_Id := Empty; 1379 S : Entity_Id; 1380 1381 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; 1382 -- Recursively save value of this global, will be restored on exit 1383 1384 begin 1385 -- Initialize unblocked exit count for statements of begin block 1386 -- plus one for each exception handler that is present. 1387 1388 Unblocked_Exit_Count := 1; 1389 1390 if Present (EH) then 1391 Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH); 1392 end if; 1393 1394 -- If a label is present analyze it and mark it as referenced 1395 1396 if Present (Id) then 1397 Analyze (Id); 1398 Ent := Entity (Id); 1399 1400 -- An error defense. If we have an identifier, but no entity, then 1401 -- something is wrong. If previous errors, then just remove the 1402 -- identifier and continue, otherwise raise an exception. 1403 1404 if No (Ent) then 1405 Check_Error_Detected; 1406 Set_Identifier (N, Empty); 1407 1408 else 1409 if Ekind (Ent) = E_Label then 1410 Reinit_Field_To_Zero (Ent, F_Enclosing_Scope); 1411 end if; 1412 1413 Mutate_Ekind (Ent, E_Block); 1414 Generate_Reference (Ent, N, ' '); 1415 Generate_Definition (Ent); 1416 1417 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then 1418 Set_Label_Construct (Parent (Ent), N); 1419 end if; 1420 end if; 1421 end if; 1422 1423 -- If no entity set, create a label entity 1424 1425 if No (Ent) then 1426 Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); 1427 Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N))); 1428 Set_Parent (Ent, N); 1429 end if; 1430 1431 Set_Etype (Ent, Standard_Void_Type); 1432 Set_Block_Node (Ent, Identifier (N)); 1433 Push_Scope (Ent); 1434 1435 -- The block served as an extended return statement. Ensure that any 1436 -- entities created during the analysis and expansion of the return 1437 -- object declaration are once again visible. 1438 1439 if Is_BIP_Return_Statement then 1440 Install_Return_Entities (Ent); 1441 end if; 1442 1443 if Present (Decls) then 1444 Analyze_Declarations (Decls); 1445 Check_Completion; 1446 Inspect_Deferred_Constant_Completion (Decls); 1447 end if; 1448 1449 Analyze (HSS); 1450 Process_End_Label (HSS, 'e', Ent); 1451 1452 -- If exception handlers are present, then we indicate that enclosing 1453 -- scopes contain a block with handlers. We only need to mark non- 1454 -- generic scopes. 1455 1456 if Present (EH) then 1457 S := Scope (Ent); 1458 loop 1459 Set_Has_Nested_Block_With_Handler (S); 1460 exit when Is_Overloadable (S) 1461 or else Ekind (S) = E_Package 1462 or else Is_Generic_Unit (S); 1463 S := Scope (S); 1464 end loop; 1465 end if; 1466 1467 Check_References (Ent); 1468 Update_Use_Clause_Chain; 1469 End_Scope; 1470 1471 if Unblocked_Exit_Count = 0 then 1472 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1473 Check_Unreachable_Code (N); 1474 else 1475 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1476 end if; 1477 end; 1478 end Analyze_Block_Statement; 1479 1480 -------------------------------- 1481 -- Analyze_Compound_Statement -- 1482 -------------------------------- 1483 1484 procedure Analyze_Compound_Statement (N : Node_Id) is 1485 begin 1486 Analyze_List (Actions (N)); 1487 end Analyze_Compound_Statement; 1488 1489 ---------------------------- 1490 -- Analyze_Case_Statement -- 1491 ---------------------------- 1492 1493 procedure Analyze_Case_Statement (N : Node_Id) is 1494 Exp : constant Node_Id := Expression (N); 1495 1496 Statements_Analyzed : Boolean := False; 1497 -- Set True if at least some statement sequences get analyzed. If False 1498 -- on exit, means we had a serious error that prevented full analysis of 1499 -- the case statement, and as a result it is not a good idea to output 1500 -- warning messages about unreachable code. 1501 1502 Is_General_Case_Statement : Boolean := False; 1503 -- Set True (later) if type of case expression is not discrete 1504 1505 procedure Non_Static_Choice_Error (Choice : Node_Id); 1506 -- Error routine invoked by the generic instantiation below when the 1507 -- case statement has a non static choice. 1508 1509 procedure Process_Statements (Alternative : Node_Id); 1510 -- Analyzes the statements associated with a case alternative. Needed 1511 -- by instantiation below. 1512 1513 package Analyze_Case_Choices is new 1514 Generic_Analyze_Choices 1515 (Process_Associated_Node => Process_Statements); 1516 use Analyze_Case_Choices; 1517 -- Instantiation of the generic choice analysis package 1518 1519 package Check_Case_Choices is new 1520 Generic_Check_Choices 1521 (Process_Empty_Choice => No_OP, 1522 Process_Non_Static_Choice => Non_Static_Choice_Error, 1523 Process_Associated_Node => No_OP); 1524 use Check_Case_Choices; 1525 -- Instantiation of the generic choice processing package 1526 1527 ----------------------------- 1528 -- Non_Static_Choice_Error -- 1529 ----------------------------- 1530 1531 procedure Non_Static_Choice_Error (Choice : Node_Id) is 1532 begin 1533 Flag_Non_Static_Expr 1534 ("choice given in case statement is not static!", Choice); 1535 end Non_Static_Choice_Error; 1536 1537 ------------------------ 1538 -- Process_Statements -- 1539 ------------------------ 1540 1541 procedure Process_Statements (Alternative : Node_Id) is 1542 Choices : constant List_Id := Discrete_Choices (Alternative); 1543 Ent : Entity_Id; 1544 1545 begin 1546 if Is_General_Case_Statement then 1547 return; 1548 -- Processing deferred in this case; decls associated with 1549 -- pattern match bindings don't exist yet. 1550 end if; 1551 1552 Unblocked_Exit_Count := Unblocked_Exit_Count + 1; 1553 Statements_Analyzed := True; 1554 1555 -- An interesting optimization. If the case statement expression 1556 -- is a simple entity, then we can set the current value within an 1557 -- alternative if the alternative has one possible value. 1558 1559 -- case N is 1560 -- when 1 => alpha 1561 -- when 2 | 3 => beta 1562 -- when others => gamma 1563 1564 -- Here we know that N is initially 1 within alpha, but for beta and 1565 -- gamma, we do not know anything more about the initial value. 1566 1567 if Is_Entity_Name (Exp) then 1568 Ent := Entity (Exp); 1569 1570 if Is_Object (Ent) then 1571 if List_Length (Choices) = 1 1572 and then Nkind (First (Choices)) in N_Subexpr 1573 and then Compile_Time_Known_Value (First (Choices)) 1574 then 1575 Set_Current_Value (Entity (Exp), First (Choices)); 1576 end if; 1577 1578 Analyze_Statements (Statements (Alternative)); 1579 1580 -- After analyzing the case, set the current value to empty 1581 -- since we won't know what it is for the next alternative 1582 -- (unless reset by this same circuit), or after the case. 1583 1584 Set_Current_Value (Entity (Exp), Empty); 1585 return; 1586 end if; 1587 end if; 1588 1589 -- Case where expression is not an entity name of an object 1590 1591 Analyze_Statements (Statements (Alternative)); 1592 end Process_Statements; 1593 1594 -- Local variables 1595 1596 Exp_Type : Entity_Id; 1597 Exp_Btype : Entity_Id; 1598 1599 Others_Present : Boolean; 1600 -- Indicates if Others was present 1601 1602 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; 1603 -- Recursively save value of this global, will be restored on exit 1604 1605 -- Start of processing for Analyze_Case_Statement 1606 1607 begin 1608 Analyze (Exp); 1609 1610 -- The expression must be of any discrete type. In rare cases, the 1611 -- expander constructs a case statement whose expression has a private 1612 -- type whose full view is discrete. This can happen when generating 1613 -- a stream operation for a variant type after the type is frozen, 1614 -- when the partial of view of the type of the discriminant is private. 1615 -- In that case, use the full view to analyze case alternatives. 1616 1617 if not Is_Overloaded (Exp) 1618 and then not Comes_From_Source (N) 1619 and then Is_Private_Type (Etype (Exp)) 1620 and then Present (Full_View (Etype (Exp))) 1621 and then Is_Discrete_Type (Full_View (Etype (Exp))) 1622 then 1623 Resolve (Exp); 1624 Exp_Type := Full_View (Etype (Exp)); 1625 1626 -- For Ada, overloading might be ok because subsequently filtering 1627 -- out non-discretes may resolve the ambiguity. 1628 -- But GNAT extensions allow casing on non-discretes. 1629 1630 elsif Extensions_Allowed and then Is_Overloaded (Exp) then 1631 1632 -- It would be nice if we could generate all the right error 1633 -- messages by calling "Resolve (Exp, Any_Type);" in the 1634 -- same way that they are generated a few lines below by the 1635 -- call "Analyze_And_Resolve (Exp, Any_Discrete);". 1636 -- Unfortunately, Any_Type and Any_Discrete are not treated 1637 -- consistently (specifically, by Sem_Type.Covers), so that 1638 -- doesn't work. 1639 1640 Error_Msg_N 1641 ("selecting expression of general case statement is ambiguous", 1642 Exp); 1643 return; 1644 1645 -- Check for a GNAT-extension "general" case statement (i.e., one where 1646 -- the type of the selecting expression is not discrete). 1647 1648 elsif Extensions_Allowed 1649 and then not Is_Discrete_Type (Etype (Exp)) 1650 then 1651 Resolve (Exp, Etype (Exp)); 1652 Exp_Type := Etype (Exp); 1653 Is_General_Case_Statement := True; 1654 else 1655 Analyze_And_Resolve (Exp, Any_Discrete); 1656 Exp_Type := Etype (Exp); 1657 end if; 1658 1659 Check_Unset_Reference (Exp); 1660 Exp_Btype := Base_Type (Exp_Type); 1661 1662 -- The expression must be of a discrete type which must be determinable 1663 -- independently of the context in which the expression occurs, but 1664 -- using the fact that the expression must be of a discrete type. 1665 -- Moreover, the type this expression must not be a character literal 1666 -- (which is always ambiguous) or, for Ada-83, a generic formal type. 1667 1668 -- If error already reported by Resolve, nothing more to do 1669 1670 if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then 1671 return; 1672 1673 elsif Exp_Btype = Any_Character then 1674 Error_Msg_N 1675 ("character literal as case expression is ambiguous", Exp); 1676 return; 1677 1678 elsif Ada_Version = Ada_83 1679 and then (Is_Generic_Type (Exp_Btype) 1680 or else Is_Generic_Type (Root_Type (Exp_Btype))) 1681 then 1682 Error_Msg_N 1683 ("(Ada 83) case expression cannot be of a generic type", Exp); 1684 return; 1685 1686 elsif not Extensions_Allowed 1687 and then not Is_Discrete_Type (Exp_Type) 1688 then 1689 Error_Msg_N 1690 ("expression in case statement must be of a discrete_Type", Exp); 1691 return; 1692 end if; 1693 1694 -- If the case expression is a formal object of mode in out, then treat 1695 -- it as having a nonstatic subtype by forcing use of the base type 1696 -- (which has to get passed to Check_Case_Choices below). Also use base 1697 -- type when the case expression is parenthesized. 1698 1699 if Paren_Count (Exp) > 0 1700 or else (Is_Entity_Name (Exp) 1701 and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter) 1702 then 1703 Exp_Type := Exp_Btype; 1704 end if; 1705 1706 -- Call instantiated procedures to analyze and check discrete choices 1707 1708 Unblocked_Exit_Count := 0; 1709 1710 Analyze_Choices (Alternatives (N), Exp_Type); 1711 Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); 1712 1713 if Is_General_Case_Statement then 1714 -- Work normally done in Process_Statements was deferred; do that 1715 -- deferred work now that Check_Choices has had a chance to create 1716 -- any needed pattern-match-binding declarations. 1717 declare 1718 Alt : Node_Id := First (Alternatives (N)); 1719 begin 1720 while Present (Alt) loop 1721 Unblocked_Exit_Count := Unblocked_Exit_Count + 1; 1722 Analyze_Statements (Statements (Alt)); 1723 Next (Alt); 1724 end loop; 1725 end; 1726 end if; 1727 1728 if Exp_Type = Universal_Integer and then not Others_Present then 1729 Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); 1730 end if; 1731 1732 -- If all our exits were blocked by unconditional transfers of control, 1733 -- then the entire CASE statement acts as an unconditional transfer of 1734 -- control, so treat it like one, and check unreachable code. Skip this 1735 -- test if we had serious errors preventing any statement analysis. 1736 1737 if Unblocked_Exit_Count = 0 and then Statements_Analyzed then 1738 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1739 Check_Unreachable_Code (N); 1740 else 1741 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 1742 end if; 1743 1744 -- If the expander is active it will detect the case of a statically 1745 -- determined single alternative and remove warnings for the case, but 1746 -- if we are not doing expansion, that circuit won't be active. Here we 1747 -- duplicate the effect of removing warnings in the same way, so that 1748 -- we will get the same set of warnings in -gnatc mode. 1749 1750 if not Expander_Active 1751 and then Compile_Time_Known_Value (Expression (N)) 1752 and then Serious_Errors_Detected = 0 1753 then 1754 declare 1755 Chosen : constant Node_Id := Find_Static_Alternative (N); 1756 Alt : Node_Id; 1757 1758 begin 1759 Alt := First (Alternatives (N)); 1760 while Present (Alt) loop 1761 if Alt /= Chosen then 1762 Remove_Warning_Messages (Statements (Alt)); 1763 end if; 1764 1765 Next (Alt); 1766 end loop; 1767 end; 1768 end if; 1769 end Analyze_Case_Statement; 1770 1771 ---------------------------- 1772 -- Analyze_Exit_Statement -- 1773 ---------------------------- 1774 1775 -- If the exit includes a name, it must be the name of a currently open 1776 -- loop. Otherwise there must be an innermost open loop on the stack, to 1777 -- which the statement implicitly refers. 1778 1779 -- Additionally, in SPARK mode: 1780 1781 -- The exit can only name the closest enclosing loop; 1782 1783 -- An exit with a when clause must be directly contained in a loop; 1784 1785 -- An exit without a when clause must be directly contained in an 1786 -- if-statement with no elsif or else, which is itself directly contained 1787 -- in a loop. The exit must be the last statement in the if-statement. 1788 1789 procedure Analyze_Exit_Statement (N : Node_Id) is 1790 Target : constant Node_Id := Name (N); 1791 Cond : constant Node_Id := Condition (N); 1792 Scope_Id : Entity_Id := Empty; -- initialize to prevent warning 1793 U_Name : Entity_Id; 1794 Kind : Entity_Kind; 1795 1796 begin 1797 if No (Cond) then 1798 Check_Unreachable_Code (N); 1799 end if; 1800 1801 if Present (Target) then 1802 Analyze (Target); 1803 U_Name := Entity (Target); 1804 1805 if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then 1806 Error_Msg_N ("invalid loop name in exit statement", N); 1807 return; 1808 1809 else 1810 Set_Has_Exit (U_Name); 1811 end if; 1812 1813 else 1814 U_Name := Empty; 1815 end if; 1816 1817 for J in reverse 0 .. Scope_Stack.Last loop 1818 Scope_Id := Scope_Stack.Table (J).Entity; 1819 Kind := Ekind (Scope_Id); 1820 1821 if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then 1822 Set_Has_Exit (Scope_Id); 1823 exit; 1824 1825 elsif Kind = E_Block 1826 or else Kind = E_Loop 1827 or else Kind = E_Return_Statement 1828 then 1829 null; 1830 1831 else 1832 Error_Msg_N 1833 ("cannot exit from program unit or accept statement", N); 1834 return; 1835 end if; 1836 end loop; 1837 1838 -- Verify that if present the condition is a Boolean expression 1839 1840 if Present (Cond) then 1841 Analyze_And_Resolve (Cond, Any_Boolean); 1842 Check_Unset_Reference (Cond); 1843 end if; 1844 1845 -- Chain exit statement to associated loop entity 1846 1847 Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); 1848 Set_First_Exit_Statement (Scope_Id, N); 1849 1850 -- Since the exit may take us out of a loop, any previous assignment 1851 -- statement is not useless, so clear last assignment indications. It 1852 -- is OK to keep other current values, since if the exit statement 1853 -- does not exit, then the current values are still valid. 1854 1855 Kill_Current_Values (Last_Assignment_Only => True); 1856 end Analyze_Exit_Statement; 1857 1858 ---------------------------- 1859 -- Analyze_Goto_Statement -- 1860 ---------------------------- 1861 1862 procedure Analyze_Goto_Statement (N : Node_Id) is 1863 Label : constant Node_Id := Name (N); 1864 Scope_Id : Entity_Id; 1865 Label_Scope : Entity_Id; 1866 Label_Ent : Entity_Id; 1867 1868 begin 1869 -- Actual semantic checks 1870 1871 Check_Unreachable_Code (N); 1872 Kill_Current_Values (Last_Assignment_Only => True); 1873 1874 Analyze (Label); 1875 Label_Ent := Entity (Label); 1876 1877 -- Ignore previous error 1878 1879 if Label_Ent = Any_Id then 1880 Check_Error_Detected; 1881 return; 1882 1883 -- We just have a label as the target of a goto 1884 1885 elsif Ekind (Label_Ent) /= E_Label then 1886 Error_Msg_N ("target of goto statement must be a label", Label); 1887 return; 1888 1889 -- Check that the target of the goto is reachable according to Ada 1890 -- scoping rules. Note: the special gotos we generate for optimizing 1891 -- local handling of exceptions would violate these rules, but we mark 1892 -- such gotos as analyzed when built, so this code is never entered. 1893 1894 elsif not Reachable (Label_Ent) then 1895 Error_Msg_N ("target of goto statement is not reachable", Label); 1896 return; 1897 end if; 1898 1899 -- Here if goto passes initial validity checks 1900 1901 Label_Scope := Enclosing_Scope (Label_Ent); 1902 1903 for J in reverse 0 .. Scope_Stack.Last loop 1904 Scope_Id := Scope_Stack.Table (J).Entity; 1905 1906 if Label_Scope = Scope_Id 1907 or else Ekind (Scope_Id) not in 1908 E_Block | E_Loop | E_Return_Statement 1909 then 1910 if Scope_Id /= Label_Scope then 1911 Error_Msg_N 1912 ("cannot exit from program unit or accept statement", N); 1913 end if; 1914 1915 return; 1916 end if; 1917 end loop; 1918 1919 raise Program_Error; 1920 end Analyze_Goto_Statement; 1921 1922 --------------------------------- 1923 -- Analyze_Goto_When_Statement -- 1924 --------------------------------- 1925 1926 procedure Analyze_Goto_When_Statement (N : Node_Id) is 1927 begin 1928 -- Verify the condition is a Boolean expression 1929 1930 Analyze_And_Resolve (Condition (N), Any_Boolean); 1931 Check_Unset_Reference (Condition (N)); 1932 end Analyze_Goto_When_Statement; 1933 1934 -------------------------- 1935 -- Analyze_If_Statement -- 1936 -------------------------- 1937 1938 -- A special complication arises in the analysis of if statements 1939 1940 -- The expander has circuitry to completely delete code that it can tell 1941 -- will not be executed (as a result of compile time known conditions). In 1942 -- the analyzer, we ensure that code that will be deleted in this manner 1943 -- is analyzed but not expanded. This is obviously more efficient, but 1944 -- more significantly, difficulties arise if code is expanded and then 1945 -- eliminated (e.g. exception table entries disappear). Similarly, itypes 1946 -- generated in deleted code must be frozen from start, because the nodes 1947 -- on which they depend will not be available at the freeze point. 1948 1949 procedure Analyze_If_Statement (N : Node_Id) is 1950 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; 1951 -- Recursively save value of this global, will be restored on exit 1952 1953 Save_In_Deleted_Code : Boolean := In_Deleted_Code; 1954 1955 Del : Boolean := False; 1956 -- This flag gets set True if a True condition has been found, which 1957 -- means that remaining ELSE/ELSIF parts are deleted. 1958 1959 procedure Analyze_Cond_Then (Cnode : Node_Id); 1960 -- This is applied to either the N_If_Statement node itself or to an 1961 -- N_Elsif_Part node. It deals with analyzing the condition and the THEN 1962 -- statements associated with it. 1963 1964 ----------------------- 1965 -- Analyze_Cond_Then -- 1966 ----------------------- 1967 1968 procedure Analyze_Cond_Then (Cnode : Node_Id) is 1969 Cond : constant Node_Id := Condition (Cnode); 1970 Tstm : constant List_Id := Then_Statements (Cnode); 1971 1972 begin 1973 Unblocked_Exit_Count := Unblocked_Exit_Count + 1; 1974 Analyze_And_Resolve (Cond, Any_Boolean); 1975 Check_Unset_Reference (Cond); 1976 Set_Current_Value_Condition (Cnode); 1977 1978 -- If already deleting, then just analyze then statements 1979 1980 if Del then 1981 Analyze_Statements (Tstm); 1982 1983 -- Compile time known value, not deleting yet 1984 1985 elsif Compile_Time_Known_Value (Cond) then 1986 Save_In_Deleted_Code := In_Deleted_Code; 1987 1988 -- If condition is True, then analyze the THEN statements and set 1989 -- no expansion for ELSE and ELSIF parts. 1990 1991 if Is_True (Expr_Value (Cond)) then 1992 Analyze_Statements (Tstm); 1993 Del := True; 1994 Expander_Mode_Save_And_Set (False); 1995 In_Deleted_Code := True; 1996 1997 -- If condition is False, analyze THEN with expansion off 1998 1999 else pragma Assert (Is_False (Expr_Value (Cond))); 2000 Expander_Mode_Save_And_Set (False); 2001 In_Deleted_Code := True; 2002 Analyze_Statements (Tstm); 2003 Expander_Mode_Restore; 2004 In_Deleted_Code := Save_In_Deleted_Code; 2005 end if; 2006 2007 -- Not known at compile time, not deleting, normal analysis 2008 2009 else 2010 Analyze_Statements (Tstm); 2011 end if; 2012 end Analyze_Cond_Then; 2013 2014 -- Local variables 2015 2016 E : Node_Id; 2017 -- For iterating over elsif parts 2018 2019 -- Start of processing for Analyze_If_Statement 2020 2021 begin 2022 -- Initialize exit count for else statements. If there is no else part, 2023 -- this count will stay non-zero reflecting the fact that the uncovered 2024 -- else case is an unblocked exit. 2025 2026 Unblocked_Exit_Count := 1; 2027 Analyze_Cond_Then (N); 2028 2029 -- Now to analyze the elsif parts if any are present 2030 2031 if Present (Elsif_Parts (N)) then 2032 E := First (Elsif_Parts (N)); 2033 while Present (E) loop 2034 Analyze_Cond_Then (E); 2035 Next (E); 2036 end loop; 2037 end if; 2038 2039 if Present (Else_Statements (N)) then 2040 Analyze_Statements (Else_Statements (N)); 2041 end if; 2042 2043 -- If all our exits were blocked by unconditional transfers of control, 2044 -- then the entire IF statement acts as an unconditional transfer of 2045 -- control, so treat it like one, and check unreachable code. 2046 2047 if Unblocked_Exit_Count = 0 then 2048 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 2049 Check_Unreachable_Code (N); 2050 else 2051 Unblocked_Exit_Count := Save_Unblocked_Exit_Count; 2052 end if; 2053 2054 if Del then 2055 Expander_Mode_Restore; 2056 In_Deleted_Code := Save_In_Deleted_Code; 2057 end if; 2058 2059 if not Expander_Active 2060 and then Compile_Time_Known_Value (Condition (N)) 2061 and then Serious_Errors_Detected = 0 2062 then 2063 if Is_True (Expr_Value (Condition (N))) then 2064 Remove_Warning_Messages (Else_Statements (N)); 2065 2066 if Present (Elsif_Parts (N)) then 2067 E := First (Elsif_Parts (N)); 2068 while Present (E) loop 2069 Remove_Warning_Messages (Then_Statements (E)); 2070 Next (E); 2071 end loop; 2072 end if; 2073 2074 else 2075 Remove_Warning_Messages (Then_Statements (N)); 2076 end if; 2077 end if; 2078 2079 -- Warn on redundant if statement that has no effect 2080 2081 -- Note, we could also check empty ELSIF parts ??? 2082 2083 if Warn_On_Redundant_Constructs 2084 2085 -- If statement must be from source 2086 2087 and then Comes_From_Source (N) 2088 2089 -- Condition must not have obvious side effect 2090 2091 and then Has_No_Obvious_Side_Effects (Condition (N)) 2092 2093 -- No elsif parts of else part 2094 2095 and then No (Elsif_Parts (N)) 2096 and then No (Else_Statements (N)) 2097 2098 -- Then must be a single null statement 2099 2100 and then List_Length (Then_Statements (N)) = 1 2101 then 2102 -- Go to original node, since we may have rewritten something as 2103 -- a null statement (e.g. a case we could figure the outcome of). 2104 2105 declare 2106 T : constant Node_Id := First (Then_Statements (N)); 2107 S : constant Node_Id := Original_Node (T); 2108 2109 begin 2110 if Comes_From_Source (S) and then Nkind (S) = N_Null_Statement then 2111 Error_Msg_N ("if statement has no effect?r?", N); 2112 end if; 2113 end; 2114 end if; 2115 end Analyze_If_Statement; 2116 2117 ---------------------------------------- 2118 -- Analyze_Implicit_Label_Declaration -- 2119 ---------------------------------------- 2120 2121 -- An implicit label declaration is generated in the innermost enclosing 2122 -- declarative part. This is done for labels, and block and loop names. 2123 2124 -- Note: any changes in this routine may need to be reflected in 2125 -- Analyze_Label_Entity. 2126 2127 procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is 2128 Id : constant Node_Id := Defining_Identifier (N); 2129 begin 2130 Enter_Name (Id); 2131 Mutate_Ekind (Id, E_Label); 2132 Set_Etype (Id, Standard_Void_Type); 2133 Set_Enclosing_Scope (Id, Current_Scope); 2134 end Analyze_Implicit_Label_Declaration; 2135 2136 ------------------------------ 2137 -- Analyze_Iteration_Scheme -- 2138 ------------------------------ 2139 2140 procedure Analyze_Iteration_Scheme (N : Node_Id) is 2141 Cond : Node_Id; 2142 Iter_Spec : Node_Id; 2143 Loop_Spec : Node_Id; 2144 2145 begin 2146 -- For an infinite loop, there is no iteration scheme 2147 2148 if No (N) then 2149 return; 2150 end if; 2151 2152 Cond := Condition (N); 2153 Iter_Spec := Iterator_Specification (N); 2154 Loop_Spec := Loop_Parameter_Specification (N); 2155 2156 if Present (Cond) then 2157 Analyze_And_Resolve (Cond, Any_Boolean); 2158 Check_Unset_Reference (Cond); 2159 Set_Current_Value_Condition (N); 2160 2161 elsif Present (Iter_Spec) then 2162 Analyze_Iterator_Specification (Iter_Spec); 2163 2164 else 2165 Analyze_Loop_Parameter_Specification (Loop_Spec); 2166 end if; 2167 end Analyze_Iteration_Scheme; 2168 2169 ------------------------------------ 2170 -- Analyze_Iterator_Specification -- 2171 ------------------------------------ 2172 2173 procedure Analyze_Iterator_Specification (N : Node_Id) is 2174 Def_Id : constant Node_Id := Defining_Identifier (N); 2175 Iter_Name : constant Node_Id := Name (N); 2176 Loc : constant Source_Ptr := Sloc (N); 2177 Subt : constant Node_Id := Subtype_Indication (N); 2178 2179 Bas : Entity_Id := Empty; -- initialize to prevent warning 2180 Typ : Entity_Id; 2181 2182 procedure Check_Reverse_Iteration (Typ : Entity_Id); 2183 -- For an iteration over a container, if the loop carries the Reverse 2184 -- indicator, verify that the container type has an Iterate aspect that 2185 -- implements the reversible iterator interface. 2186 2187 procedure Check_Subtype_Definition (Comp_Type : Entity_Id); 2188 -- If a subtype indication is present, verify that it is consistent 2189 -- with the component type of the array or container name. 2190 -- In Ada 2022, the subtype indication may be an access definition, 2191 -- if the array or container has elements of an anonymous access type. 2192 2193 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id; 2194 -- For containers with Iterator and related aspects, the cursor is 2195 -- obtained by locating an entity with the proper name in the scope 2196 -- of the type. 2197 2198 ----------------------------- 2199 -- Check_Reverse_Iteration -- 2200 ----------------------------- 2201 2202 procedure Check_Reverse_Iteration (Typ : Entity_Id) is 2203 begin 2204 if Reverse_Present (N) then 2205 if Is_Array_Type (Typ) 2206 or else Is_Reversible_Iterator (Typ) 2207 or else 2208 (Present (Find_Aspect (Typ, Aspect_Iterable)) 2209 and then 2210 Present 2211 (Get_Iterable_Type_Primitive (Typ, Name_Previous))) 2212 then 2213 null; 2214 else 2215 Error_Msg_N 2216 ("container type does not support reverse iteration", N); 2217 end if; 2218 end if; 2219 end Check_Reverse_Iteration; 2220 2221 ------------------------------- 2222 -- Check_Subtype_Definition -- 2223 ------------------------------- 2224 2225 procedure Check_Subtype_Definition (Comp_Type : Entity_Id) is 2226 begin 2227 if not Present (Subt) then 2228 return; 2229 end if; 2230 2231 if Is_Anonymous_Access_Type (Entity (Subt)) then 2232 if not Is_Anonymous_Access_Type (Comp_Type) then 2233 Error_Msg_NE 2234 ("component type& is not an anonymous access", 2235 Subt, Comp_Type); 2236 2237 elsif not Conforming_Types 2238 (Designated_Type (Entity (Subt)), 2239 Designated_Type (Comp_Type), 2240 Fully_Conformant) 2241 then 2242 Error_Msg_NE 2243 ("subtype indication does not match component type&", 2244 Subt, Comp_Type); 2245 end if; 2246 2247 elsif Present (Subt) 2248 and then (not Covers (Base_Type (Bas), Comp_Type) 2249 or else not Subtypes_Statically_Match (Bas, Comp_Type)) 2250 then 2251 if Is_Array_Type (Typ) then 2252 Error_Msg_NE 2253 ("subtype indication does not match component type&", 2254 Subt, Comp_Type); 2255 else 2256 Error_Msg_NE 2257 ("subtype indication does not match element type&", 2258 Subt, Comp_Type); 2259 end if; 2260 end if; 2261 end Check_Subtype_Definition; 2262 2263 --------------------- 2264 -- Get_Cursor_Type -- 2265 --------------------- 2266 2267 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is 2268 Ent : Entity_Id; 2269 2270 begin 2271 -- If iterator type is derived, the cursor is declared in the scope 2272 -- of the parent type. 2273 2274 if Is_Derived_Type (Typ) then 2275 Ent := First_Entity (Scope (Etype (Typ))); 2276 else 2277 Ent := First_Entity (Scope (Typ)); 2278 end if; 2279 2280 while Present (Ent) loop 2281 exit when Chars (Ent) = Name_Cursor; 2282 Next_Entity (Ent); 2283 end loop; 2284 2285 if No (Ent) then 2286 return Any_Type; 2287 end if; 2288 2289 -- The cursor is the target of generated assignments in the 2290 -- loop, and cannot have a limited type. 2291 2292 if Is_Limited_Type (Etype (Ent)) then 2293 Error_Msg_N ("cursor type cannot be limited", N); 2294 end if; 2295 2296 return Etype (Ent); 2297 end Get_Cursor_Type; 2298 2299 -- Start of processing for Analyze_Iterator_Specification 2300 2301 begin 2302 Enter_Name (Def_Id); 2303 2304 -- AI12-0151 specifies that when the subtype indication is present, it 2305 -- must statically match the type of the array or container element. 2306 -- To simplify this check, we introduce a subtype declaration with the 2307 -- given subtype indication when it carries a constraint, and rewrite 2308 -- the original as a reference to the created subtype entity. 2309 2310 if Present (Subt) then 2311 if Nkind (Subt) = N_Subtype_Indication then 2312 declare 2313 S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S'); 2314 Decl : constant Node_Id := 2315 Make_Subtype_Declaration (Loc, 2316 Defining_Identifier => S, 2317 Subtype_Indication => New_Copy_Tree (Subt)); 2318 begin 2319 Insert_Before (Parent (Parent (N)), Decl); 2320 Analyze (Decl); 2321 Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); 2322 end; 2323 2324 -- Ada 2022: the subtype definition may be for an anonymous 2325 -- access type. 2326 2327 elsif Nkind (Subt) = N_Access_Definition then 2328 declare 2329 S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S'); 2330 Decl : Node_Id; 2331 begin 2332 if Present (Subtype_Mark (Subt)) then 2333 Decl := 2334 Make_Full_Type_Declaration (Loc, 2335 Defining_Identifier => S, 2336 Type_Definition => 2337 Make_Access_To_Object_Definition (Loc, 2338 All_Present => True, 2339 Subtype_Indication => 2340 New_Copy_Tree (Subtype_Mark (Subt)))); 2341 2342 else 2343 Decl := 2344 Make_Full_Type_Declaration (Loc, 2345 Defining_Identifier => S, 2346 Type_Definition => 2347 New_Copy_Tree 2348 (Access_To_Subprogram_Definition (Subt))); 2349 end if; 2350 2351 Insert_Before (Parent (Parent (N)), Decl); 2352 Analyze (Decl); 2353 Freeze_Before (First (Statements (Parent (Parent (N)))), S); 2354 Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); 2355 end; 2356 else 2357 Analyze (Subt); 2358 end if; 2359 2360 -- Save entity of subtype indication for subsequent check 2361 2362 Bas := Entity (Subt); 2363 end if; 2364 2365 Preanalyze_Range (Iter_Name); 2366 2367 -- If the domain of iteration is a function call, make sure the function 2368 -- itself is frozen. This is an issue if this is a local expression 2369 -- function. 2370 2371 if Nkind (Iter_Name) = N_Function_Call 2372 and then Is_Entity_Name (Name (Iter_Name)) 2373 and then Full_Analysis 2374 and then (In_Assertion_Expr = 0 or else Assertions_Enabled) 2375 then 2376 Freeze_Before (N, Entity (Name (Iter_Name))); 2377 end if; 2378 2379 -- Set the kind of the loop variable, which is not visible within the 2380 -- iterator name. 2381 2382 Mutate_Ekind (Def_Id, E_Variable); 2383 2384 -- Provide a link between the iterator variable and the container, for 2385 -- subsequent use in cross-reference and modification information. 2386 2387 if Of_Present (N) then 2388 Set_Related_Expression (Def_Id, Iter_Name); 2389 2390 -- For a container, the iterator is specified through the aspect 2391 2392 if not Is_Array_Type (Etype (Iter_Name)) then 2393 declare 2394 Iterator : constant Entity_Id := 2395 Find_Value_Of_Aspect 2396 (Etype (Iter_Name), Aspect_Default_Iterator); 2397 2398 I : Interp_Index; 2399 It : Interp; 2400 2401 begin 2402 -- The domain of iteration must implement either the RM 2403 -- iterator interface, or the SPARK Iterable aspect. 2404 2405 if No (Iterator) then 2406 if No (Find_Aspect (Etype (Iter_Name), Aspect_Iterable)) then 2407 Error_Msg_NE 2408 ("cannot iterate over&", 2409 N, Base_Type (Etype (Iter_Name))); 2410 return; 2411 end if; 2412 2413 elsif not Is_Overloaded (Iterator) then 2414 Check_Reverse_Iteration (Etype (Iterator)); 2415 2416 -- If Iterator is overloaded, use reversible iterator if one is 2417 -- available. 2418 2419 elsif Is_Overloaded (Iterator) then 2420 Get_First_Interp (Iterator, I, It); 2421 while Present (It.Nam) loop 2422 if Ekind (It.Nam) = E_Function 2423 and then Is_Reversible_Iterator (Etype (It.Nam)) 2424 then 2425 Set_Etype (Iterator, It.Typ); 2426 Set_Entity (Iterator, It.Nam); 2427 exit; 2428 end if; 2429 2430 Get_Next_Interp (I, It); 2431 end loop; 2432 2433 Check_Reverse_Iteration (Etype (Iterator)); 2434 end if; 2435 end; 2436 end if; 2437 end if; 2438 2439 -- If the domain of iteration is an expression, create a declaration for 2440 -- it, so that finalization actions are introduced outside of the loop. 2441 -- The declaration must be a renaming (both in GNAT and GNATprove 2442 -- modes), because the body of the loop may assign to elements. 2443 2444 if not Is_Entity_Name (Iter_Name) 2445 2446 -- When the context is a quantified expression, the renaming 2447 -- declaration is delayed until the expansion phase if we are 2448 -- doing expansion. 2449 2450 and then (Nkind (Parent (N)) /= N_Quantified_Expression 2451 or else (Operating_Mode = Check_Semantics 2452 and then not GNATprove_Mode)) 2453 2454 -- Do not perform this expansion when expansion is disabled, where the 2455 -- temporary may hide the transformation of a selected component into 2456 -- a prefixed function call, and references need to see the original 2457 -- expression. 2458 2459 and then (Expander_Active or GNATprove_Mode) 2460 then 2461 declare 2462 Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); 2463 Decl : Node_Id; 2464 Act_S : Node_Id; 2465 2466 begin 2467 2468 -- If the domain of iteration is an array component that depends 2469 -- on a discriminant, create actual subtype for it. Preanalysis 2470 -- does not generate the actual subtype of a selected component. 2471 2472 if Nkind (Iter_Name) = N_Selected_Component 2473 and then Is_Array_Type (Etype (Iter_Name)) 2474 then 2475 Act_S := 2476 Build_Actual_Subtype_Of_Component 2477 (Etype (Selector_Name (Iter_Name)), Iter_Name); 2478 Insert_Action (N, Act_S); 2479 2480 if Present (Act_S) then 2481 Typ := Defining_Identifier (Act_S); 2482 else 2483 Typ := Etype (Iter_Name); 2484 end if; 2485 2486 else 2487 Typ := Etype (Iter_Name); 2488 2489 -- Verify that the expression produces an iterator 2490 2491 if not Of_Present (N) and then not Is_Iterator (Typ) 2492 and then not Is_Array_Type (Typ) 2493 and then No (Find_Aspect (Typ, Aspect_Iterable)) 2494 then 2495 Error_Msg_N 2496 ("expect object that implements iterator interface", 2497 Iter_Name); 2498 end if; 2499 end if; 2500 2501 -- Protect against malformed iterator 2502 2503 if Typ = Any_Type then 2504 Error_Msg_N ("invalid expression in loop iterator", Iter_Name); 2505 return; 2506 end if; 2507 2508 if not Of_Present (N) then 2509 Check_Reverse_Iteration (Typ); 2510 end if; 2511 2512 -- For an element iteration over a slice, we must complete 2513 -- the resolution and expansion of the slice bounds. These 2514 -- can be arbitrary expressions, and the preanalysis that 2515 -- was performed in preparation for the iteration may have 2516 -- generated an itype whose bounds must be fully expanded. 2517 -- We set the parent node to provide a proper insertion 2518 -- point for generated actions, if any. 2519 2520 if Nkind (Iter_Name) = N_Slice 2521 and then Nkind (Discrete_Range (Iter_Name)) = N_Range 2522 and then not Analyzed (Discrete_Range (Iter_Name)) 2523 then 2524 declare 2525 Indx : constant Node_Id := 2526 Entity (First_Index (Etype (Iter_Name))); 2527 begin 2528 Set_Parent (Indx, Iter_Name); 2529 Resolve (Scalar_Range (Indx), Etype (Indx)); 2530 end; 2531 end if; 2532 2533 -- The name in the renaming declaration may be a function call. 2534 -- Indicate that it does not come from source, to suppress 2535 -- spurious warnings on renamings of parameterless functions, 2536 -- a common enough idiom in user-defined iterators. 2537 2538 Decl := 2539 Make_Object_Renaming_Declaration (Loc, 2540 Defining_Identifier => Id, 2541 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 2542 Name => 2543 New_Copy_Tree (Iter_Name, New_Sloc => Loc)); 2544 2545 Insert_Actions (Parent (Parent (N)), New_List (Decl)); 2546 Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); 2547 Analyze (Name (N)); 2548 Set_Etype (Id, Typ); 2549 Set_Etype (Name (N), Typ); 2550 end; 2551 2552 -- Container is an entity or an array with uncontrolled components, or 2553 -- else it is a container iterator given by a function call, typically 2554 -- called Iterate in the case of predefined containers, even though 2555 -- Iterate is not a reserved name. What matters is that the return type 2556 -- of the function is an iterator type. 2557 2558 elsif Is_Entity_Name (Iter_Name) then 2559 Analyze (Iter_Name); 2560 2561 if Nkind (Iter_Name) = N_Function_Call then 2562 declare 2563 C : constant Node_Id := Name (Iter_Name); 2564 I : Interp_Index; 2565 It : Interp; 2566 2567 begin 2568 if not Is_Overloaded (Iter_Name) then 2569 Resolve (Iter_Name, Etype (C)); 2570 2571 else 2572 Get_First_Interp (C, I, It); 2573 while It.Typ /= Empty loop 2574 if Reverse_Present (N) then 2575 if Is_Reversible_Iterator (It.Typ) then 2576 Resolve (Iter_Name, It.Typ); 2577 exit; 2578 end if; 2579 2580 elsif Is_Iterator (It.Typ) then 2581 Resolve (Iter_Name, It.Typ); 2582 exit; 2583 end if; 2584 2585 Get_Next_Interp (I, It); 2586 end loop; 2587 end if; 2588 end; 2589 2590 -- Domain of iteration is not overloaded 2591 2592 else 2593 Resolve (Iter_Name); 2594 end if; 2595 2596 if not Of_Present (N) then 2597 Check_Reverse_Iteration (Etype (Iter_Name)); 2598 end if; 2599 end if; 2600 2601 -- Get base type of container, for proper retrieval of Cursor type 2602 -- and primitive operations. 2603 2604 Typ := Base_Type (Etype (Iter_Name)); 2605 2606 if Is_Array_Type (Typ) then 2607 if Of_Present (N) then 2608 Set_Etype (Def_Id, Component_Type (Typ)); 2609 2610 -- The loop variable is aliased if the array components are 2611 -- aliased. Likewise for the independent aspect. 2612 2613 Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ)); 2614 Set_Is_Independent (Def_Id, Has_Independent_Components (Typ)); 2615 2616 -- AI12-0047 stipulates that the domain (array or container) 2617 -- cannot be a component that depends on a discriminant if the 2618 -- enclosing object is mutable, to prevent a modification of the 2619 -- domain of iteration in the course of an iteration. 2620 2621 -- If the object is an expression it has been captured in a 2622 -- temporary, so examine original node. 2623 2624 if Nkind (Original_Node (Iter_Name)) = N_Selected_Component 2625 and then Is_Dependent_Component_Of_Mutable_Object 2626 (Original_Node (Iter_Name)) 2627 then 2628 Error_Msg_N 2629 ("iterable name cannot be a discriminant-dependent " 2630 & "component of a mutable object", N); 2631 end if; 2632 2633 Check_Subtype_Definition (Component_Type (Typ)); 2634 2635 -- Here we have a missing Range attribute 2636 2637 else 2638 Error_Msg_N 2639 ("missing Range attribute in iteration over an array", N); 2640 2641 -- In Ada 2012 mode, this may be an attempt at an iterator 2642 2643 if Ada_Version >= Ada_2012 then 2644 Error_Msg_NE 2645 ("\if& is meant to designate an element of the array, use OF", 2646 N, Def_Id); 2647 end if; 2648 2649 -- Prevent cascaded errors 2650 2651 Mutate_Ekind (Def_Id, E_Loop_Parameter); 2652 Set_Etype (Def_Id, Etype (First_Index (Typ))); 2653 end if; 2654 2655 -- Check for type error in iterator 2656 2657 elsif Typ = Any_Type then 2658 return; 2659 2660 -- Iteration over a container 2661 2662 else 2663 Mutate_Ekind (Def_Id, E_Loop_Parameter); 2664 Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N)); 2665 2666 -- OF present 2667 2668 if Of_Present (N) then 2669 if Has_Aspect (Typ, Aspect_Iterable) then 2670 declare 2671 Elt : constant Entity_Id := 2672 Get_Iterable_Type_Primitive (Typ, Name_Element); 2673 begin 2674 if No (Elt) then 2675 Error_Msg_N 2676 ("missing Element primitive for iteration", N); 2677 else 2678 Set_Etype (Def_Id, Etype (Elt)); 2679 Check_Reverse_Iteration (Typ); 2680 end if; 2681 end; 2682 2683 Check_Subtype_Definition (Etype (Def_Id)); 2684 2685 -- For a predefined container, the type of the loop variable is 2686 -- the Iterator_Element aspect of the container type. 2687 2688 else 2689 declare 2690 Element : constant Entity_Id := 2691 Find_Value_Of_Aspect 2692 (Typ, Aspect_Iterator_Element); 2693 Iterator : constant Entity_Id := 2694 Find_Value_Of_Aspect 2695 (Typ, Aspect_Default_Iterator); 2696 Orig_Iter_Name : constant Node_Id := 2697 Original_Node (Iter_Name); 2698 Cursor_Type : Entity_Id; 2699 2700 begin 2701 if No (Element) then 2702 Error_Msg_NE ("cannot iterate over&", N, Typ); 2703 return; 2704 2705 else 2706 Set_Etype (Def_Id, Entity (Element)); 2707 Cursor_Type := Get_Cursor_Type (Typ); 2708 pragma Assert (Present (Cursor_Type)); 2709 2710 Check_Subtype_Definition (Etype (Def_Id)); 2711 2712 -- If the container has a variable indexing aspect, the 2713 -- element is a variable and is modifiable in the loop. 2714 2715 if Has_Aspect (Typ, Aspect_Variable_Indexing) then 2716 Mutate_Ekind (Def_Id, E_Variable); 2717 end if; 2718 2719 -- If the container is a constant, iterating over it 2720 -- requires a Constant_Indexing operation. 2721 2722 if not Is_Variable (Iter_Name) 2723 and then not Has_Aspect (Typ, Aspect_Constant_Indexing) 2724 then 2725 Error_Msg_N 2726 ("iteration over constant container require " 2727 & "constant_indexing aspect", N); 2728 2729 -- The Iterate function may have an in_out parameter, 2730 -- and a constant container is thus illegal. 2731 2732 elsif Present (Iterator) 2733 and then Ekind (Entity (Iterator)) = E_Function 2734 and then Ekind (First_Formal (Entity (Iterator))) /= 2735 E_In_Parameter 2736 and then not Is_Variable (Iter_Name) 2737 then 2738 Error_Msg_N ("variable container expected", N); 2739 end if; 2740 2741 -- Detect a case where the iterator denotes a component 2742 -- of a mutable object which depends on a discriminant. 2743 -- Note that the iterator may denote a function call in 2744 -- qualified form, in which case this check should not 2745 -- be performed. 2746 2747 if Nkind (Orig_Iter_Name) = N_Selected_Component 2748 and then 2749 Present (Entity (Selector_Name (Orig_Iter_Name))) 2750 and then 2751 Ekind (Entity (Selector_Name (Orig_Iter_Name))) in 2752 E_Component | E_Discriminant 2753 and then Is_Dependent_Component_Of_Mutable_Object 2754 (Orig_Iter_Name) 2755 then 2756 Error_Msg_N 2757 ("container cannot be a discriminant-dependent " 2758 & "component of a mutable object", N); 2759 end if; 2760 end if; 2761 end; 2762 end if; 2763 2764 -- IN iterator, domain is a range, or a call to Iterate function 2765 2766 else 2767 -- For an iteration of the form IN, the name must denote an 2768 -- iterator, typically the result of a call to Iterate. Give a 2769 -- useful error message when the name is a container by itself. 2770 2771 -- The type may be a formal container type, which has to have 2772 -- an Iterable aspect detailing the required primitives. 2773 2774 if Is_Entity_Name (Original_Node (Name (N))) 2775 and then not Is_Iterator (Typ) 2776 then 2777 if Has_Aspect (Typ, Aspect_Iterable) then 2778 null; 2779 2780 elsif not Has_Aspect (Typ, Aspect_Iterator_Element) then 2781 Error_Msg_NE 2782 ("cannot iterate over&", Name (N), Typ); 2783 else 2784 Error_Msg_N 2785 ("name must be an iterator, not a container", Name (N)); 2786 end if; 2787 2788 if Has_Aspect (Typ, Aspect_Iterable) then 2789 null; 2790 else 2791 Error_Msg_NE 2792 ("\to iterate directly over the elements of a container, " 2793 & "write `of &`", Name (N), Original_Node (Name (N))); 2794 2795 -- No point in continuing analysis of iterator spec 2796 2797 return; 2798 end if; 2799 end if; 2800 2801 -- If the name is a call (typically prefixed) to some Iterate 2802 -- function, it has been rewritten as an object declaration. 2803 -- If that object is a selected component, verify that it is not 2804 -- a component of an unconstrained mutable object. 2805 2806 if Nkind (Iter_Name) = N_Identifier 2807 or else (not Expander_Active and Comes_From_Source (Iter_Name)) 2808 then 2809 declare 2810 Orig_Node : constant Node_Id := Original_Node (Iter_Name); 2811 Iter_Kind : constant Node_Kind := Nkind (Orig_Node); 2812 Obj : Node_Id; 2813 2814 begin 2815 if Iter_Kind = N_Selected_Component then 2816 Obj := Prefix (Orig_Node); 2817 2818 elsif Iter_Kind = N_Function_Call then 2819 Obj := First_Actual (Orig_Node); 2820 2821 -- If neither, the name comes from source 2822 2823 else 2824 Obj := Iter_Name; 2825 end if; 2826 2827 if Nkind (Obj) = N_Selected_Component 2828 and then Is_Dependent_Component_Of_Mutable_Object (Obj) 2829 then 2830 Error_Msg_N 2831 ("container cannot be a discriminant-dependent " 2832 & "component of a mutable object", N); 2833 end if; 2834 end; 2835 end if; 2836 2837 -- The result type of Iterate function is the classwide type of 2838 -- the interface parent. We need the specific Cursor type defined 2839 -- in the container package. We obtain it by name for a predefined 2840 -- container, or through the Iterable aspect for a formal one. 2841 2842 if Has_Aspect (Typ, Aspect_Iterable) then 2843 Set_Etype (Def_Id, 2844 Get_Cursor_Type 2845 (Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)), 2846 Typ)); 2847 2848 else 2849 Set_Etype (Def_Id, Get_Cursor_Type (Typ)); 2850 Check_Reverse_Iteration (Etype (Iter_Name)); 2851 end if; 2852 2853 end if; 2854 end if; 2855 2856 if Present (Iterator_Filter (N)) then 2857 -- Preanalyze the filter. Expansion will take place when enclosing 2858 -- loop is expanded. 2859 2860 Preanalyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); 2861 end if; 2862 end Analyze_Iterator_Specification; 2863 2864 ------------------- 2865 -- Analyze_Label -- 2866 ------------------- 2867 2868 -- Note: the semantic work required for analyzing labels (setting them as 2869 -- reachable) was done in a prepass through the statements in the block, 2870 -- so that forward gotos would be properly handled. See Analyze_Statements 2871 -- for further details. The only processing required here is to deal with 2872 -- optimizations that depend on an assumption of sequential control flow, 2873 -- since of course the occurrence of a label breaks this assumption. 2874 2875 procedure Analyze_Label (N : Node_Id) is 2876 pragma Warnings (Off, N); 2877 begin 2878 Kill_Current_Values; 2879 end Analyze_Label; 2880 2881 -------------------------- 2882 -- Analyze_Label_Entity -- 2883 -------------------------- 2884 2885 procedure Analyze_Label_Entity (E : Entity_Id) is 2886 begin 2887 Mutate_Ekind (E, E_Label); 2888 Set_Etype (E, Standard_Void_Type); 2889 Set_Enclosing_Scope (E, Current_Scope); 2890 Set_Reachable (E, True); 2891 end Analyze_Label_Entity; 2892 2893 ------------------------------------------ 2894 -- Analyze_Loop_Parameter_Specification -- 2895 ------------------------------------------ 2896 2897 procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is 2898 Loop_Nod : constant Node_Id := Parent (Parent (N)); 2899 2900 procedure Check_Controlled_Array_Attribute (DS : Node_Id); 2901 -- If the bounds are given by a 'Range reference on a function call 2902 -- that returns a controlled array, introduce an explicit declaration 2903 -- to capture the bounds, so that the function result can be finalized 2904 -- in timely fashion. 2905 2906 procedure Check_Predicate_Use (T : Entity_Id); 2907 -- Diagnose Attempt to iterate through non-static predicate. Note that 2908 -- a type with inherited predicates may have both static and dynamic 2909 -- forms. In this case it is not sufficent to check the static predicate 2910 -- function only, look for a dynamic predicate aspect as well. 2911 2912 procedure Process_Bounds (R : Node_Id); 2913 -- If the iteration is given by a range, create temporaries and 2914 -- assignment statements block to capture the bounds and perform 2915 -- required finalization actions in case a bound includes a function 2916 -- call that uses the temporary stack. We first preanalyze a copy of 2917 -- the range in order to determine the expected type, and analyze and 2918 -- resolve the original bounds. 2919 2920 -------------------------------------- 2921 -- Check_Controlled_Array_Attribute -- 2922 -------------------------------------- 2923 2924 procedure Check_Controlled_Array_Attribute (DS : Node_Id) is 2925 begin 2926 if Nkind (DS) = N_Attribute_Reference 2927 and then Is_Entity_Name (Prefix (DS)) 2928 and then Ekind (Entity (Prefix (DS))) = E_Function 2929 and then Is_Array_Type (Etype (Entity (Prefix (DS)))) 2930 and then 2931 Is_Controlled (Component_Type (Etype (Entity (Prefix (DS))))) 2932 and then Expander_Active 2933 then 2934 declare 2935 Loc : constant Source_Ptr := Sloc (N); 2936 Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); 2937 Indx : constant Entity_Id := 2938 Base_Type (Etype (First_Index (Arr))); 2939 Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); 2940 Decl : Node_Id; 2941 2942 begin 2943 Decl := 2944 Make_Subtype_Declaration (Loc, 2945 Defining_Identifier => Subt, 2946 Subtype_Indication => 2947 Make_Subtype_Indication (Loc, 2948 Subtype_Mark => New_Occurrence_Of (Indx, Loc), 2949 Constraint => 2950 Make_Range_Constraint (Loc, Relocate_Node (DS)))); 2951 Insert_Before (Loop_Nod, Decl); 2952 Analyze (Decl); 2953 2954 Rewrite (DS, 2955 Make_Attribute_Reference (Loc, 2956 Prefix => New_Occurrence_Of (Subt, Loc), 2957 Attribute_Name => Attribute_Name (DS))); 2958 2959 Analyze (DS); 2960 end; 2961 end if; 2962 end Check_Controlled_Array_Attribute; 2963 2964 ------------------------- 2965 -- Check_Predicate_Use -- 2966 ------------------------- 2967 2968 procedure Check_Predicate_Use (T : Entity_Id) is 2969 begin 2970 -- A predicated subtype is illegal in loops and related constructs 2971 -- if the predicate is not static, or if it is a non-static subtype 2972 -- of a statically predicated subtype. 2973 2974 if Is_Discrete_Type (T) 2975 and then Has_Predicates (T) 2976 and then (not Has_Static_Predicate (T) 2977 or else not Is_Static_Subtype (T) 2978 or else Has_Dynamic_Predicate_Aspect (T)) 2979 then 2980 -- Seems a confusing message for the case of a static predicate 2981 -- with a non-static subtype??? 2982 2983 Bad_Predicated_Subtype_Use 2984 ("cannot use subtype& with non-static predicate for loop " 2985 & "iteration", Discrete_Subtype_Definition (N), 2986 T, Suggest_Static => True); 2987 2988 elsif Inside_A_Generic 2989 and then Is_Generic_Formal (T) 2990 and then Is_Discrete_Type (T) 2991 then 2992 Set_No_Dynamic_Predicate_On_Actual (T); 2993 end if; 2994 end Check_Predicate_Use; 2995 2996 -------------------- 2997 -- Process_Bounds -- 2998 -------------------- 2999 3000 procedure Process_Bounds (R : Node_Id) is 3001 Loc : constant Source_Ptr := Sloc (N); 3002 3003 function One_Bound 3004 (Original_Bound : Node_Id; 3005 Analyzed_Bound : Node_Id; 3006 Typ : Entity_Id) return Node_Id; 3007 -- Capture value of bound and return captured value 3008 3009 --------------- 3010 -- One_Bound -- 3011 --------------- 3012 3013 function One_Bound 3014 (Original_Bound : Node_Id; 3015 Analyzed_Bound : Node_Id; 3016 Typ : Entity_Id) return Node_Id 3017 is 3018 Assign : Node_Id; 3019 Decl : Node_Id; 3020 Id : Entity_Id; 3021 3022 begin 3023 -- If the bound is a constant or an object, no need for a separate 3024 -- declaration. If the bound is the result of previous expansion 3025 -- it is already analyzed and should not be modified. Note that 3026 -- the Bound will be resolved later, if needed, as part of the 3027 -- call to Make_Index (literal bounds may need to be resolved to 3028 -- type Integer). 3029 3030 if Analyzed (Original_Bound) then 3031 return Original_Bound; 3032 3033 elsif Nkind (Analyzed_Bound) in 3034 N_Integer_Literal | N_Character_Literal 3035 or else Is_Entity_Name (Analyzed_Bound) 3036 then 3037 Analyze_And_Resolve (Original_Bound, Typ); 3038 return Original_Bound; 3039 3040 elsif Inside_Class_Condition_Preanalysis then 3041 Analyze_And_Resolve (Original_Bound, Typ); 3042 return Original_Bound; 3043 end if; 3044 3045 -- Normally, the best approach is simply to generate a constant 3046 -- declaration that captures the bound. However, there is a nasty 3047 -- case where this is wrong. If the bound is complex, and has a 3048 -- possible use of the secondary stack, we need to generate a 3049 -- separate assignment statement to ensure the creation of a block 3050 -- which will release the secondary stack. 3051 3052 -- We prefer the constant declaration, since it leaves us with a 3053 -- proper trace of the value, useful in optimizations that get rid 3054 -- of junk range checks. 3055 3056 if not Has_Sec_Stack_Call (Analyzed_Bound) then 3057 Analyze_And_Resolve (Original_Bound, Typ); 3058 3059 -- Ensure that the bound is valid. This check should not be 3060 -- generated when the range belongs to a quantified expression 3061 -- as the construct is still not expanded into its final form. 3062 3063 if Nkind (Parent (R)) /= N_Loop_Parameter_Specification 3064 or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression 3065 then 3066 Ensure_Valid (Original_Bound); 3067 end if; 3068 3069 Force_Evaluation (Original_Bound); 3070 return Original_Bound; 3071 end if; 3072 3073 Id := Make_Temporary (Loc, 'R', Original_Bound); 3074 3075 -- Here we make a declaration with a separate assignment 3076 -- statement, and insert before loop header. 3077 3078 Decl := 3079 Make_Object_Declaration (Loc, 3080 Defining_Identifier => Id, 3081 Object_Definition => New_Occurrence_Of (Typ, Loc)); 3082 3083 Assign := 3084 Make_Assignment_Statement (Loc, 3085 Name => New_Occurrence_Of (Id, Loc), 3086 Expression => Relocate_Node (Original_Bound)); 3087 3088 Insert_Actions (Loop_Nod, New_List (Decl, Assign)); 3089 3090 -- Now that this temporary variable is initialized we decorate it 3091 -- as safe-to-reevaluate to inform to the backend that no further 3092 -- asignment will be issued and hence it can be handled as side 3093 -- effect free. Note that this decoration must be done when the 3094 -- assignment has been analyzed because otherwise it will be 3095 -- rejected (see Analyze_Assignment). 3096 3097 Set_Is_Safe_To_Reevaluate (Id); 3098 3099 Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); 3100 3101 if Nkind (Assign) = N_Assignment_Statement then 3102 return Expression (Assign); 3103 else 3104 return Original_Bound; 3105 end if; 3106 end One_Bound; 3107 3108 Hi : constant Node_Id := High_Bound (R); 3109 Lo : constant Node_Id := Low_Bound (R); 3110 R_Copy : constant Node_Id := New_Copy_Tree (R); 3111 New_Hi : Node_Id; 3112 New_Lo : Node_Id; 3113 Typ : Entity_Id; 3114 3115 -- Start of processing for Process_Bounds 3116 3117 begin 3118 Set_Parent (R_Copy, Parent (R)); 3119 Preanalyze_Range (R_Copy); 3120 Typ := Etype (R_Copy); 3121 3122 -- If the type of the discrete range is Universal_Integer, then the 3123 -- bound's type must be resolved to Integer, and any object used to 3124 -- hold the bound must also have type Integer, unless the literal 3125 -- bounds are constant-folded expressions with a user-defined type. 3126 3127 if Typ = Universal_Integer then 3128 if Nkind (Lo) = N_Integer_Literal 3129 and then Present (Etype (Lo)) 3130 and then Scope (Etype (Lo)) /= Standard_Standard 3131 then 3132 Typ := Etype (Lo); 3133 3134 elsif Nkind (Hi) = N_Integer_Literal 3135 and then Present (Etype (Hi)) 3136 and then Scope (Etype (Hi)) /= Standard_Standard 3137 then 3138 Typ := Etype (Hi); 3139 3140 else 3141 Typ := Standard_Integer; 3142 end if; 3143 end if; 3144 3145 Set_Etype (R, Typ); 3146 3147 New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ); 3148 New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ); 3149 3150 -- Propagate staticness to loop range itself, in case the 3151 -- corresponding subtype is static. 3152 3153 if New_Lo /= Lo and then Is_OK_Static_Expression (New_Lo) then 3154 Rewrite (Low_Bound (R), New_Copy (New_Lo)); 3155 end if; 3156 3157 if New_Hi /= Hi and then Is_OK_Static_Expression (New_Hi) then 3158 Rewrite (High_Bound (R), New_Copy (New_Hi)); 3159 end if; 3160 end Process_Bounds; 3161 3162 -- Local variables 3163 3164 DS : constant Node_Id := Discrete_Subtype_Definition (N); 3165 Id : constant Entity_Id := Defining_Identifier (N); 3166 3167 DS_Copy : Node_Id; 3168 3169 -- Start of processing for Analyze_Loop_Parameter_Specification 3170 3171 begin 3172 Enter_Name (Id); 3173 3174 -- We always consider the loop variable to be referenced, since the loop 3175 -- may be used just for counting purposes. 3176 3177 Generate_Reference (Id, N, ' '); 3178 3179 -- Check for the case of loop variable hiding a local variable (used 3180 -- later on to give a nice warning if the hidden variable is never 3181 -- assigned). 3182 3183 declare 3184 H : constant Entity_Id := Homonym (Id); 3185 begin 3186 if Present (H) 3187 and then Ekind (H) = E_Variable 3188 and then Is_Discrete_Type (Etype (H)) 3189 and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id) 3190 then 3191 Set_Hiding_Loop_Variable (H, Id); 3192 end if; 3193 end; 3194 3195 -- Analyze the subtype definition and create temporaries for the bounds. 3196 -- Do not evaluate the range when preanalyzing a quantified expression 3197 -- because bounds expressed as function calls with side effects will be 3198 -- incorrectly replicated. 3199 3200 if Nkind (DS) = N_Range 3201 and then Expander_Active 3202 and then Nkind (Parent (N)) /= N_Quantified_Expression 3203 then 3204 Process_Bounds (DS); 3205 3206 -- Either the expander not active or the range of iteration is a subtype 3207 -- indication, an entity, or a function call that yields an aggregate or 3208 -- a container. 3209 3210 else 3211 DS_Copy := New_Copy_Tree (DS); 3212 Set_Parent (DS_Copy, Parent (DS)); 3213 Preanalyze_Range (DS_Copy); 3214 3215 -- Ada 2012: If the domain of iteration is: 3216 3217 -- a) a function call, 3218 -- b) an identifier that is not a type, 3219 -- c) an attribute reference 'Old (within a postcondition), 3220 -- d) an unchecked conversion or a qualified expression with 3221 -- the proper iterator type. 3222 3223 -- then it is an iteration over a container. It was classified as 3224 -- a loop specification by the parser, and must be rewritten now 3225 -- to activate container iteration. The last case will occur within 3226 -- an expanded inlined call, where the expansion wraps an actual in 3227 -- an unchecked conversion when needed. The expression of the 3228 -- conversion is always an object. 3229 3230 if Nkind (DS_Copy) = N_Function_Call 3231 3232 or else (Is_Entity_Name (DS_Copy) 3233 and then not Is_Type (Entity (DS_Copy))) 3234 3235 or else (Nkind (DS_Copy) = N_Attribute_Reference 3236 and then Attribute_Name (DS_Copy) in 3237 Name_Loop_Entry | Name_Old) 3238 3239 or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable) 3240 3241 or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion 3242 or else (Nkind (DS_Copy) = N_Qualified_Expression 3243 and then Is_Iterator (Etype (DS_Copy))) 3244 then 3245 -- This is an iterator specification. Rewrite it as such and 3246 -- analyze it to capture function calls that may require 3247 -- finalization actions. 3248 3249 declare 3250 I_Spec : constant Node_Id := 3251 Make_Iterator_Specification (Sloc (N), 3252 Defining_Identifier => Relocate_Node (Id), 3253 Name => DS_Copy, 3254 Subtype_Indication => Empty, 3255 Reverse_Present => Reverse_Present (N)); 3256 Scheme : constant Node_Id := Parent (N); 3257 3258 begin 3259 Set_Iterator_Specification (Scheme, I_Spec); 3260 Set_Loop_Parameter_Specification (Scheme, Empty); 3261 Set_Iterator_Filter (I_Spec, 3262 Relocate_Node (Iterator_Filter (N))); 3263 3264 Analyze_Iterator_Specification (I_Spec); 3265 3266 -- In a generic context, analyze the original domain of 3267 -- iteration, for name capture. 3268 3269 if not Expander_Active then 3270 Analyze (DS); 3271 end if; 3272 3273 -- Set kind of loop parameter, which may be used in the 3274 -- subsequent analysis of the condition in a quantified 3275 -- expression. 3276 3277 Mutate_Ekind (Id, E_Loop_Parameter); 3278 return; 3279 end; 3280 3281 -- Domain of iteration is not a function call, and is side-effect 3282 -- free. 3283 3284 else 3285 -- A quantified expression that appears in a pre/post condition 3286 -- is preanalyzed several times. If the range is given by an 3287 -- attribute reference it is rewritten as a range, and this is 3288 -- done even with expansion disabled. If the type is already set 3289 -- do not reanalyze, because a range with static bounds may be 3290 -- typed Integer by default. 3291 3292 if Nkind (Parent (N)) = N_Quantified_Expression 3293 and then Present (Etype (DS)) 3294 then 3295 null; 3296 else 3297 Analyze (DS); 3298 end if; 3299 end if; 3300 end if; 3301 3302 if DS = Error then 3303 return; 3304 end if; 3305 3306 -- Some additional checks if we are iterating through a type 3307 3308 if Is_Entity_Name (DS) 3309 and then Present (Entity (DS)) 3310 and then Is_Type (Entity (DS)) 3311 then 3312 -- The subtype indication may denote the completion of an incomplete 3313 -- type declaration. 3314 3315 if Ekind (Entity (DS)) = E_Incomplete_Type then 3316 Set_Entity (DS, Get_Full_View (Entity (DS))); 3317 Set_Etype (DS, Entity (DS)); 3318 end if; 3319 3320 Check_Predicate_Use (Entity (DS)); 3321 end if; 3322 3323 -- Error if not discrete type 3324 3325 if not Is_Discrete_Type (Etype (DS)) then 3326 Wrong_Type (DS, Any_Discrete); 3327 Set_Etype (DS, Any_Type); 3328 end if; 3329 3330 Check_Controlled_Array_Attribute (DS); 3331 3332 if Nkind (DS) = N_Subtype_Indication then 3333 Check_Predicate_Use (Entity (Subtype_Mark (DS))); 3334 end if; 3335 3336 if Nkind (DS) not in N_Raise_xxx_Error then 3337 Make_Index (DS, N); 3338 end if; 3339 3340 Mutate_Ekind (Id, E_Loop_Parameter); 3341 3342 -- A quantified expression which appears in a pre- or post-condition may 3343 -- be analyzed multiple times. The analysis of the range creates several 3344 -- itypes which reside in different scopes depending on whether the pre- 3345 -- or post-condition has been expanded. Update the type of the loop 3346 -- variable to reflect the proper itype at each stage of analysis. 3347 3348 -- Loop_Nod might not be present when we are preanalyzing a class-wide 3349 -- pre/postcondition since preanalysis occurs in a place unrelated to 3350 -- the actual code and the quantified expression may be the outermost 3351 -- expression of the class-wide condition. 3352 3353 if No (Etype (Id)) 3354 or else Etype (Id) = Any_Type 3355 or else 3356 (Present (Etype (Id)) 3357 and then Is_Itype (Etype (Id)) 3358 and then Present (Loop_Nod) 3359 and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions 3360 and then Nkind (Original_Node (Parent (Loop_Nod))) = 3361 N_Quantified_Expression) 3362 then 3363 Set_Etype (Id, Etype (DS)); 3364 end if; 3365 3366 -- Treat a range as an implicit reference to the type, to inhibit 3367 -- spurious warnings. 3368 3369 Generate_Reference (Base_Type (Etype (DS)), N, ' '); 3370 Set_Is_Known_Valid (Id, True); 3371 3372 -- The loop is not a declarative part, so the loop variable must be 3373 -- frozen explicitly. Do not freeze while preanalyzing a quantified 3374 -- expression because the freeze node will not be inserted into the 3375 -- tree due to flag Is_Spec_Expression being set. 3376 3377 if Nkind (Parent (N)) /= N_Quantified_Expression then 3378 declare 3379 Flist : constant List_Id := Freeze_Entity (Id, N); 3380 begin 3381 if Is_Non_Empty_List (Flist) then 3382 Insert_Actions (N, Flist); 3383 end if; 3384 end; 3385 end if; 3386 3387 -- Case where we have a range or a subtype, get type bounds 3388 3389 if Nkind (DS) in N_Range | N_Subtype_Indication 3390 and then not Error_Posted (DS) 3391 and then Etype (DS) /= Any_Type 3392 and then Is_Discrete_Type (Etype (DS)) 3393 then 3394 declare 3395 L : Node_Id; 3396 H : Node_Id; 3397 Null_Range : Boolean := False; 3398 3399 begin 3400 if Nkind (DS) = N_Range then 3401 L := Low_Bound (DS); 3402 H := High_Bound (DS); 3403 else 3404 L := 3405 Type_Low_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); 3406 H := 3407 Type_High_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); 3408 end if; 3409 3410 -- Check for null or possibly null range and issue warning. We 3411 -- suppress such messages in generic templates and instances, 3412 -- because in practice they tend to be dubious in these cases. The 3413 -- check applies as well to rewritten array element loops where a 3414 -- null range may be detected statically. 3415 3416 if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then 3417 if Compile_Time_Compare (L, H, Assume_Valid => False) = GT then 3418 -- Since we know the range of the loop is always null, 3419 -- set the appropriate flag to remove the loop entirely 3420 -- during expansion. 3421 3422 Set_Is_Null_Loop (Loop_Nod); 3423 Null_Range := True; 3424 end if; 3425 3426 -- Suppress the warning if inside a generic template or 3427 -- instance, since in practice they tend to be dubious in these 3428 -- cases since they can result from intended parameterization. 3429 3430 if not Inside_A_Generic and then not In_Instance then 3431 3432 -- Specialize msg if invalid values could make the loop 3433 -- non-null after all. 3434 3435 if Null_Range then 3436 if Comes_From_Source (N) then 3437 Error_Msg_N 3438 ("??loop range is null, loop will not execute", DS); 3439 end if; 3440 3441 -- Here is where the loop could execute because of 3442 -- invalid values, so issue appropriate message. 3443 3444 elsif Comes_From_Source (N) then 3445 Error_Msg_N 3446 ("??loop range may be null, loop may not execute", 3447 DS); 3448 Error_Msg_N 3449 ("??can only execute if invalid values are present", 3450 DS); 3451 end if; 3452 end if; 3453 3454 -- In either case, suppress warnings in the body of the loop, 3455 -- since it is likely that these warnings will be inappropriate 3456 -- if the loop never actually executes, which is likely. 3457 3458 Set_Suppress_Loop_Warnings (Loop_Nod); 3459 3460 -- The other case for a warning is a reverse loop where the 3461 -- upper bound is the integer literal zero or one, and the 3462 -- lower bound may exceed this value. 3463 3464 -- For example, we have 3465 3466 -- for J in reverse N .. 1 loop 3467 3468 -- In practice, this is very likely to be a case of reversing 3469 -- the bounds incorrectly in the range. 3470 3471 elsif Reverse_Present (N) 3472 and then Nkind (Original_Node (H)) = N_Integer_Literal 3473 and then 3474 (Intval (Original_Node (H)) = Uint_0 3475 or else 3476 Intval (Original_Node (H)) = Uint_1) 3477 then 3478 -- Lower bound may in fact be known and known not to exceed 3479 -- upper bound (e.g. reverse 0 .. 1) and that's OK. 3480 3481 if Compile_Time_Known_Value (L) 3482 and then Expr_Value (L) <= Expr_Value (H) 3483 then 3484 null; 3485 3486 -- Otherwise warning is warranted 3487 3488 else 3489 Error_Msg_N ("??loop range may be null", DS); 3490 Error_Msg_N ("\??bounds may be wrong way round", DS); 3491 end if; 3492 end if; 3493 3494 -- Check if either bound is known to be outside the range of the 3495 -- loop parameter type, this is e.g. the case of a loop from 3496 -- 20..X where the type is 1..19. 3497 3498 -- Such a loop is dubious since either it raises CE or it executes 3499 -- zero times, and that cannot be useful! 3500 3501 if Etype (DS) /= Any_Type 3502 and then not Error_Posted (DS) 3503 and then Nkind (DS) = N_Subtype_Indication 3504 and then Nkind (Constraint (DS)) = N_Range_Constraint 3505 then 3506 declare 3507 LLo : constant Node_Id := 3508 Low_Bound (Range_Expression (Constraint (DS))); 3509 LHi : constant Node_Id := 3510 High_Bound (Range_Expression (Constraint (DS))); 3511 3512 Bad_Bound : Node_Id := Empty; 3513 -- Suspicious loop bound 3514 3515 begin 3516 -- At this stage L, H are the bounds of the type, and LLo 3517 -- Lhi are the low bound and high bound of the loop. 3518 3519 if Compile_Time_Compare (LLo, L, Assume_Valid => True) = LT 3520 or else 3521 Compile_Time_Compare (LLo, H, Assume_Valid => True) = GT 3522 then 3523 Bad_Bound := LLo; 3524 end if; 3525 3526 if Compile_Time_Compare (LHi, L, Assume_Valid => True) = LT 3527 or else 3528 Compile_Time_Compare (LHi, H, Assume_Valid => True) = GT 3529 then 3530 Bad_Bound := LHi; 3531 end if; 3532 3533 if Present (Bad_Bound) then 3534 Error_Msg_N 3535 ("suspicious loop bound out of range of " 3536 & "loop subtype??", Bad_Bound); 3537 Error_Msg_N 3538 ("\loop executes zero times or raises " 3539 & "Constraint_Error??", Bad_Bound); 3540 end if; 3541 3542 if Compile_Time_Compare (LLo, LHi, Assume_Valid => False) 3543 = GT 3544 then 3545 Error_Msg_N ("??constrained range is null", 3546 Constraint (DS)); 3547 3548 -- Additional constraints on modular types can be 3549 -- confusing, add more information. 3550 3551 if Ekind (Etype (DS)) = E_Modular_Integer_Subtype then 3552 Error_Msg_Uint_1 := Intval (LLo); 3553 Error_Msg_Uint_2 := Intval (LHi); 3554 Error_Msg_NE ("\iterator has modular type &, " & 3555 "so the loop has bounds ^ ..^", 3556 Constraint (DS), 3557 Subtype_Mark (DS)); 3558 end if; 3559 3560 Set_Is_Null_Loop (Loop_Nod); 3561 Null_Range := True; 3562 3563 -- Suppress other warnigns about the body of the loop, as 3564 -- it will never execute. 3565 Set_Suppress_Loop_Warnings (Loop_Nod); 3566 end if; 3567 end; 3568 end if; 3569 3570 -- This declare block is about warnings, if we get an exception while 3571 -- testing for warnings, we simply abandon the attempt silently. This 3572 -- most likely occurs as the result of a previous error, but might 3573 -- just be an obscure case we have missed. In either case, not giving 3574 -- the warning is perfectly acceptable. 3575 3576 exception 3577 when others => 3578 -- With debug flag K we will get an exception unless an error 3579 -- has already occurred (useful for debugging). 3580 3581 if Debug_Flag_K then 3582 Check_Error_Detected; 3583 end if; 3584 end; 3585 end if; 3586 3587 if Present (Iterator_Filter (N)) then 3588 Analyze_And_Resolve (Iterator_Filter (N), Standard_Boolean); 3589 end if; 3590 3591 -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). 3592 -- This check is relevant only when SPARK_Mode is on as it is not a 3593 -- standard Ada legality check. 3594 3595 if SPARK_Mode = On and then Is_Effectively_Volatile (Id) then 3596 Error_Msg_N ("loop parameter cannot be volatile", Id); 3597 end if; 3598 end Analyze_Loop_Parameter_Specification; 3599 3600 ---------------------------- 3601 -- Analyze_Loop_Statement -- 3602 ---------------------------- 3603 3604 procedure Analyze_Loop_Statement (N : Node_Id) is 3605 3606 -- The following exception is raised by routine Prepare_Loop_Statement 3607 -- to avoid further analysis of a transformed loop. 3608 3609 procedure Prepare_Loop_Statement 3610 (Iter : Node_Id; 3611 Stop_Processing : out Boolean); 3612 -- Determine whether loop statement N with iteration scheme Iter must be 3613 -- transformed prior to analysis, and if so, perform it. 3614 -- If Stop_Processing is set to True, should stop further processing. 3615 3616 ---------------------------- 3617 -- Prepare_Loop_Statement -- 3618 ---------------------------- 3619 3620 procedure Prepare_Loop_Statement 3621 (Iter : Node_Id; 3622 Stop_Processing : out Boolean) 3623 is 3624 function Has_Sec_Stack_Default_Iterator 3625 (Cont_Typ : Entity_Id) return Boolean; 3626 pragma Inline (Has_Sec_Stack_Default_Iterator); 3627 -- Determine whether container type Cont_Typ has a default iterator 3628 -- that requires secondary stack management. 3629 3630 function Is_Sec_Stack_Iteration_Primitive 3631 (Cont_Typ : Entity_Id; 3632 Iter_Prim_Nam : Name_Id) return Boolean; 3633 pragma Inline (Is_Sec_Stack_Iteration_Primitive); 3634 -- Determine whether container type Cont_Typ has an iteration routine 3635 -- described by its name Iter_Prim_Nam that requires secondary stack 3636 -- management. 3637 3638 function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean; 3639 pragma Inline (Is_Wrapped_In_Block); 3640 -- Determine whether arbitrary statement Stmt is the sole statement 3641 -- wrapped within some block, excluding pragmas. 3642 3643 procedure Prepare_Iterator_Loop 3644 (Iter_Spec : Node_Id; 3645 Stop_Processing : out Boolean); 3646 pragma Inline (Prepare_Iterator_Loop); 3647 -- Prepare an iterator loop with iteration specification Iter_Spec 3648 -- for transformation if needed. 3649 -- If Stop_Processing is set to True, should stop further processing. 3650 3651 procedure Prepare_Param_Spec_Loop 3652 (Param_Spec : Node_Id; 3653 Stop_Processing : out Boolean); 3654 pragma Inline (Prepare_Param_Spec_Loop); 3655 -- Prepare a discrete loop with parameter specification Param_Spec 3656 -- for transformation if needed. 3657 -- If Stop_Processing is set to True, should stop further processing. 3658 3659 procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean); 3660 pragma Inline (Wrap_Loop_Statement); 3661 -- Wrap loop statement N within a block. Flag Manage_Sec_Stack must 3662 -- be set when the block must mark and release the secondary stack. 3663 -- Should stop further processing after calling this procedure. 3664 3665 ------------------------------------ 3666 -- Has_Sec_Stack_Default_Iterator -- 3667 ------------------------------------ 3668 3669 function Has_Sec_Stack_Default_Iterator 3670 (Cont_Typ : Entity_Id) return Boolean 3671 is 3672 Def_Iter : constant Node_Id := 3673 Find_Value_Of_Aspect 3674 (Cont_Typ, Aspect_Default_Iterator); 3675 begin 3676 return 3677 Present (Def_Iter) 3678 and then Requires_Transient_Scope (Etype (Def_Iter)); 3679 end Has_Sec_Stack_Default_Iterator; 3680 3681 -------------------------------------- 3682 -- Is_Sec_Stack_Iteration_Primitive -- 3683 -------------------------------------- 3684 3685 function Is_Sec_Stack_Iteration_Primitive 3686 (Cont_Typ : Entity_Id; 3687 Iter_Prim_Nam : Name_Id) return Boolean 3688 is 3689 Iter_Prim : constant Entity_Id := 3690 Get_Iterable_Type_Primitive 3691 (Cont_Typ, Iter_Prim_Nam); 3692 begin 3693 return 3694 Present (Iter_Prim) 3695 and then Requires_Transient_Scope (Etype (Iter_Prim)); 3696 end Is_Sec_Stack_Iteration_Primitive; 3697 3698 ------------------------- 3699 -- Is_Wrapped_In_Block -- 3700 ------------------------- 3701 3702 function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean is 3703 Blk_HSS : Node_Id; 3704 Blk_Id : Entity_Id; 3705 Blk_Stmt : Node_Id; 3706 3707 begin 3708 Blk_Id := Current_Scope; 3709 3710 -- The current context is a block. Inspect the statements of the 3711 -- block to determine whether it wraps Stmt. 3712 3713 if Ekind (Blk_Id) = E_Block 3714 and then Present (Block_Node (Blk_Id)) 3715 then 3716 Blk_HSS := 3717 Handled_Statement_Sequence (Parent (Block_Node (Blk_Id))); 3718 3719 -- Skip leading pragmas introduced for invariant and predicate 3720 -- checks. 3721 3722 Blk_Stmt := First (Statements (Blk_HSS)); 3723 while Present (Blk_Stmt) 3724 and then Nkind (Blk_Stmt) = N_Pragma 3725 loop 3726 Next (Blk_Stmt); 3727 end loop; 3728 3729 return Blk_Stmt = Stmt and then No (Next (Blk_Stmt)); 3730 end if; 3731 3732 return False; 3733 end Is_Wrapped_In_Block; 3734 3735 --------------------------- 3736 -- Prepare_Iterator_Loop -- 3737 --------------------------- 3738 3739 procedure Prepare_Iterator_Loop 3740 (Iter_Spec : Node_Id; 3741 Stop_Processing : out Boolean) 3742 is 3743 Cont_Typ : Entity_Id; 3744 Nam : Node_Id; 3745 Nam_Copy : Node_Id; 3746 3747 begin 3748 Stop_Processing := False; 3749 3750 -- The iterator specification has syntactic errors. Transform the 3751 -- loop into an infinite loop in order to safely perform at least 3752 -- some minor analysis. This check must come first. 3753 3754 if Error_Posted (Iter_Spec) then 3755 Set_Iteration_Scheme (N, Empty); 3756 Analyze (N); 3757 Stop_Processing := True; 3758 3759 -- Nothing to do when the loop is already wrapped in a block 3760 3761 elsif Is_Wrapped_In_Block (N) then 3762 null; 3763 3764 -- Otherwise the iterator loop traverses an array or a container 3765 -- and appears in the form 3766 -- 3767 -- for Def_Id in [reverse] Iterator_Name loop 3768 -- for Def_Id [: Subtyp_Indic] of [reverse] Iterable_Name loop 3769 3770 else 3771 -- Prepare a copy of the iterated name for preanalysis. The 3772 -- copy is semi inserted into the tree by setting its Parent 3773 -- pointer. 3774 3775 Nam := Name (Iter_Spec); 3776 Nam_Copy := New_Copy_Tree (Nam); 3777 Set_Parent (Nam_Copy, Parent (Nam)); 3778 3779 -- Determine what the loop is iterating on 3780 3781 Preanalyze_Range (Nam_Copy); 3782 Cont_Typ := Etype (Nam_Copy); 3783 3784 -- The iterator loop is traversing an array. This case does not 3785 -- require any transformation. 3786 3787 if Is_Array_Type (Cont_Typ) then 3788 null; 3789 3790 -- Otherwise unconditionally wrap the loop statement within 3791 -- a block. The expansion of iterator loops may relocate the 3792 -- iterator outside the loop, thus "leaking" its entity into 3793 -- the enclosing scope. Wrapping the loop statement allows 3794 -- for multiple iterator loops using the same iterator name 3795 -- to coexist within the same scope. 3796 -- 3797 -- The block must manage the secondary stack when the iterator 3798 -- loop is traversing a container using either 3799 -- 3800 -- * A default iterator obtained on the secondary stack 3801 -- 3802 -- * Call to Iterate where the iterator is returned on the 3803 -- secondary stack. 3804 -- 3805 -- * Combination of First, Next, and Has_Element where the 3806 -- first two return a cursor on the secondary stack. 3807 3808 else 3809 Wrap_Loop_Statement 3810 (Manage_Sec_Stack => 3811 Has_Sec_Stack_Default_Iterator (Cont_Typ) 3812 or else Has_Sec_Stack_Call (Nam_Copy) 3813 or else Is_Sec_Stack_Iteration_Primitive 3814 (Cont_Typ, Name_First) 3815 or else Is_Sec_Stack_Iteration_Primitive 3816 (Cont_Typ, Name_Next)); 3817 Stop_Processing := True; 3818 end if; 3819 end if; 3820 end Prepare_Iterator_Loop; 3821 3822 ----------------------------- 3823 -- Prepare_Param_Spec_Loop -- 3824 ----------------------------- 3825 3826 procedure Prepare_Param_Spec_Loop 3827 (Param_Spec : Node_Id; 3828 Stop_Processing : out Boolean) 3829 is 3830 High : Node_Id; 3831 Low : Node_Id; 3832 Rng : Node_Id; 3833 Rng_Copy : Node_Id; 3834 Rng_Typ : Entity_Id; 3835 3836 begin 3837 Stop_Processing := False; 3838 Rng := Discrete_Subtype_Definition (Param_Spec); 3839 3840 -- Nothing to do when the loop is already wrapped in a block 3841 3842 if Is_Wrapped_In_Block (N) then 3843 null; 3844 3845 -- The parameter specification appears in the form 3846 -- 3847 -- for Def_Id in Subtype_Mark Constraint loop 3848 3849 elsif Nkind (Rng) = N_Subtype_Indication 3850 and then Nkind (Range_Expression (Constraint (Rng))) = N_Range 3851 then 3852 Rng := Range_Expression (Constraint (Rng)); 3853 3854 -- Preanalyze the bounds of the range constraint, setting 3855 -- parent fields to associate the copied bounds with the range, 3856 -- allowing proper tree climbing during preanalysis. 3857 3858 Low := New_Copy_Tree (Low_Bound (Rng)); 3859 High := New_Copy_Tree (High_Bound (Rng)); 3860 3861 Set_Parent (Low, Rng); 3862 Set_Parent (High, Rng); 3863 3864 Preanalyze (Low); 3865 Preanalyze (High); 3866 3867 -- The bounds contain at least one function call that returns 3868 -- on the secondary stack. Note that the loop must be wrapped 3869 -- only when such a call exists. 3870 3871 if Has_Sec_Stack_Call (Low) or else Has_Sec_Stack_Call (High) 3872 then 3873 Wrap_Loop_Statement (Manage_Sec_Stack => True); 3874 Stop_Processing := True; 3875 end if; 3876 3877 -- Otherwise the parameter specification appears in the form 3878 -- 3879 -- for Def_Id in Range loop 3880 3881 else 3882 -- Prepare a copy of the discrete range for preanalysis. The 3883 -- copy is semi inserted into the tree by setting its Parent 3884 -- pointer. 3885 3886 Rng_Copy := New_Copy_Tree (Rng); 3887 Set_Parent (Rng_Copy, Parent (Rng)); 3888 3889 -- Determine what the loop is iterating on 3890 3891 Preanalyze_Range (Rng_Copy); 3892 Rng_Typ := Etype (Rng_Copy); 3893 3894 -- Wrap the loop statement within a block in order to manage 3895 -- the secondary stack when the discrete range is 3896 -- 3897 -- * Either a Forward_Iterator or a Reverse_Iterator 3898 -- 3899 -- * Function call whose return type requires finalization 3900 -- actions. 3901 3902 -- ??? it is unclear why using Has_Sec_Stack_Call directly on 3903 -- the discrete range causes the freeze node of an itype to be 3904 -- in the wrong scope in complex assertion expressions. 3905 3906 if Is_Iterator (Rng_Typ) 3907 or else (Nkind (Rng_Copy) = N_Function_Call 3908 and then Needs_Finalization (Rng_Typ)) 3909 then 3910 Wrap_Loop_Statement (Manage_Sec_Stack => True); 3911 Stop_Processing := True; 3912 end if; 3913 end if; 3914 end Prepare_Param_Spec_Loop; 3915 3916 ------------------------- 3917 -- Wrap_Loop_Statement -- 3918 ------------------------- 3919 3920 procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean) is 3921 Loc : constant Source_Ptr := Sloc (N); 3922 3923 Blk : Node_Id; 3924 Blk_Id : Entity_Id; 3925 3926 begin 3927 Blk := 3928 Make_Block_Statement (Loc, 3929 Declarations => New_List, 3930 Handled_Statement_Sequence => 3931 Make_Handled_Sequence_Of_Statements (Loc, 3932 Statements => New_List (Relocate_Node (N)))); 3933 3934 Add_Block_Identifier (Blk, Blk_Id); 3935 Set_Uses_Sec_Stack (Blk_Id, Manage_Sec_Stack); 3936 3937 Rewrite (N, Blk); 3938 Analyze (N); 3939 end Wrap_Loop_Statement; 3940 3941 -- Local variables 3942 3943 Iter_Spec : constant Node_Id := Iterator_Specification (Iter); 3944 Param_Spec : constant Node_Id := Loop_Parameter_Specification (Iter); 3945 3946 -- Start of processing for Prepare_Loop_Statement 3947 3948 begin 3949 Stop_Processing := False; 3950 3951 if Present (Iter_Spec) then 3952 Prepare_Iterator_Loop (Iter_Spec, Stop_Processing); 3953 3954 elsif Present (Param_Spec) then 3955 Prepare_Param_Spec_Loop (Param_Spec, Stop_Processing); 3956 end if; 3957 end Prepare_Loop_Statement; 3958 3959 -- Local declarations 3960 3961 Id : constant Node_Id := Identifier (N); 3962 Iter : constant Node_Id := Iteration_Scheme (N); 3963 Loc : constant Source_Ptr := Sloc (N); 3964 Ent : Entity_Id; 3965 Stmt : Node_Id; 3966 3967 -- Start of processing for Analyze_Loop_Statement 3968 3969 begin 3970 if Present (Id) then 3971 3972 -- Make name visible, e.g. for use in exit statements. Loop labels 3973 -- are always considered to be referenced. 3974 3975 Analyze (Id); 3976 Ent := Entity (Id); 3977 3978 -- Guard against serious error (typically, a scope mismatch when 3979 -- semantic analysis is requested) by creating loop entity to 3980 -- continue analysis. 3981 3982 if No (Ent) then 3983 if Total_Errors_Detected /= 0 then 3984 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 3985 else 3986 raise Program_Error; 3987 end if; 3988 3989 -- Verify that the loop name is hot hidden by an unrelated 3990 -- declaration in an inner scope. 3991 3992 elsif Ekind (Ent) /= E_Label and then Ekind (Ent) /= E_Loop then 3993 Error_Msg_Sloc := Sloc (Ent); 3994 Error_Msg_N ("implicit label declaration for & is hidden#", Id); 3995 3996 if Present (Homonym (Ent)) 3997 and then Ekind (Homonym (Ent)) = E_Label 3998 then 3999 Set_Entity (Id, Ent); 4000 Mutate_Ekind (Ent, E_Loop); 4001 end if; 4002 4003 else 4004 Generate_Reference (Ent, N, ' '); 4005 Generate_Definition (Ent); 4006 4007 -- If we found a label, mark its type. If not, ignore it, since it 4008 -- means we have a conflicting declaration, which would already 4009 -- have been diagnosed at declaration time. Set Label_Construct 4010 -- of the implicit label declaration, which is not created by the 4011 -- parser for generic units. 4012 4013 if Ekind (Ent) = E_Label then 4014 Reinit_Field_To_Zero (Ent, F_Enclosing_Scope); 4015 Mutate_Ekind (Ent, E_Loop); 4016 4017 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then 4018 Set_Label_Construct (Parent (Ent), N); 4019 end if; 4020 end if; 4021 end if; 4022 4023 -- Case of no identifier present. Create one and attach it to the 4024 -- loop statement for use as a scope and as a reference for later 4025 -- expansions. Indicate that the label does not come from source, 4026 -- and attach it to the loop statement so it is part of the tree, 4027 -- even without a full declaration. 4028 4029 else 4030 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 4031 Set_Etype (Ent, Standard_Void_Type); 4032 Set_Identifier (N, New_Occurrence_Of (Ent, Loc)); 4033 Set_Parent (Ent, N); 4034 Set_Has_Created_Identifier (N); 4035 end if; 4036 4037 -- Determine whether the loop statement must be transformed prior to 4038 -- analysis, and if so, perform it. This early modification is needed 4039 -- when: 4040 -- 4041 -- * The loop has an erroneous iteration scheme. In this case the 4042 -- loop is converted into an infinite loop in order to perform 4043 -- minor analysis. 4044 -- 4045 -- * The loop is an Ada 2012 iterator loop. In this case the loop is 4046 -- wrapped within a block to provide a local scope for the iterator. 4047 -- If the iterator specification requires the secondary stack in any 4048 -- way, the block is marked in order to manage it. 4049 -- 4050 -- * The loop is using a parameter specification where the discrete 4051 -- range requires the secondary stack. In this case the loop is 4052 -- wrapped within a block in order to manage the secondary stack. 4053 4054 if Present (Iter) then 4055 declare 4056 Stop_Processing : Boolean; 4057 begin 4058 Prepare_Loop_Statement (Iter, Stop_Processing); 4059 4060 if Stop_Processing then 4061 return; 4062 end if; 4063 end; 4064 end if; 4065 4066 -- Kill current values on entry to loop, since statements in the body of 4067 -- the loop may have been executed before the loop is entered. Similarly 4068 -- we kill values after the loop, since we do not know that the body of 4069 -- the loop was executed. 4070 4071 Kill_Current_Values; 4072 Push_Scope (Ent); 4073 Analyze_Iteration_Scheme (Iter); 4074 4075 -- Check for following case which merits a warning if the type E of is 4076 -- a multi-dimensional array (and no explicit subscript ranges present). 4077 4078 -- for J in E'Range 4079 -- for K in E'Range 4080 4081 if Present (Iter) 4082 and then Present (Loop_Parameter_Specification (Iter)) 4083 then 4084 declare 4085 LPS : constant Node_Id := Loop_Parameter_Specification (Iter); 4086 DSD : constant Node_Id := 4087 Original_Node (Discrete_Subtype_Definition (LPS)); 4088 begin 4089 if Nkind (DSD) = N_Attribute_Reference 4090 and then Attribute_Name (DSD) = Name_Range 4091 and then No (Expressions (DSD)) 4092 then 4093 declare 4094 Typ : constant Entity_Id := Etype (Prefix (DSD)); 4095 begin 4096 if Is_Array_Type (Typ) 4097 and then Number_Dimensions (Typ) > 1 4098 and then Nkind (Parent (N)) = N_Loop_Statement 4099 and then Present (Iteration_Scheme (Parent (N))) 4100 then 4101 declare 4102 OIter : constant Node_Id := 4103 Iteration_Scheme (Parent (N)); 4104 OLPS : constant Node_Id := 4105 Loop_Parameter_Specification (OIter); 4106 ODSD : constant Node_Id := 4107 Original_Node (Discrete_Subtype_Definition (OLPS)); 4108 begin 4109 if Nkind (ODSD) = N_Attribute_Reference 4110 and then Attribute_Name (ODSD) = Name_Range 4111 and then No (Expressions (ODSD)) 4112 and then Etype (Prefix (ODSD)) = Typ 4113 then 4114 Error_Msg_Sloc := Sloc (ODSD); 4115 Error_Msg_N 4116 ("inner range same as outer range#??", DSD); 4117 end if; 4118 end; 4119 end if; 4120 end; 4121 end if; 4122 end; 4123 end if; 4124 4125 -- Analyze the statements of the body except in the case of an Ada 2012 4126 -- iterator with the expander active. In this case the expander will do 4127 -- a rewrite of the loop into a while loop. We will then analyze the 4128 -- loop body when we analyze this while loop. 4129 4130 -- We need to do this delay because if the container is for indefinite 4131 -- types the actual subtype of the components will only be determined 4132 -- when the cursor declaration is analyzed. 4133 4134 -- If the expander is not active then we want to analyze the loop body 4135 -- now even in the Ada 2012 iterator case, since the rewriting will not 4136 -- be done. Insert the loop variable in the current scope, if not done 4137 -- when analysing the iteration scheme. Set its kind properly to detect 4138 -- improper uses in the loop body. 4139 4140 -- In GNATprove mode, we do one of the above depending on the kind of 4141 -- loop. If it is an iterator over an array, then we do not analyze the 4142 -- loop now. We will analyze it after it has been rewritten by the 4143 -- special SPARK expansion which is activated in GNATprove mode. We need 4144 -- to do this so that other expansions that should occur in GNATprove 4145 -- mode take into account the specificities of the rewritten loop, in 4146 -- particular the introduction of a renaming (which needs to be 4147 -- expanded). 4148 4149 -- In other cases in GNATprove mode then we want to analyze the loop 4150 -- body now, since no rewriting will occur. Within a generic the 4151 -- GNATprove mode is irrelevant, we must analyze the generic for 4152 -- non-local name capture. 4153 4154 if Present (Iter) 4155 and then Present (Iterator_Specification (Iter)) 4156 then 4157 if GNATprove_Mode 4158 and then Is_Iterator_Over_Array (Iterator_Specification (Iter)) 4159 and then not Inside_A_Generic 4160 then 4161 null; 4162 4163 elsif not Expander_Active then 4164 declare 4165 I_Spec : constant Node_Id := Iterator_Specification (Iter); 4166 Id : constant Entity_Id := Defining_Identifier (I_Spec); 4167 4168 begin 4169 if Scope (Id) /= Current_Scope then 4170 Enter_Name (Id); 4171 end if; 4172 4173 -- In an element iterator, the loop parameter is a variable if 4174 -- the domain of iteration (container or array) is a variable. 4175 4176 if not Of_Present (I_Spec) 4177 or else not Is_Variable (Name (I_Spec)) 4178 then 4179 Mutate_Ekind (Id, E_Loop_Parameter); 4180 end if; 4181 end; 4182 4183 Analyze_Statements (Statements (N)); 4184 end if; 4185 4186 else 4187 -- Pre-Ada2012 for-loops and while loops 4188 4189 Analyze_Statements (Statements (N)); 4190 end if; 4191 4192 -- If the loop has no side effects, mark it for removal. 4193 4194 if Side_Effect_Free_Loop (N) then 4195 Set_Is_Null_Loop (N); 4196 end if; 4197 4198 -- When the iteration scheme of a loop contains attribute 'Loop_Entry, 4199 -- the loop is transformed into a conditional block. Retrieve the loop. 4200 4201 Stmt := N; 4202 4203 if Subject_To_Loop_Entry_Attributes (Stmt) then 4204 Stmt := Find_Loop_In_Conditional_Block (Stmt); 4205 end if; 4206 4207 -- Finish up processing for the loop. We kill all current values, since 4208 -- in general we don't know if the statements in the loop have been 4209 -- executed. We could do a bit better than this with a loop that we 4210 -- know will execute at least once, but it's not worth the trouble and 4211 -- the front end is not in the business of flow tracing. 4212 4213 Process_End_Label (Stmt, 'e', Ent); 4214 End_Scope; 4215 Kill_Current_Values; 4216 4217 -- Check for infinite loop. Skip check for generated code, since it 4218 -- justs waste time and makes debugging the routine called harder. 4219 4220 -- Note that we have to wait till the body of the loop is fully analyzed 4221 -- before making this call, since Check_Infinite_Loop_Warning relies on 4222 -- being able to use semantic visibility information to find references. 4223 4224 if Comes_From_Source (Stmt) then 4225 Check_Infinite_Loop_Warning (Stmt); 4226 end if; 4227 4228 -- Code after loop is unreachable if the loop has no WHILE or FOR and 4229 -- contains no EXIT statements within the body of the loop. 4230 4231 if No (Iter) and then not Has_Exit (Ent) then 4232 Check_Unreachable_Code (Stmt); 4233 end if; 4234 end Analyze_Loop_Statement; 4235 4236 ---------------------------- 4237 -- Analyze_Null_Statement -- 4238 ---------------------------- 4239 4240 -- Note: the semantics of the null statement is implemented by a single 4241 -- null statement, too bad everything isn't as simple as this. 4242 4243 procedure Analyze_Null_Statement (N : Node_Id) is 4244 pragma Warnings (Off, N); 4245 begin 4246 null; 4247 end Analyze_Null_Statement; 4248 4249 ------------------------- 4250 -- Analyze_Target_Name -- 4251 ------------------------- 4252 4253 procedure Analyze_Target_Name (N : Node_Id) is 4254 procedure Report_Error; 4255 -- Complain about illegal use of target_name and rewrite it into unknown 4256 -- identifier. 4257 4258 ------------------ 4259 -- Report_Error -- 4260 ------------------ 4261 4262 procedure Report_Error is 4263 begin 4264 Error_Msg_N 4265 ("must appear in the right-hand side of an assignment statement", 4266 N); 4267 Rewrite (N, New_Occurrence_Of (Any_Id, Sloc (N))); 4268 end Report_Error; 4269 4270 -- Start of processing for Analyze_Target_Name 4271 4272 begin 4273 -- A target name has the type of the left-hand side of the enclosing 4274 -- assignment. 4275 4276 -- First, verify that the context is the right-hand side of an 4277 -- assignment statement. 4278 4279 if No (Current_Assignment) then 4280 Report_Error; 4281 return; 4282 end if; 4283 4284 declare 4285 Current : Node_Id := N; 4286 Context : Node_Id := Parent (N); 4287 begin 4288 while Present (Context) loop 4289 4290 -- Check if target_name appears in the expression of the enclosing 4291 -- assignment. 4292 4293 if Nkind (Context) = N_Assignment_Statement then 4294 if Current = Expression (Context) then 4295 pragma Assert (Context = Current_Assignment); 4296 Set_Etype (N, Etype (Name (Current_Assignment))); 4297 else 4298 Report_Error; 4299 end if; 4300 return; 4301 4302 -- Prevent the search from going too far 4303 4304 elsif Is_Body_Or_Package_Declaration (Context) then 4305 Report_Error; 4306 return; 4307 end if; 4308 4309 Current := Context; 4310 Context := Parent (Context); 4311 end loop; 4312 4313 Report_Error; 4314 end; 4315 end Analyze_Target_Name; 4316 4317 ------------------------ 4318 -- Analyze_Statements -- 4319 ------------------------ 4320 4321 procedure Analyze_Statements (L : List_Id) is 4322 Lab : Entity_Id; 4323 S : Node_Id; 4324 4325 begin 4326 -- The labels declared in the statement list are reachable from 4327 -- statements in the list. We do this as a prepass so that any goto 4328 -- statement will be properly flagged if its target is not reachable. 4329 -- This is not required, but is nice behavior. 4330 4331 S := First (L); 4332 while Present (S) loop 4333 if Nkind (S) = N_Label then 4334 Analyze (Identifier (S)); 4335 Lab := Entity (Identifier (S)); 4336 4337 -- If we found a label mark it as reachable 4338 4339 if Ekind (Lab) = E_Label then 4340 Generate_Definition (Lab); 4341 Set_Reachable (Lab); 4342 4343 if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then 4344 Set_Label_Construct (Parent (Lab), S); 4345 end if; 4346 4347 -- If we failed to find a label, it means the implicit declaration 4348 -- of the label was hidden. A for-loop parameter can do this to 4349 -- a label with the same name inside the loop, since the implicit 4350 -- label declaration is in the innermost enclosing body or block 4351 -- statement. 4352 4353 else 4354 Error_Msg_Sloc := Sloc (Lab); 4355 Error_Msg_N 4356 ("implicit label declaration for & is hidden#", 4357 Identifier (S)); 4358 end if; 4359 end if; 4360 4361 Next (S); 4362 end loop; 4363 4364 -- Perform semantic analysis on all statements 4365 4366 Conditional_Statements_Begin; 4367 4368 S := First (L); 4369 while Present (S) loop 4370 Analyze (S); 4371 4372 -- Remove dimension in all statements 4373 4374 Remove_Dimension_In_Statement (S); 4375 Next (S); 4376 end loop; 4377 4378 Conditional_Statements_End; 4379 4380 -- Make labels unreachable. Visibility is not sufficient, because labels 4381 -- in one if-branch for example are not reachable from the other branch, 4382 -- even though their declarations are in the enclosing declarative part. 4383 4384 S := First (L); 4385 while Present (S) loop 4386 if Nkind (S) = N_Label then 4387 Set_Reachable (Entity (Identifier (S)), False); 4388 end if; 4389 4390 Next (S); 4391 end loop; 4392 end Analyze_Statements; 4393 4394 ---------------------------- 4395 -- Check_Unreachable_Code -- 4396 ---------------------------- 4397 4398 procedure Check_Unreachable_Code (N : Node_Id) is 4399 Error_Node : Node_Id; 4400 P : Node_Id; 4401 4402 begin 4403 if Is_List_Member (N) and then Comes_From_Source (N) then 4404 declare 4405 Nxt : Node_Id; 4406 4407 begin 4408 Nxt := Original_Node (Next (N)); 4409 4410 -- Skip past pragmas 4411 4412 while Nkind (Nxt) = N_Pragma loop 4413 Nxt := Original_Node (Next (Nxt)); 4414 end loop; 4415 4416 -- If a label follows us, then we never have dead code, since 4417 -- someone could branch to the label, so we just ignore it. 4418 4419 if Nkind (Nxt) = N_Label then 4420 return; 4421 4422 -- Otherwise see if we have a real statement following us 4423 4424 elsif Present (Nxt) 4425 and then Comes_From_Source (Nxt) 4426 and then Is_Statement (Nxt) 4427 then 4428 -- Special very annoying exception. If we have a return that 4429 -- follows a raise, then we allow it without a warning, since 4430 -- the Ada RM annoyingly requires a useless return here. 4431 4432 if Nkind (Original_Node (N)) /= N_Raise_Statement 4433 or else Nkind (Nxt) /= N_Simple_Return_Statement 4434 then 4435 -- The rather strange shenanigans with the warning message 4436 -- here reflects the fact that Kill_Dead_Code is very good 4437 -- at removing warnings in deleted code, and this is one 4438 -- warning we would prefer NOT to have removed. 4439 4440 Error_Node := Nxt; 4441 4442 -- If we have unreachable code, analyze and remove the 4443 -- unreachable code, since it is useless and we don't 4444 -- want to generate junk warnings. 4445 4446 -- We skip this step if we are not in code generation mode 4447 -- or CodePeer mode. 4448 4449 -- This is the one case where we remove dead code in the 4450 -- semantics as opposed to the expander, and we do not want 4451 -- to remove code if we are not in code generation mode, 4452 -- since this messes up the tree or loses useful information 4453 -- for CodePeer. 4454 4455 -- Note that one might react by moving the whole circuit to 4456 -- exp_ch5, but then we lose the warning in -gnatc mode. 4457 4458 if Operating_Mode = Generate_Code 4459 and then not CodePeer_Mode 4460 then 4461 loop 4462 Nxt := Next (N); 4463 4464 -- Quit deleting when we have nothing more to delete 4465 -- or if we hit a label (since someone could transfer 4466 -- control to a label, so we should not delete it). 4467 4468 exit when No (Nxt) or else Nkind (Nxt) = N_Label; 4469 4470 -- Statement/declaration is to be deleted 4471 4472 Analyze (Nxt); 4473 Remove (Nxt); 4474 Kill_Dead_Code (Nxt); 4475 end loop; 4476 end if; 4477 4478 Error_Msg 4479 ("??unreachable code!", Sloc (Error_Node), Error_Node); 4480 end if; 4481 4482 -- If the unconditional transfer of control instruction is the 4483 -- last statement of a sequence, then see if our parent is one of 4484 -- the constructs for which we count unblocked exits, and if so, 4485 -- adjust the count. 4486 4487 else 4488 P := Parent (N); 4489 4490 -- Statements in THEN part or ELSE part of IF statement 4491 4492 if Nkind (P) = N_If_Statement then 4493 null; 4494 4495 -- Statements in ELSIF part of an IF statement 4496 4497 elsif Nkind (P) = N_Elsif_Part then 4498 P := Parent (P); 4499 pragma Assert (Nkind (P) = N_If_Statement); 4500 4501 -- Statements in CASE statement alternative 4502 4503 elsif Nkind (P) = N_Case_Statement_Alternative then 4504 P := Parent (P); 4505 pragma Assert (Nkind (P) = N_Case_Statement); 4506 4507 -- Statements in body of block 4508 4509 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 4510 and then Nkind (Parent (P)) = N_Block_Statement 4511 then 4512 -- The original loop is now placed inside a block statement 4513 -- due to the expansion of attribute 'Loop_Entry. Return as 4514 -- this is not a "real" block for the purposes of exit 4515 -- counting. 4516 4517 if Nkind (N) = N_Loop_Statement 4518 and then Subject_To_Loop_Entry_Attributes (N) 4519 then 4520 return; 4521 end if; 4522 4523 -- Statements in exception handler in a block 4524 4525 elsif Nkind (P) = N_Exception_Handler 4526 and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements 4527 and then Nkind (Parent (Parent (P))) = N_Block_Statement 4528 then 4529 null; 4530 4531 -- None of these cases, so return 4532 4533 else 4534 return; 4535 end if; 4536 4537 -- This was one of the cases we are looking for (i.e. the 4538 -- parent construct was IF, CASE or block) so decrement count. 4539 4540 Unblocked_Exit_Count := Unblocked_Exit_Count - 1; 4541 end if; 4542 end; 4543 end if; 4544 end Check_Unreachable_Code; 4545 4546 ------------------------ 4547 -- Has_Sec_Stack_Call -- 4548 ------------------------ 4549 4550 function Has_Sec_Stack_Call (N : Node_Id) return Boolean is 4551 function Check_Call (N : Node_Id) return Traverse_Result; 4552 -- Check if N is a function call which uses the secondary stack 4553 4554 ---------------- 4555 -- Check_Call -- 4556 ---------------- 4557 4558 function Check_Call (N : Node_Id) return Traverse_Result is 4559 Nam : Node_Id; 4560 Subp : Entity_Id; 4561 Typ : Entity_Id; 4562 4563 begin 4564 if Nkind (N) = N_Function_Call then 4565 Nam := Name (N); 4566 4567 -- Obtain the subprogram being invoked 4568 4569 loop 4570 if Nkind (Nam) = N_Explicit_Dereference then 4571 Nam := Prefix (Nam); 4572 4573 elsif Nkind (Nam) = N_Selected_Component then 4574 Nam := Selector_Name (Nam); 4575 4576 else 4577 exit; 4578 end if; 4579 end loop; 4580 4581 Subp := Entity (Nam); 4582 4583 if Present (Subp) then 4584 Typ := Etype (Subp); 4585 4586 if Requires_Transient_Scope (Typ) then 4587 return Abandon; 4588 4589 elsif Sec_Stack_Needed_For_Return (Subp) then 4590 return Abandon; 4591 end if; 4592 end if; 4593 end if; 4594 4595 -- Continue traversing the tree 4596 4597 return OK; 4598 end Check_Call; 4599 4600 function Check_Calls is new Traverse_Func (Check_Call); 4601 4602 -- Start of processing for Has_Sec_Stack_Call 4603 4604 begin 4605 return Check_Calls (N) = Abandon; 4606 end Has_Sec_Stack_Call; 4607 4608 ---------------------- 4609 -- Preanalyze_Range -- 4610 ---------------------- 4611 4612 procedure Preanalyze_Range (R_Copy : Node_Id) is 4613 Save_Analysis : constant Boolean := Full_Analysis; 4614 Typ : Entity_Id; 4615 4616 begin 4617 Full_Analysis := False; 4618 Expander_Mode_Save_And_Set (False); 4619 4620 -- In addition to the above we must explicitly suppress the generation 4621 -- of freeze nodes that might otherwise be generated during resolution 4622 -- of the range (e.g. if given by an attribute that will freeze its 4623 -- prefix). 4624 4625 Set_Must_Not_Freeze (R_Copy); 4626 4627 if Nkind (R_Copy) = N_Attribute_Reference then 4628 Set_Must_Not_Freeze (Prefix (R_Copy)); 4629 end if; 4630 4631 Analyze (R_Copy); 4632 4633 if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then 4634 4635 -- Apply preference rules for range of predefined integer types, or 4636 -- check for array or iterable construct for "of" iterator, or 4637 -- diagnose true ambiguity. 4638 4639 declare 4640 I : Interp_Index; 4641 It : Interp; 4642 Found : Entity_Id := Empty; 4643 4644 begin 4645 Get_First_Interp (R_Copy, I, It); 4646 while Present (It.Typ) loop 4647 if Is_Discrete_Type (It.Typ) then 4648 if No (Found) then 4649 Found := It.Typ; 4650 else 4651 if Scope (Found) = Standard_Standard then 4652 null; 4653 4654 elsif Scope (It.Typ) = Standard_Standard then 4655 Found := It.Typ; 4656 4657 else 4658 -- Both of them are user-defined 4659 4660 Error_Msg_N 4661 ("ambiguous bounds in range of iteration", R_Copy); 4662 Error_Msg_N ("\possible interpretations:", R_Copy); 4663 Error_Msg_NE ("\\}", R_Copy, Found); 4664 Error_Msg_NE ("\\}", R_Copy, It.Typ); 4665 exit; 4666 end if; 4667 end if; 4668 4669 elsif Nkind (Parent (R_Copy)) = N_Iterator_Specification 4670 and then Of_Present (Parent (R_Copy)) 4671 then 4672 if Is_Array_Type (It.Typ) 4673 or else Has_Aspect (It.Typ, Aspect_Iterator_Element) 4674 or else Has_Aspect (It.Typ, Aspect_Constant_Indexing) 4675 or else Has_Aspect (It.Typ, Aspect_Variable_Indexing) 4676 then 4677 if No (Found) then 4678 Found := It.Typ; 4679 Set_Etype (R_Copy, It.Typ); 4680 4681 else 4682 Error_Msg_N ("ambiguous domain of iteration", R_Copy); 4683 end if; 4684 end if; 4685 end if; 4686 4687 Get_Next_Interp (I, It); 4688 end loop; 4689 end; 4690 end if; 4691 4692 -- Subtype mark in iteration scheme 4693 4694 if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then 4695 null; 4696 4697 -- Expression in range, or Ada 2012 iterator 4698 4699 elsif Nkind (R_Copy) in N_Subexpr then 4700 Resolve (R_Copy); 4701 Typ := Etype (R_Copy); 4702 4703 if Is_Discrete_Type (Typ) then 4704 null; 4705 4706 -- Check that the resulting object is an iterable container 4707 4708 elsif Has_Aspect (Typ, Aspect_Iterator_Element) 4709 or else Has_Aspect (Typ, Aspect_Constant_Indexing) 4710 or else Has_Aspect (Typ, Aspect_Variable_Indexing) 4711 then 4712 null; 4713 4714 -- The expression may yield an implicit reference to an iterable 4715 -- container. Insert explicit dereference so that proper type is 4716 -- visible in the loop. 4717 4718 elsif Has_Implicit_Dereference (Etype (R_Copy)) then 4719 Build_Explicit_Dereference 4720 (R_Copy, Get_Reference_Discriminant (Etype (R_Copy))); 4721 end if; 4722 end if; 4723 4724 Expander_Mode_Restore; 4725 Full_Analysis := Save_Analysis; 4726 end Preanalyze_Range; 4727 4728end Sem_Ch5; 4729