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