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