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 if No (Iterator) then 2238 null; -- error reported below 2239 2240 elsif not Is_Overloaded (Iterator) then 2241 Check_Reverse_Iteration (Etype (Iterator)); 2242 2243 -- If Iterator is overloaded, use reversible iterator if one is 2244 -- available. 2245 2246 elsif Is_Overloaded (Iterator) then 2247 Get_First_Interp (Iterator, I, It); 2248 while Present (It.Nam) loop 2249 if Ekind (It.Nam) = E_Function 2250 and then Is_Reversible_Iterator (Etype (It.Nam)) 2251 then 2252 Set_Etype (Iterator, It.Typ); 2253 Set_Entity (Iterator, It.Nam); 2254 exit; 2255 end if; 2256 2257 Get_Next_Interp (I, It); 2258 end loop; 2259 2260 Check_Reverse_Iteration (Etype (Iterator)); 2261 end if; 2262 end; 2263 end if; 2264 end if; 2265 2266 -- If the domain of iteration is an expression, create a declaration for 2267 -- it, so that finalization actions are introduced outside of the loop. 2268 -- The declaration must be a renaming because the body of the loop may 2269 -- assign to elements. 2270 2271 if not Is_Entity_Name (Iter_Name) 2272 2273 -- When the context is a quantified expression, the renaming 2274 -- declaration is delayed until the expansion phase if we are 2275 -- doing expansion. 2276 2277 and then (Nkind (Parent (N)) /= N_Quantified_Expression 2278 or else Operating_Mode = Check_Semantics) 2279 2280 -- Do not perform this expansion for ASIS and when expansion is 2281 -- disabled, where the temporary may hide the transformation of a 2282 -- selected component into a prefixed function call, and references 2283 -- need to see the original expression. 2284 2285 and then Expander_Active 2286 then 2287 declare 2288 Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); 2289 Decl : Node_Id; 2290 Act_S : Node_Id; 2291 2292 begin 2293 2294 -- If the domain of iteration is an array component that depends 2295 -- on a discriminant, create actual subtype for it. preanalysis 2296 -- does not generate the actual subtype of a selected component. 2297 2298 if Nkind (Iter_Name) = N_Selected_Component 2299 and then Is_Array_Type (Etype (Iter_Name)) 2300 then 2301 Act_S := 2302 Build_Actual_Subtype_Of_Component 2303 (Etype (Selector_Name (Iter_Name)), Iter_Name); 2304 Insert_Action (N, Act_S); 2305 2306 if Present (Act_S) then 2307 Typ := Defining_Identifier (Act_S); 2308 else 2309 Typ := Etype (Iter_Name); 2310 end if; 2311 2312 else 2313 Typ := Etype (Iter_Name); 2314 2315 -- Verify that the expression produces an iterator 2316 2317 if not Of_Present (N) and then not Is_Iterator (Typ) 2318 and then not Is_Array_Type (Typ) 2319 and then No (Find_Aspect (Typ, Aspect_Iterable)) 2320 then 2321 Error_Msg_N 2322 ("expect object that implements iterator interface", 2323 Iter_Name); 2324 end if; 2325 end if; 2326 2327 -- Protect against malformed iterator 2328 2329 if Typ = Any_Type then 2330 Error_Msg_N ("invalid expression in loop iterator", Iter_Name); 2331 return; 2332 end if; 2333 2334 if not Of_Present (N) then 2335 Check_Reverse_Iteration (Typ); 2336 end if; 2337 2338 -- The name in the renaming declaration may be a function call. 2339 -- Indicate that it does not come from source, to suppress 2340 -- spurious warnings on renamings of parameterless functions, 2341 -- a common enough idiom in user-defined iterators. 2342 2343 Decl := 2344 Make_Object_Renaming_Declaration (Loc, 2345 Defining_Identifier => Id, 2346 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 2347 Name => 2348 New_Copy_Tree (Iter_Name, New_Sloc => Loc)); 2349 2350 Insert_Actions (Parent (Parent (N)), New_List (Decl)); 2351 Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); 2352 Set_Etype (Id, Typ); 2353 Set_Etype (Name (N), Typ); 2354 end; 2355 2356 -- Container is an entity or an array with uncontrolled components, or 2357 -- else it is a container iterator given by a function call, typically 2358 -- called Iterate in the case of predefined containers, even though 2359 -- Iterate is not a reserved name. What matters is that the return type 2360 -- of the function is an iterator type. 2361 2362 elsif Is_Entity_Name (Iter_Name) then 2363 Analyze (Iter_Name); 2364 2365 if Nkind (Iter_Name) = N_Function_Call then 2366 declare 2367 C : constant Node_Id := Name (Iter_Name); 2368 I : Interp_Index; 2369 It : Interp; 2370 2371 begin 2372 if not Is_Overloaded (Iter_Name) then 2373 Resolve (Iter_Name, Etype (C)); 2374 2375 else 2376 Get_First_Interp (C, I, It); 2377 while It.Typ /= Empty loop 2378 if Reverse_Present (N) then 2379 if Is_Reversible_Iterator (It.Typ) then 2380 Resolve (Iter_Name, It.Typ); 2381 exit; 2382 end if; 2383 2384 elsif Is_Iterator (It.Typ) then 2385 Resolve (Iter_Name, It.Typ); 2386 exit; 2387 end if; 2388 2389 Get_Next_Interp (I, It); 2390 end loop; 2391 end if; 2392 end; 2393 2394 -- Domain of iteration is not overloaded 2395 2396 else 2397 Resolve (Iter_Name, Etype (Iter_Name)); 2398 end if; 2399 2400 if not Of_Present (N) then 2401 Check_Reverse_Iteration (Etype (Iter_Name)); 2402 end if; 2403 end if; 2404 2405 -- Get base type of container, for proper retrieval of Cursor type 2406 -- and primitive operations. 2407 2408 Typ := Base_Type (Etype (Iter_Name)); 2409 2410 if Is_Array_Type (Typ) then 2411 if Of_Present (N) then 2412 Set_Etype (Def_Id, Component_Type (Typ)); 2413 2414 -- The loop variable is aliased if the array components are 2415 -- aliased. 2416 2417 Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ)); 2418 2419 -- AI12-0047 stipulates that the domain (array or container) 2420 -- cannot be a component that depends on a discriminant if the 2421 -- enclosing object is mutable, to prevent a modification of the 2422 -- dowmain of iteration in the course of an iteration. 2423 2424 -- If the object is an expression it has been captured in a 2425 -- temporary, so examine original node. 2426 2427 if Nkind (Original_Node (Iter_Name)) = N_Selected_Component 2428 and then Is_Dependent_Component_Of_Mutable_Object 2429 (Original_Node (Iter_Name)) 2430 then 2431 Error_Msg_N 2432 ("iterable name cannot be a discriminant-dependent " 2433 & "component of a mutable object", N); 2434 end if; 2435 2436 Check_Subtype_Indication (Component_Type (Typ)); 2437 2438 -- Here we have a missing Range attribute 2439 2440 else 2441 Error_Msg_N 2442 ("missing Range attribute in iteration over an array", N); 2443 2444 -- In Ada 2012 mode, this may be an attempt at an iterator 2445 2446 if Ada_Version >= Ada_2012 then 2447 Error_Msg_NE 2448 ("\if& is meant to designate an element of the array, use OF", 2449 N, Def_Id); 2450 end if; 2451 2452 -- Prevent cascaded errors 2453 2454 Set_Ekind (Def_Id, E_Loop_Parameter); 2455 Set_Etype (Def_Id, Etype (First_Index (Typ))); 2456 end if; 2457 2458 -- Check for type error in iterator 2459 2460 elsif Typ = Any_Type then 2461 return; 2462 2463 -- Iteration over a container 2464 2465 else 2466 Set_Ekind (Def_Id, E_Loop_Parameter); 2467 Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N)); 2468 2469 -- OF present 2470 2471 if Of_Present (N) then 2472 if Has_Aspect (Typ, Aspect_Iterable) then 2473 declare 2474 Elt : constant Entity_Id := 2475 Get_Iterable_Type_Primitive (Typ, Name_Element); 2476 begin 2477 if No (Elt) then 2478 Error_Msg_N 2479 ("missing Element primitive for iteration", N); 2480 else 2481 Set_Etype (Def_Id, Etype (Elt)); 2482 Check_Reverse_Iteration (Typ); 2483 end if; 2484 end; 2485 2486 Check_Subtype_Indication (Etype (Def_Id)); 2487 2488 -- For a predefined container, The type of the loop variable is 2489 -- the Iterator_Element aspect of the container type. 2490 2491 else 2492 declare 2493 Element : constant Entity_Id := 2494 Find_Value_Of_Aspect 2495 (Typ, Aspect_Iterator_Element); 2496 Iterator : constant Entity_Id := 2497 Find_Value_Of_Aspect 2498 (Typ, Aspect_Default_Iterator); 2499 Orig_Iter_Name : constant Node_Id := 2500 Original_Node (Iter_Name); 2501 Cursor_Type : Entity_Id; 2502 2503 begin 2504 if No (Element) then 2505 Error_Msg_NE ("cannot iterate over&", N, Typ); 2506 return; 2507 2508 else 2509 Set_Etype (Def_Id, Entity (Element)); 2510 Cursor_Type := Get_Cursor_Type (Typ); 2511 pragma Assert (Present (Cursor_Type)); 2512 2513 Check_Subtype_Indication (Etype (Def_Id)); 2514 2515 -- If the container has a variable indexing aspect, the 2516 -- element is a variable and is modifiable in the loop. 2517 2518 if Has_Aspect (Typ, Aspect_Variable_Indexing) then 2519 Set_Ekind (Def_Id, E_Variable); 2520 end if; 2521 2522 -- If the container is a constant, iterating over it 2523 -- requires a Constant_Indexing operation. 2524 2525 if not Is_Variable (Iter_Name) 2526 and then not Has_Aspect (Typ, Aspect_Constant_Indexing) 2527 then 2528 Error_Msg_N 2529 ("iteration over constant container require " 2530 & "constant_indexing aspect", N); 2531 2532 -- The Iterate function may have an in_out parameter, 2533 -- and a constant container is thus illegal. 2534 2535 elsif Present (Iterator) 2536 and then Ekind (Entity (Iterator)) = E_Function 2537 and then Ekind (First_Formal (Entity (Iterator))) /= 2538 E_In_Parameter 2539 and then not Is_Variable (Iter_Name) 2540 then 2541 Error_Msg_N ("variable container expected", N); 2542 end if; 2543 2544 -- Detect a case where the iterator denotes a component 2545 -- of a mutable object which depends on a discriminant. 2546 -- Note that the iterator may denote a function call in 2547 -- qualified form, in which case this check should not 2548 -- be performed. 2549 2550 if Nkind (Orig_Iter_Name) = N_Selected_Component 2551 and then 2552 Present (Entity (Selector_Name (Orig_Iter_Name))) 2553 and then Ekind_In 2554 (Entity (Selector_Name (Orig_Iter_Name)), 2555 E_Component, 2556 E_Discriminant) 2557 and then Is_Dependent_Component_Of_Mutable_Object 2558 (Orig_Iter_Name) 2559 then 2560 Error_Msg_N 2561 ("container cannot be a discriminant-dependent " 2562 & "component of a mutable object", N); 2563 end if; 2564 end if; 2565 end; 2566 end if; 2567 2568 -- IN iterator, domain is a range, or a call to Iterate function 2569 2570 else 2571 -- For an iteration of the form IN, the name must denote an 2572 -- iterator, typically the result of a call to Iterate. Give a 2573 -- useful error message when the name is a container by itself. 2574 2575 -- The type may be a formal container type, which has to have 2576 -- an Iterable aspect detailing the required primitives. 2577 2578 if Is_Entity_Name (Original_Node (Name (N))) 2579 and then not Is_Iterator (Typ) 2580 then 2581 if Has_Aspect (Typ, Aspect_Iterable) then 2582 null; 2583 2584 elsif not Has_Aspect (Typ, Aspect_Iterator_Element) then 2585 Error_Msg_NE 2586 ("cannot iterate over&", Name (N), Typ); 2587 else 2588 Error_Msg_N 2589 ("name must be an iterator, not a container", Name (N)); 2590 end if; 2591 2592 if Has_Aspect (Typ, Aspect_Iterable) then 2593 null; 2594 else 2595 Error_Msg_NE 2596 ("\to iterate directly over the elements of a container, " 2597 & "write `of &`", Name (N), Original_Node (Name (N))); 2598 2599 -- No point in continuing analysis of iterator spec 2600 2601 return; 2602 end if; 2603 end if; 2604 2605 -- If the name is a call (typically prefixed) to some Iterate 2606 -- function, it has been rewritten as an object declaration. 2607 -- If that object is a selected component, verify that it is not 2608 -- a component of an unconstrained mutable object. 2609 2610 if Nkind (Iter_Name) = N_Identifier 2611 or else (not Expander_Active and Comes_From_Source (Iter_Name)) 2612 then 2613 declare 2614 Orig_Node : constant Node_Id := Original_Node (Iter_Name); 2615 Iter_Kind : constant Node_Kind := Nkind (Orig_Node); 2616 Obj : Node_Id; 2617 2618 begin 2619 if Iter_Kind = N_Selected_Component then 2620 Obj := Prefix (Orig_Node); 2621 2622 elsif Iter_Kind = N_Function_Call then 2623 Obj := First_Actual (Orig_Node); 2624 2625 -- If neither, the name comes from source 2626 2627 else 2628 Obj := Iter_Name; 2629 end if; 2630 2631 if Nkind (Obj) = N_Selected_Component 2632 and then Is_Dependent_Component_Of_Mutable_Object (Obj) 2633 then 2634 Error_Msg_N 2635 ("container cannot be a discriminant-dependent " 2636 & "component of a mutable object", N); 2637 end if; 2638 end; 2639 end if; 2640 2641 -- The result type of Iterate function is the classwide type of 2642 -- the interface parent. We need the specific Cursor type defined 2643 -- in the container package. We obtain it by name for a predefined 2644 -- container, or through the Iterable aspect for a formal one. 2645 2646 if Has_Aspect (Typ, Aspect_Iterable) then 2647 Set_Etype (Def_Id, 2648 Get_Cursor_Type 2649 (Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)), 2650 Typ)); 2651 2652 else 2653 Set_Etype (Def_Id, Get_Cursor_Type (Typ)); 2654 Check_Reverse_Iteration (Etype (Iter_Name)); 2655 end if; 2656 2657 end if; 2658 end if; 2659 end Analyze_Iterator_Specification; 2660 2661 ------------------- 2662 -- Analyze_Label -- 2663 ------------------- 2664 2665 -- Note: the semantic work required for analyzing labels (setting them as 2666 -- reachable) was done in a prepass through the statements in the block, 2667 -- so that forward gotos would be properly handled. See Analyze_Statements 2668 -- for further details. The only processing required here is to deal with 2669 -- optimizations that depend on an assumption of sequential control flow, 2670 -- since of course the occurrence of a label breaks this assumption. 2671 2672 procedure Analyze_Label (N : Node_Id) is 2673 pragma Warnings (Off, N); 2674 begin 2675 Kill_Current_Values; 2676 end Analyze_Label; 2677 2678 -------------------------- 2679 -- Analyze_Label_Entity -- 2680 -------------------------- 2681 2682 procedure Analyze_Label_Entity (E : Entity_Id) is 2683 begin 2684 Set_Ekind (E, E_Label); 2685 Set_Etype (E, Standard_Void_Type); 2686 Set_Enclosing_Scope (E, Current_Scope); 2687 Set_Reachable (E, True); 2688 end Analyze_Label_Entity; 2689 2690 ------------------------------------------ 2691 -- Analyze_Loop_Parameter_Specification -- 2692 ------------------------------------------ 2693 2694 procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is 2695 Loop_Nod : constant Node_Id := Parent (Parent (N)); 2696 2697 procedure Check_Controlled_Array_Attribute (DS : Node_Id); 2698 -- If the bounds are given by a 'Range reference on a function call 2699 -- that returns a controlled array, introduce an explicit declaration 2700 -- to capture the bounds, so that the function result can be finalized 2701 -- in timely fashion. 2702 2703 procedure Check_Predicate_Use (T : Entity_Id); 2704 -- Diagnose Attempt to iterate through non-static predicate. Note that 2705 -- a type with inherited predicates may have both static and dynamic 2706 -- forms. In this case it is not sufficent to check the static predicate 2707 -- function only, look for a dynamic predicate aspect as well. 2708 2709 procedure Process_Bounds (R : Node_Id); 2710 -- If the iteration is given by a range, create temporaries and 2711 -- assignment statements block to capture the bounds and perform 2712 -- required finalization actions in case a bound includes a function 2713 -- call that uses the temporary stack. We first preanalyze a copy of 2714 -- the range in order to determine the expected type, and analyze and 2715 -- resolve the original bounds. 2716 2717 -------------------------------------- 2718 -- Check_Controlled_Array_Attribute -- 2719 -------------------------------------- 2720 2721 procedure Check_Controlled_Array_Attribute (DS : Node_Id) is 2722 begin 2723 if Nkind (DS) = N_Attribute_Reference 2724 and then Is_Entity_Name (Prefix (DS)) 2725 and then Ekind (Entity (Prefix (DS))) = E_Function 2726 and then Is_Array_Type (Etype (Entity (Prefix (DS)))) 2727 and then 2728 Is_Controlled (Component_Type (Etype (Entity (Prefix (DS))))) 2729 and then Expander_Active 2730 then 2731 declare 2732 Loc : constant Source_Ptr := Sloc (N); 2733 Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); 2734 Indx : constant Entity_Id := 2735 Base_Type (Etype (First_Index (Arr))); 2736 Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); 2737 Decl : Node_Id; 2738 2739 begin 2740 Decl := 2741 Make_Subtype_Declaration (Loc, 2742 Defining_Identifier => Subt, 2743 Subtype_Indication => 2744 Make_Subtype_Indication (Loc, 2745 Subtype_Mark => New_Occurrence_Of (Indx, Loc), 2746 Constraint => 2747 Make_Range_Constraint (Loc, Relocate_Node (DS)))); 2748 Insert_Before (Loop_Nod, Decl); 2749 Analyze (Decl); 2750 2751 Rewrite (DS, 2752 Make_Attribute_Reference (Loc, 2753 Prefix => New_Occurrence_Of (Subt, Loc), 2754 Attribute_Name => Attribute_Name (DS))); 2755 2756 Analyze (DS); 2757 end; 2758 end if; 2759 end Check_Controlled_Array_Attribute; 2760 2761 ------------------------- 2762 -- Check_Predicate_Use -- 2763 ------------------------- 2764 2765 procedure Check_Predicate_Use (T : Entity_Id) is 2766 begin 2767 -- A predicated subtype is illegal in loops and related constructs 2768 -- if the predicate is not static, or if it is a non-static subtype 2769 -- of a statically predicated subtype. 2770 2771 if Is_Discrete_Type (T) 2772 and then Has_Predicates (T) 2773 and then (not Has_Static_Predicate (T) 2774 or else not Is_Static_Subtype (T) 2775 or else Has_Dynamic_Predicate_Aspect (T)) 2776 then 2777 -- Seems a confusing message for the case of a static predicate 2778 -- with a non-static subtype??? 2779 2780 Bad_Predicated_Subtype_Use 2781 ("cannot use subtype& with non-static predicate for loop " 2782 & "iteration", Discrete_Subtype_Definition (N), 2783 T, Suggest_Static => True); 2784 2785 elsif Inside_A_Generic 2786 and then Is_Generic_Formal (T) 2787 and then Is_Discrete_Type (T) 2788 then 2789 Set_No_Dynamic_Predicate_On_Actual (T); 2790 end if; 2791 end Check_Predicate_Use; 2792 2793 -------------------- 2794 -- Process_Bounds -- 2795 -------------------- 2796 2797 procedure Process_Bounds (R : Node_Id) is 2798 Loc : constant Source_Ptr := Sloc (N); 2799 2800 function One_Bound 2801 (Original_Bound : Node_Id; 2802 Analyzed_Bound : Node_Id; 2803 Typ : Entity_Id) return Node_Id; 2804 -- Capture value of bound and return captured value 2805 2806 --------------- 2807 -- One_Bound -- 2808 --------------- 2809 2810 function One_Bound 2811 (Original_Bound : Node_Id; 2812 Analyzed_Bound : Node_Id; 2813 Typ : Entity_Id) return Node_Id 2814 is 2815 Assign : Node_Id; 2816 Decl : Node_Id; 2817 Id : Entity_Id; 2818 2819 begin 2820 -- If the bound is a constant or an object, no need for a separate 2821 -- declaration. If the bound is the result of previous expansion 2822 -- it is already analyzed and should not be modified. Note that 2823 -- the Bound will be resolved later, if needed, as part of the 2824 -- call to Make_Index (literal bounds may need to be resolved to 2825 -- type Integer). 2826 2827 if Analyzed (Original_Bound) then 2828 return Original_Bound; 2829 2830 elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, 2831 N_Character_Literal) 2832 or else Is_Entity_Name (Analyzed_Bound) 2833 then 2834 Analyze_And_Resolve (Original_Bound, Typ); 2835 return Original_Bound; 2836 end if; 2837 2838 -- Normally, the best approach is simply to generate a constant 2839 -- declaration that captures the bound. However, there is a nasty 2840 -- case where this is wrong. If the bound is complex, and has a 2841 -- possible use of the secondary stack, we need to generate a 2842 -- separate assignment statement to ensure the creation of a block 2843 -- which will release the secondary stack. 2844 2845 -- We prefer the constant declaration, since it leaves us with a 2846 -- proper trace of the value, useful in optimizations that get rid 2847 -- of junk range checks. 2848 2849 if not Has_Sec_Stack_Call (Analyzed_Bound) then 2850 Analyze_And_Resolve (Original_Bound, Typ); 2851 2852 -- Ensure that the bound is valid. This check should not be 2853 -- generated when the range belongs to a quantified expression 2854 -- as the construct is still not expanded into its final form. 2855 2856 if Nkind (Parent (R)) /= N_Loop_Parameter_Specification 2857 or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression 2858 then 2859 Ensure_Valid (Original_Bound); 2860 end if; 2861 2862 Force_Evaluation (Original_Bound); 2863 return Original_Bound; 2864 end if; 2865 2866 Id := Make_Temporary (Loc, 'R', Original_Bound); 2867 2868 -- Here we make a declaration with a separate assignment 2869 -- statement, and insert before loop header. 2870 2871 Decl := 2872 Make_Object_Declaration (Loc, 2873 Defining_Identifier => Id, 2874 Object_Definition => New_Occurrence_Of (Typ, Loc)); 2875 2876 Assign := 2877 Make_Assignment_Statement (Loc, 2878 Name => New_Occurrence_Of (Id, Loc), 2879 Expression => Relocate_Node (Original_Bound)); 2880 2881 Insert_Actions (Loop_Nod, New_List (Decl, Assign)); 2882 2883 -- Now that this temporary variable is initialized we decorate it 2884 -- as safe-to-reevaluate to inform to the backend that no further 2885 -- asignment will be issued and hence it can be handled as side 2886 -- effect free. Note that this decoration must be done when the 2887 -- assignment has been analyzed because otherwise it will be 2888 -- rejected (see Analyze_Assignment). 2889 2890 Set_Is_Safe_To_Reevaluate (Id); 2891 2892 Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); 2893 2894 if Nkind (Assign) = N_Assignment_Statement then 2895 return Expression (Assign); 2896 else 2897 return Original_Bound; 2898 end if; 2899 end One_Bound; 2900 2901 Hi : constant Node_Id := High_Bound (R); 2902 Lo : constant Node_Id := Low_Bound (R); 2903 R_Copy : constant Node_Id := New_Copy_Tree (R); 2904 New_Hi : Node_Id; 2905 New_Lo : Node_Id; 2906 Typ : Entity_Id; 2907 2908 -- Start of processing for Process_Bounds 2909 2910 begin 2911 Set_Parent (R_Copy, Parent (R)); 2912 Preanalyze_Range (R_Copy); 2913 Typ := Etype (R_Copy); 2914 2915 -- If the type of the discrete range is Universal_Integer, then the 2916 -- bound's type must be resolved to Integer, and any object used to 2917 -- hold the bound must also have type Integer, unless the literal 2918 -- bounds are constant-folded expressions with a user-defined type. 2919 2920 if Typ = Universal_Integer then 2921 if Nkind (Lo) = N_Integer_Literal 2922 and then Present (Etype (Lo)) 2923 and then Scope (Etype (Lo)) /= Standard_Standard 2924 then 2925 Typ := Etype (Lo); 2926 2927 elsif Nkind (Hi) = N_Integer_Literal 2928 and then Present (Etype (Hi)) 2929 and then Scope (Etype (Hi)) /= Standard_Standard 2930 then 2931 Typ := Etype (Hi); 2932 2933 else 2934 Typ := Standard_Integer; 2935 end if; 2936 end if; 2937 2938 Set_Etype (R, Typ); 2939 2940 New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ); 2941 New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ); 2942 2943 -- Propagate staticness to loop range itself, in case the 2944 -- corresponding subtype is static. 2945 2946 if New_Lo /= Lo and then Is_OK_Static_Expression (New_Lo) then 2947 Rewrite (Low_Bound (R), New_Copy (New_Lo)); 2948 end if; 2949 2950 if New_Hi /= Hi and then Is_OK_Static_Expression (New_Hi) then 2951 Rewrite (High_Bound (R), New_Copy (New_Hi)); 2952 end if; 2953 end Process_Bounds; 2954 2955 -- Local variables 2956 2957 DS : constant Node_Id := Discrete_Subtype_Definition (N); 2958 Id : constant Entity_Id := Defining_Identifier (N); 2959 2960 DS_Copy : Node_Id; 2961 2962 -- Start of processing for Analyze_Loop_Parameter_Specification 2963 2964 begin 2965 Enter_Name (Id); 2966 2967 -- We always consider the loop variable to be referenced, since the loop 2968 -- may be used just for counting purposes. 2969 2970 Generate_Reference (Id, N, ' '); 2971 2972 -- Check for the case of loop variable hiding a local variable (used 2973 -- later on to give a nice warning if the hidden variable is never 2974 -- assigned). 2975 2976 declare 2977 H : constant Entity_Id := Homonym (Id); 2978 begin 2979 if Present (H) 2980 and then Ekind (H) = E_Variable 2981 and then Is_Discrete_Type (Etype (H)) 2982 and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id) 2983 then 2984 Set_Hiding_Loop_Variable (H, Id); 2985 end if; 2986 end; 2987 2988 -- Loop parameter specification must include subtype mark in SPARK 2989 2990 if Nkind (DS) = N_Range then 2991 Check_SPARK_05_Restriction 2992 ("loop parameter specification must include subtype mark", N); 2993 end if; 2994 2995 -- Analyze the subtype definition and create temporaries for the bounds. 2996 -- Do not evaluate the range when preanalyzing a quantified expression 2997 -- because bounds expressed as function calls with side effects will be 2998 -- incorrectly replicated. 2999 3000 if Nkind (DS) = N_Range 3001 and then Expander_Active 3002 and then Nkind (Parent (N)) /= N_Quantified_Expression 3003 then 3004 Process_Bounds (DS); 3005 3006 -- Either the expander not active or the range of iteration is a subtype 3007 -- indication, an entity, or a function call that yields an aggregate or 3008 -- a container. 3009 3010 else 3011 DS_Copy := New_Copy_Tree (DS); 3012 Set_Parent (DS_Copy, Parent (DS)); 3013 Preanalyze_Range (DS_Copy); 3014 3015 -- Ada 2012: If the domain of iteration is: 3016 3017 -- a) a function call, 3018 -- b) an identifier that is not a type, 3019 -- c) an attribute reference 'Old (within a postcondition), 3020 -- d) an unchecked conversion or a qualified expression with 3021 -- the proper iterator type. 3022 3023 -- then it is an iteration over a container. It was classified as 3024 -- a loop specification by the parser, and must be rewritten now 3025 -- to activate container iteration. The last case will occur within 3026 -- an expanded inlined call, where the expansion wraps an actual in 3027 -- an unchecked conversion when needed. The expression of the 3028 -- conversion is always an object. 3029 3030 if Nkind (DS_Copy) = N_Function_Call 3031 3032 or else (Is_Entity_Name (DS_Copy) 3033 and then not Is_Type (Entity (DS_Copy))) 3034 3035 or else (Nkind (DS_Copy) = N_Attribute_Reference 3036 and then Nam_In (Attribute_Name (DS_Copy), 3037 Name_Loop_Entry, Name_Old)) 3038 3039 or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable) 3040 3041 or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion 3042 or else (Nkind (DS_Copy) = N_Qualified_Expression 3043 and then Is_Iterator (Etype (DS_Copy))) 3044 then 3045 -- This is an iterator specification. Rewrite it as such and 3046 -- analyze it to capture function calls that may require 3047 -- finalization actions. 3048 3049 declare 3050 I_Spec : constant Node_Id := 3051 Make_Iterator_Specification (Sloc (N), 3052 Defining_Identifier => Relocate_Node (Id), 3053 Name => DS_Copy, 3054 Subtype_Indication => Empty, 3055 Reverse_Present => Reverse_Present (N)); 3056 Scheme : constant Node_Id := Parent (N); 3057 3058 begin 3059 Set_Iterator_Specification (Scheme, I_Spec); 3060 Set_Loop_Parameter_Specification (Scheme, Empty); 3061 Analyze_Iterator_Specification (I_Spec); 3062 3063 -- In a generic context, analyze the original domain of 3064 -- iteration, for name capture. 3065 3066 if not Expander_Active then 3067 Analyze (DS); 3068 end if; 3069 3070 -- Set kind of loop parameter, which may be used in the 3071 -- subsequent analysis of the condition in a quantified 3072 -- expression. 3073 3074 Set_Ekind (Id, E_Loop_Parameter); 3075 return; 3076 end; 3077 3078 -- Domain of iteration is not a function call, and is side-effect 3079 -- free. 3080 3081 else 3082 -- A quantified expression that appears in a pre/post condition 3083 -- is preanalyzed several times. If the range is given by an 3084 -- attribute reference it is rewritten as a range, and this is 3085 -- done even with expansion disabled. If the type is already set 3086 -- do not reanalyze, because a range with static bounds may be 3087 -- typed Integer by default. 3088 3089 if Nkind (Parent (N)) = N_Quantified_Expression 3090 and then Present (Etype (DS)) 3091 then 3092 null; 3093 else 3094 Analyze (DS); 3095 end if; 3096 end if; 3097 end if; 3098 3099 if DS = Error then 3100 return; 3101 end if; 3102 3103 -- Some additional checks if we are iterating through a type 3104 3105 if Is_Entity_Name (DS) 3106 and then Present (Entity (DS)) 3107 and then Is_Type (Entity (DS)) 3108 then 3109 -- The subtype indication may denote the completion of an incomplete 3110 -- type declaration. 3111 3112 if Ekind (Entity (DS)) = E_Incomplete_Type then 3113 Set_Entity (DS, Get_Full_View (Entity (DS))); 3114 Set_Etype (DS, Entity (DS)); 3115 end if; 3116 3117 Check_Predicate_Use (Entity (DS)); 3118 end if; 3119 3120 -- Error if not discrete type 3121 3122 if not Is_Discrete_Type (Etype (DS)) then 3123 Wrong_Type (DS, Any_Discrete); 3124 Set_Etype (DS, Any_Type); 3125 end if; 3126 3127 Check_Controlled_Array_Attribute (DS); 3128 3129 if Nkind (DS) = N_Subtype_Indication then 3130 Check_Predicate_Use (Entity (Subtype_Mark (DS))); 3131 end if; 3132 3133 Make_Index (DS, N, In_Iter_Schm => True); 3134 Set_Ekind (Id, E_Loop_Parameter); 3135 3136 -- A quantified expression which appears in a pre- or post-condition may 3137 -- be analyzed multiple times. The analysis of the range creates several 3138 -- itypes which reside in different scopes depending on whether the pre- 3139 -- or post-condition has been expanded. Update the type of the loop 3140 -- variable to reflect the proper itype at each stage of analysis. 3141 3142 if No (Etype (Id)) 3143 or else Etype (Id) = Any_Type 3144 or else 3145 (Present (Etype (Id)) 3146 and then Is_Itype (Etype (Id)) 3147 and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions 3148 and then Nkind (Original_Node (Parent (Loop_Nod))) = 3149 N_Quantified_Expression) 3150 then 3151 Set_Etype (Id, Etype (DS)); 3152 end if; 3153 3154 -- Treat a range as an implicit reference to the type, to inhibit 3155 -- spurious warnings. 3156 3157 Generate_Reference (Base_Type (Etype (DS)), N, ' '); 3158 Set_Is_Known_Valid (Id, True); 3159 3160 -- The loop is not a declarative part, so the loop variable must be 3161 -- frozen explicitly. Do not freeze while preanalyzing a quantified 3162 -- expression because the freeze node will not be inserted into the 3163 -- tree due to flag Is_Spec_Expression being set. 3164 3165 if Nkind (Parent (N)) /= N_Quantified_Expression then 3166 declare 3167 Flist : constant List_Id := Freeze_Entity (Id, N); 3168 begin 3169 if Is_Non_Empty_List (Flist) then 3170 Insert_Actions (N, Flist); 3171 end if; 3172 end; 3173 end if; 3174 3175 -- Case where we have a range or a subtype, get type bounds 3176 3177 if Nkind_In (DS, N_Range, N_Subtype_Indication) 3178 and then not Error_Posted (DS) 3179 and then Etype (DS) /= Any_Type 3180 and then Is_Discrete_Type (Etype (DS)) 3181 then 3182 declare 3183 L : Node_Id; 3184 H : Node_Id; 3185 3186 begin 3187 if Nkind (DS) = N_Range then 3188 L := Low_Bound (DS); 3189 H := High_Bound (DS); 3190 else 3191 L := 3192 Type_Low_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); 3193 H := 3194 Type_High_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); 3195 end if; 3196 3197 -- Check for null or possibly null range and issue warning. We 3198 -- suppress such messages in generic templates and instances, 3199 -- because in practice they tend to be dubious in these cases. The 3200 -- check applies as well to rewritten array element loops where a 3201 -- null range may be detected statically. 3202 3203 if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then 3204 3205 -- Suppress the warning if inside a generic template or 3206 -- instance, since in practice they tend to be dubious in these 3207 -- cases since they can result from intended parameterization. 3208 3209 if not Inside_A_Generic and then not In_Instance then 3210 3211 -- Specialize msg if invalid values could make the loop 3212 -- non-null after all. 3213 3214 if Compile_Time_Compare 3215 (L, H, Assume_Valid => False) = GT 3216 then 3217 -- Since we know the range of the loop is null, set the 3218 -- appropriate flag to remove the loop entirely during 3219 -- expansion. 3220 3221 Set_Is_Null_Loop (Loop_Nod); 3222 3223 if Comes_From_Source (N) then 3224 Error_Msg_N 3225 ("??loop range is null, loop will not execute", DS); 3226 end if; 3227 3228 -- Here is where the loop could execute because of 3229 -- invalid values, so issue appropriate message and in 3230 -- this case we do not set the Is_Null_Loop flag since 3231 -- the loop may execute. 3232 3233 elsif Comes_From_Source (N) then 3234 Error_Msg_N 3235 ("??loop range may be null, loop may not execute", 3236 DS); 3237 Error_Msg_N 3238 ("??can only execute if invalid values are present", 3239 DS); 3240 end if; 3241 end if; 3242 3243 -- In either case, suppress warnings in the body of the loop, 3244 -- since it is likely that these warnings will be inappropriate 3245 -- if the loop never actually executes, which is likely. 3246 3247 Set_Suppress_Loop_Warnings (Loop_Nod); 3248 3249 -- The other case for a warning is a reverse loop where the 3250 -- upper bound is the integer literal zero or one, and the 3251 -- lower bound may exceed this value. 3252 3253 -- For example, we have 3254 3255 -- for J in reverse N .. 1 loop 3256 3257 -- In practice, this is very likely to be a case of reversing 3258 -- the bounds incorrectly in the range. 3259 3260 elsif Reverse_Present (N) 3261 and then Nkind (Original_Node (H)) = N_Integer_Literal 3262 and then 3263 (Intval (Original_Node (H)) = Uint_0 3264 or else 3265 Intval (Original_Node (H)) = Uint_1) 3266 then 3267 -- Lower bound may in fact be known and known not to exceed 3268 -- upper bound (e.g. reverse 0 .. 1) and that's OK. 3269 3270 if Compile_Time_Known_Value (L) 3271 and then Expr_Value (L) <= Expr_Value (H) 3272 then 3273 null; 3274 3275 -- Otherwise warning is warranted 3276 3277 else 3278 Error_Msg_N ("??loop range may be null", DS); 3279 Error_Msg_N ("\??bounds may be wrong way round", DS); 3280 end if; 3281 end if; 3282 3283 -- Check if either bound is known to be outside the range of the 3284 -- loop parameter type, this is e.g. the case of a loop from 3285 -- 20..X where the type is 1..19. 3286 3287 -- Such a loop is dubious since either it raises CE or it executes 3288 -- zero times, and that cannot be useful! 3289 3290 if Etype (DS) /= Any_Type 3291 and then not Error_Posted (DS) 3292 and then Nkind (DS) = N_Subtype_Indication 3293 and then Nkind (Constraint (DS)) = N_Range_Constraint 3294 then 3295 declare 3296 LLo : constant Node_Id := 3297 Low_Bound (Range_Expression (Constraint (DS))); 3298 LHi : constant Node_Id := 3299 High_Bound (Range_Expression (Constraint (DS))); 3300 3301 Bad_Bound : Node_Id := Empty; 3302 -- Suspicious loop bound 3303 3304 begin 3305 -- At this stage L, H are the bounds of the type, and LLo 3306 -- Lhi are the low bound and high bound of the loop. 3307 3308 if Compile_Time_Compare (LLo, L, Assume_Valid => True) = LT 3309 or else 3310 Compile_Time_Compare (LLo, H, Assume_Valid => True) = GT 3311 then 3312 Bad_Bound := LLo; 3313 end if; 3314 3315 if Compile_Time_Compare (LHi, L, Assume_Valid => True) = LT 3316 or else 3317 Compile_Time_Compare (LHi, H, Assume_Valid => True) = GT 3318 then 3319 Bad_Bound := LHi; 3320 end if; 3321 3322 if Present (Bad_Bound) then 3323 Error_Msg_N 3324 ("suspicious loop bound out of range of " 3325 & "loop subtype??", Bad_Bound); 3326 Error_Msg_N 3327 ("\loop executes zero times or raises " 3328 & "Constraint_Error??", Bad_Bound); 3329 end if; 3330 end; 3331 end if; 3332 3333 -- This declare block is about warnings, if we get an exception while 3334 -- testing for warnings, we simply abandon the attempt silently. This 3335 -- most likely occurs as the result of a previous error, but might 3336 -- just be an obscure case we have missed. In either case, not giving 3337 -- the warning is perfectly acceptable. 3338 3339 exception 3340 when others => null; 3341 end; 3342 end if; 3343 3344 -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). 3345 -- This check is relevant only when SPARK_Mode is on as it is not a 3346 -- standard Ada legality check. 3347 3348 if SPARK_Mode = On and then Is_Effectively_Volatile (Id) then 3349 Error_Msg_N ("loop parameter cannot be volatile", Id); 3350 end if; 3351 end Analyze_Loop_Parameter_Specification; 3352 3353 ---------------------------- 3354 -- Analyze_Loop_Statement -- 3355 ---------------------------- 3356 3357 procedure Analyze_Loop_Statement (N : Node_Id) is 3358 3359 -- The following exception is raised by routine Prepare_Loop_Statement 3360 -- to avoid further analysis of a transformed loop. 3361 3362 Skip_Analysis : exception; 3363 3364 function Disable_Constant (N : Node_Id) return Traverse_Result; 3365 -- If N represents an E_Variable entity, set Is_True_Constant To False 3366 3367 procedure Disable_Constants is new Traverse_Proc (Disable_Constant); 3368 -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on 3369 -- variables referenced within an OpenACC construct. 3370 3371 procedure Prepare_Loop_Statement (Iter : Node_Id); 3372 -- Determine whether loop statement N with iteration scheme Iter must be 3373 -- transformed prior to analysis, and if so, perform it. The routine 3374 -- raises Skip_Analysis to prevent further analysis of the transformed 3375 -- loop. 3376 3377 ---------------------- 3378 -- Disable_Constant -- 3379 ---------------------- 3380 3381 function Disable_Constant (N : Node_Id) return Traverse_Result is 3382 begin 3383 if Is_Entity_Name (N) 3384 and then Present (Entity (N)) 3385 and then Ekind (Entity (N)) = E_Variable 3386 then 3387 Set_Is_True_Constant (Entity (N), False); 3388 end if; 3389 3390 return OK; 3391 end Disable_Constant; 3392 3393 ---------------------------- 3394 -- Prepare_Loop_Statement -- 3395 ---------------------------- 3396 3397 procedure Prepare_Loop_Statement (Iter : Node_Id) is 3398 function Has_Sec_Stack_Default_Iterator 3399 (Cont_Typ : Entity_Id) return Boolean; 3400 pragma Inline (Has_Sec_Stack_Default_Iterator); 3401 -- Determine whether container type Cont_Typ has a default iterator 3402 -- that requires secondary stack management. 3403 3404 function Is_Sec_Stack_Iteration_Primitive 3405 (Cont_Typ : Entity_Id; 3406 Iter_Prim_Nam : Name_Id) return Boolean; 3407 pragma Inline (Is_Sec_Stack_Iteration_Primitive); 3408 -- Determine whether container type Cont_Typ has an iteration routine 3409 -- described by its name Iter_Prim_Nam that requires secondary stack 3410 -- management. 3411 3412 function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean; 3413 pragma Inline (Is_Wrapped_In_Block); 3414 -- Determine whether arbitrary statement Stmt is the sole statement 3415 -- wrapped within some block, excluding pragmas. 3416 3417 procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id); 3418 pragma Inline (Prepare_Iterator_Loop); 3419 -- Prepare an iterator loop with iteration specification Iter_Spec 3420 -- for transformation if needed. 3421 3422 procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id); 3423 pragma Inline (Prepare_Param_Spec_Loop); 3424 -- Prepare a discrete loop with parameter specification Param_Spec 3425 -- for transformation if needed. 3426 3427 procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean); 3428 pragma Inline (Wrap_Loop_Statement); 3429 pragma No_Return (Wrap_Loop_Statement); 3430 -- Wrap loop statement N within a block. Flag Manage_Sec_Stack must 3431 -- be set when the block must mark and release the secondary stack. 3432 3433 ------------------------------------ 3434 -- Has_Sec_Stack_Default_Iterator -- 3435 ------------------------------------ 3436 3437 function Has_Sec_Stack_Default_Iterator 3438 (Cont_Typ : Entity_Id) return Boolean 3439 is 3440 Def_Iter : constant Node_Id := 3441 Find_Value_Of_Aspect 3442 (Cont_Typ, Aspect_Default_Iterator); 3443 begin 3444 return 3445 Present (Def_Iter) 3446 and then Requires_Transient_Scope (Etype (Def_Iter)); 3447 end Has_Sec_Stack_Default_Iterator; 3448 3449 -------------------------------------- 3450 -- Is_Sec_Stack_Iteration_Primitive -- 3451 -------------------------------------- 3452 3453 function Is_Sec_Stack_Iteration_Primitive 3454 (Cont_Typ : Entity_Id; 3455 Iter_Prim_Nam : Name_Id) return Boolean 3456 is 3457 Iter_Prim : constant Entity_Id := 3458 Get_Iterable_Type_Primitive 3459 (Cont_Typ, Iter_Prim_Nam); 3460 begin 3461 return 3462 Present (Iter_Prim) 3463 and then Requires_Transient_Scope (Etype (Iter_Prim)); 3464 end Is_Sec_Stack_Iteration_Primitive; 3465 3466 ------------------------- 3467 -- Is_Wrapped_In_Block -- 3468 ------------------------- 3469 3470 function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean is 3471 Blk_HSS : Node_Id; 3472 Blk_Id : Entity_Id; 3473 Blk_Stmt : Node_Id; 3474 3475 begin 3476 Blk_Id := Current_Scope; 3477 3478 -- The current context is a block. Inspect the statements of the 3479 -- block to determine whether it wraps Stmt. 3480 3481 if Ekind (Blk_Id) = E_Block 3482 and then Present (Block_Node (Blk_Id)) 3483 then 3484 Blk_HSS := 3485 Handled_Statement_Sequence (Parent (Block_Node (Blk_Id))); 3486 3487 -- Skip leading pragmas introduced for invariant and predicate 3488 -- checks. 3489 3490 Blk_Stmt := First (Statements (Blk_HSS)); 3491 while Present (Blk_Stmt) 3492 and then Nkind (Blk_Stmt) = N_Pragma 3493 loop 3494 Next (Blk_Stmt); 3495 end loop; 3496 3497 return Blk_Stmt = Stmt and then No (Next (Blk_Stmt)); 3498 end if; 3499 3500 return False; 3501 end Is_Wrapped_In_Block; 3502 3503 --------------------------- 3504 -- Prepare_Iterator_Loop -- 3505 --------------------------- 3506 3507 procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id) is 3508 Cont_Typ : Entity_Id; 3509 Nam : Node_Id; 3510 Nam_Copy : Node_Id; 3511 3512 begin 3513 -- The iterator specification has syntactic errors. Transform the 3514 -- loop into an infinite loop in order to safely perform at least 3515 -- some minor analysis. This check must come first. 3516 3517 if Error_Posted (Iter_Spec) then 3518 Set_Iteration_Scheme (N, Empty); 3519 Analyze (N); 3520 3521 raise Skip_Analysis; 3522 3523 -- Nothing to do when the loop is already wrapped in a block 3524 3525 elsif Is_Wrapped_In_Block (N) then 3526 null; 3527 3528 -- Otherwise the iterator loop traverses an array or a container 3529 -- and appears in the form 3530 -- 3531 -- for Def_Id in [reverse] Iterator_Name loop 3532 -- for Def_Id [: Subtyp_Indic] of [reverse] Iterable_Name loop 3533 3534 else 3535 -- Prepare a copy of the iterated name for preanalysis. The 3536 -- copy is semi inserted into the tree by setting its Parent 3537 -- pointer. 3538 3539 Nam := Name (Iter_Spec); 3540 Nam_Copy := New_Copy_Tree (Nam); 3541 Set_Parent (Nam_Copy, Parent (Nam)); 3542 3543 -- Determine what the loop is iterating on 3544 3545 Preanalyze_Range (Nam_Copy); 3546 Cont_Typ := Etype (Nam_Copy); 3547 3548 -- The iterator loop is traversing an array. This case does not 3549 -- require any transformation. 3550 3551 if Is_Array_Type (Cont_Typ) then 3552 null; 3553 3554 -- Otherwise unconditionally wrap the loop statement within 3555 -- a block. The expansion of iterator loops may relocate the 3556 -- iterator outside the loop, thus "leaking" its entity into 3557 -- the enclosing scope. Wrapping the loop statement allows 3558 -- for multiple iterator loops using the same iterator name 3559 -- to coexist within the same scope. 3560 -- 3561 -- The block must manage the secondary stack when the iterator 3562 -- loop is traversing a container using either 3563 -- 3564 -- * A default iterator obtained on the secondary stack 3565 -- 3566 -- * Call to Iterate where the iterator is returned on the 3567 -- secondary stack. 3568 -- 3569 -- * Combination of First, Next, and Has_Element where the 3570 -- first two return a cursor on the secondary stack. 3571 3572 else 3573 Wrap_Loop_Statement 3574 (Manage_Sec_Stack => 3575 Has_Sec_Stack_Default_Iterator (Cont_Typ) 3576 or else Has_Sec_Stack_Call (Nam_Copy) 3577 or else Is_Sec_Stack_Iteration_Primitive 3578 (Cont_Typ, Name_First) 3579 or else Is_Sec_Stack_Iteration_Primitive 3580 (Cont_Typ, Name_Next)); 3581 end if; 3582 end if; 3583 end Prepare_Iterator_Loop; 3584 3585 ----------------------------- 3586 -- Prepare_Param_Spec_Loop -- 3587 ----------------------------- 3588 3589 procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id) is 3590 High : Node_Id; 3591 Low : Node_Id; 3592 Rng : Node_Id; 3593 Rng_Copy : Node_Id; 3594 Rng_Typ : Entity_Id; 3595 3596 begin 3597 Rng := Discrete_Subtype_Definition (Param_Spec); 3598 3599 -- Nothing to do when the loop is already wrapped in a block 3600 3601 if Is_Wrapped_In_Block (N) then 3602 null; 3603 3604 -- The parameter specification appears in the form 3605 -- 3606 -- for Def_Id in Subtype_Mark Constraint loop 3607 3608 elsif Nkind (Rng) = N_Subtype_Indication 3609 and then Nkind (Range_Expression (Constraint (Rng))) = N_Range 3610 then 3611 Rng := Range_Expression (Constraint (Rng)); 3612 3613 -- Preanalyze the bounds of the range constraint 3614 3615 Low := New_Copy_Tree (Low_Bound (Rng)); 3616 High := New_Copy_Tree (High_Bound (Rng)); 3617 3618 Preanalyze (Low); 3619 Preanalyze (High); 3620 3621 -- The bounds contain at least one function call that returns 3622 -- on the secondary stack. Note that the loop must be wrapped 3623 -- only when such a call exists. 3624 3625 if Has_Sec_Stack_Call (Low) 3626 or else 3627 Has_Sec_Stack_Call (High) 3628 then 3629 Wrap_Loop_Statement (Manage_Sec_Stack => True); 3630 end if; 3631 3632 -- Otherwise the parameter specification appears in the form 3633 -- 3634 -- for Def_Id in Range loop 3635 3636 else 3637 -- Prepare a copy of the discrete range for preanalysis. The 3638 -- copy is semi inserted into the tree by setting its Parent 3639 -- pointer. 3640 3641 Rng_Copy := New_Copy_Tree (Rng); 3642 Set_Parent (Rng_Copy, Parent (Rng)); 3643 3644 -- Determine what the loop is iterating on 3645 3646 Preanalyze_Range (Rng_Copy); 3647 Rng_Typ := Etype (Rng_Copy); 3648 3649 -- Wrap the loop statement within a block in order to manage 3650 -- the secondary stack when the discrete range is 3651 -- 3652 -- * Either a Forward_Iterator or a Reverse_Iterator 3653 -- 3654 -- * Function call whose return type requires finalization 3655 -- actions. 3656 3657 -- ??? it is unclear why using Has_Sec_Stack_Call directly on 3658 -- the discrete range causes the freeze node of an itype to be 3659 -- in the wrong scope in complex assertion expressions. 3660 3661 if Is_Iterator (Rng_Typ) 3662 or else (Nkind (Rng_Copy) = N_Function_Call 3663 and then Needs_Finalization (Rng_Typ)) 3664 then 3665 Wrap_Loop_Statement (Manage_Sec_Stack => True); 3666 end if; 3667 end if; 3668 end Prepare_Param_Spec_Loop; 3669 3670 ------------------------- 3671 -- Wrap_Loop_Statement -- 3672 ------------------------- 3673 3674 procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean) is 3675 Loc : constant Source_Ptr := Sloc (N); 3676 3677 Blk : Node_Id; 3678 Blk_Id : Entity_Id; 3679 3680 begin 3681 Blk := 3682 Make_Block_Statement (Loc, 3683 Declarations => New_List, 3684 Handled_Statement_Sequence => 3685 Make_Handled_Sequence_Of_Statements (Loc, 3686 Statements => New_List (Relocate_Node (N)))); 3687 3688 Add_Block_Identifier (Blk, Blk_Id); 3689 Set_Uses_Sec_Stack (Blk_Id, Manage_Sec_Stack); 3690 3691 Rewrite (N, Blk); 3692 Analyze (N); 3693 3694 raise Skip_Analysis; 3695 end Wrap_Loop_Statement; 3696 3697 -- Local variables 3698 3699 Iter_Spec : constant Node_Id := Iterator_Specification (Iter); 3700 Param_Spec : constant Node_Id := Loop_Parameter_Specification (Iter); 3701 3702 -- Start of processing for Prepare_Loop_Statement 3703 3704 begin 3705 if Present (Iter_Spec) then 3706 Prepare_Iterator_Loop (Iter_Spec); 3707 3708 elsif Present (Param_Spec) then 3709 Prepare_Param_Spec_Loop (Param_Spec); 3710 end if; 3711 end Prepare_Loop_Statement; 3712 3713 -- Local declarations 3714 3715 Id : constant Node_Id := Identifier (N); 3716 Iter : constant Node_Id := Iteration_Scheme (N); 3717 Loc : constant Source_Ptr := Sloc (N); 3718 Ent : Entity_Id; 3719 Stmt : Node_Id; 3720 3721 -- Start of processing for Analyze_Loop_Statement 3722 3723 begin 3724 if Present (Id) then 3725 3726 -- Make name visible, e.g. for use in exit statements. Loop labels 3727 -- are always considered to be referenced. 3728 3729 Analyze (Id); 3730 Ent := Entity (Id); 3731 3732 -- Guard against serious error (typically, a scope mismatch when 3733 -- semantic analysis is requested) by creating loop entity to 3734 -- continue analysis. 3735 3736 if No (Ent) then 3737 if Total_Errors_Detected /= 0 then 3738 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 3739 else 3740 raise Program_Error; 3741 end if; 3742 3743 -- Verify that the loop name is hot hidden by an unrelated 3744 -- declaration in an inner scope. 3745 3746 elsif Ekind (Ent) /= E_Label and then Ekind (Ent) /= E_Loop then 3747 Error_Msg_Sloc := Sloc (Ent); 3748 Error_Msg_N ("implicit label declaration for & is hidden#", Id); 3749 3750 if Present (Homonym (Ent)) 3751 and then Ekind (Homonym (Ent)) = E_Label 3752 then 3753 Set_Entity (Id, Ent); 3754 Set_Ekind (Ent, E_Loop); 3755 end if; 3756 3757 else 3758 Generate_Reference (Ent, N, ' '); 3759 Generate_Definition (Ent); 3760 3761 -- If we found a label, mark its type. If not, ignore it, since it 3762 -- means we have a conflicting declaration, which would already 3763 -- have been diagnosed at declaration time. Set Label_Construct 3764 -- of the implicit label declaration, which is not created by the 3765 -- parser for generic units. 3766 3767 if Ekind (Ent) = E_Label then 3768 Set_Ekind (Ent, E_Loop); 3769 3770 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then 3771 Set_Label_Construct (Parent (Ent), N); 3772 end if; 3773 end if; 3774 end if; 3775 3776 -- Case of no identifier present. Create one and attach it to the 3777 -- loop statement for use as a scope and as a reference for later 3778 -- expansions. Indicate that the label does not come from source, 3779 -- and attach it to the loop statement so it is part of the tree, 3780 -- even without a full declaration. 3781 3782 else 3783 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); 3784 Set_Etype (Ent, Standard_Void_Type); 3785 Set_Identifier (N, New_Occurrence_Of (Ent, Loc)); 3786 Set_Parent (Ent, N); 3787 Set_Has_Created_Identifier (N); 3788 end if; 3789 3790 -- Determine whether the loop statement must be transformed prior to 3791 -- analysis, and if so, perform it. This early modification is needed 3792 -- when: 3793 -- 3794 -- * The loop has an erroneous iteration scheme. In this case the 3795 -- loop is converted into an infinite loop in order to perform 3796 -- minor analysis. 3797 -- 3798 -- * The loop is an Ada 2012 iterator loop. In this case the loop is 3799 -- wrapped within a block to provide a local scope for the iterator. 3800 -- If the iterator specification requires the secondary stack in any 3801 -- way, the block is marked in order to manage it. 3802 -- 3803 -- * The loop is using a parameter specification where the discrete 3804 -- range requires the secondary stack. In this case the loop is 3805 -- wrapped within a block in order to manage the secondary stack. 3806 3807 if Present (Iter) then 3808 Prepare_Loop_Statement (Iter); 3809 end if; 3810 3811 -- Kill current values on entry to loop, since statements in the body of 3812 -- the loop may have been executed before the loop is entered. Similarly 3813 -- we kill values after the loop, since we do not know that the body of 3814 -- the loop was executed. 3815 3816 Kill_Current_Values; 3817 Push_Scope (Ent); 3818 Analyze_Iteration_Scheme (Iter); 3819 3820 -- Check for following case which merits a warning if the type E of is 3821 -- a multi-dimensional array (and no explicit subscript ranges present). 3822 3823 -- for J in E'Range 3824 -- for K in E'Range 3825 3826 if Present (Iter) 3827 and then Present (Loop_Parameter_Specification (Iter)) 3828 then 3829 declare 3830 LPS : constant Node_Id := Loop_Parameter_Specification (Iter); 3831 DSD : constant Node_Id := 3832 Original_Node (Discrete_Subtype_Definition (LPS)); 3833 begin 3834 if Nkind (DSD) = N_Attribute_Reference 3835 and then Attribute_Name (DSD) = Name_Range 3836 and then No (Expressions (DSD)) 3837 then 3838 declare 3839 Typ : constant Entity_Id := Etype (Prefix (DSD)); 3840 begin 3841 if Is_Array_Type (Typ) 3842 and then Number_Dimensions (Typ) > 1 3843 and then Nkind (Parent (N)) = N_Loop_Statement 3844 and then Present (Iteration_Scheme (Parent (N))) 3845 then 3846 declare 3847 OIter : constant Node_Id := 3848 Iteration_Scheme (Parent (N)); 3849 OLPS : constant Node_Id := 3850 Loop_Parameter_Specification (OIter); 3851 ODSD : constant Node_Id := 3852 Original_Node (Discrete_Subtype_Definition (OLPS)); 3853 begin 3854 if Nkind (ODSD) = N_Attribute_Reference 3855 and then Attribute_Name (ODSD) = Name_Range 3856 and then No (Expressions (ODSD)) 3857 and then Etype (Prefix (ODSD)) = Typ 3858 then 3859 Error_Msg_Sloc := Sloc (ODSD); 3860 Error_Msg_N 3861 ("inner range same as outer range#??", DSD); 3862 end if; 3863 end; 3864 end if; 3865 end; 3866 end if; 3867 end; 3868 end if; 3869 3870 -- Analyze the statements of the body except in the case of an Ada 2012 3871 -- iterator with the expander active. In this case the expander will do 3872 -- a rewrite of the loop into a while loop. We will then analyze the 3873 -- loop body when we analyze this while loop. 3874 3875 -- We need to do this delay because if the container is for indefinite 3876 -- types the actual subtype of the components will only be determined 3877 -- when the cursor declaration is analyzed. 3878 3879 -- If the expander is not active then we want to analyze the loop body 3880 -- now even in the Ada 2012 iterator case, since the rewriting will not 3881 -- be done. Insert the loop variable in the current scope, if not done 3882 -- when analysing the iteration scheme. Set its kind properly to detect 3883 -- improper uses in the loop body. 3884 3885 -- In GNATprove mode, we do one of the above depending on the kind of 3886 -- loop. If it is an iterator over an array, then we do not analyze the 3887 -- loop now. We will analyze it after it has been rewritten by the 3888 -- special SPARK expansion which is activated in GNATprove mode. We need 3889 -- to do this so that other expansions that should occur in GNATprove 3890 -- mode take into account the specificities of the rewritten loop, in 3891 -- particular the introduction of a renaming (which needs to be 3892 -- expanded). 3893 3894 -- In other cases in GNATprove mode then we want to analyze the loop 3895 -- body now, since no rewriting will occur. Within a generic the 3896 -- GNATprove mode is irrelevant, we must analyze the generic for 3897 -- non-local name capture. 3898 3899 if Present (Iter) 3900 and then Present (Iterator_Specification (Iter)) 3901 then 3902 if GNATprove_Mode 3903 and then Is_Iterator_Over_Array (Iterator_Specification (Iter)) 3904 and then not Inside_A_Generic 3905 then 3906 null; 3907 3908 elsif not Expander_Active then 3909 declare 3910 I_Spec : constant Node_Id := Iterator_Specification (Iter); 3911 Id : constant Entity_Id := Defining_Identifier (I_Spec); 3912 3913 begin 3914 if Scope (Id) /= Current_Scope then 3915 Enter_Name (Id); 3916 end if; 3917 3918 -- In an element iterator, The loop parameter is a variable if 3919 -- the domain of iteration (container or array) is a variable. 3920 3921 if not Of_Present (I_Spec) 3922 or else not Is_Variable (Name (I_Spec)) 3923 then 3924 Set_Ekind (Id, E_Loop_Parameter); 3925 end if; 3926 end; 3927 3928 Analyze_Statements (Statements (N)); 3929 end if; 3930 3931 else 3932 -- Pre-Ada2012 for-loops and while loops 3933 3934 Analyze_Statements (Statements (N)); 3935 end if; 3936 3937 -- When the iteration scheme of a loop contains attribute 'Loop_Entry, 3938 -- the loop is transformed into a conditional block. Retrieve the loop. 3939 3940 Stmt := N; 3941 3942 if Subject_To_Loop_Entry_Attributes (Stmt) then 3943 Stmt := Find_Loop_In_Conditional_Block (Stmt); 3944 end if; 3945 3946 -- Finish up processing for the loop. We kill all current values, since 3947 -- in general we don't know if the statements in the loop have been 3948 -- executed. We could do a bit better than this with a loop that we 3949 -- know will execute at least once, but it's not worth the trouble and 3950 -- the front end is not in the business of flow tracing. 3951 3952 Process_End_Label (Stmt, 'e', Ent); 3953 End_Scope; 3954 Kill_Current_Values; 3955 3956 -- Check for infinite loop. Skip check for generated code, since it 3957 -- justs waste time and makes debugging the routine called harder. 3958 3959 -- Note that we have to wait till the body of the loop is fully analyzed 3960 -- before making this call, since Check_Infinite_Loop_Warning relies on 3961 -- being able to use semantic visibility information to find references. 3962 3963 if Comes_From_Source (Stmt) then 3964 Check_Infinite_Loop_Warning (Stmt); 3965 end if; 3966 3967 -- Code after loop is unreachable if the loop has no WHILE or FOR and 3968 -- contains no EXIT statements within the body of the loop. 3969 3970 if No (Iter) and then not Has_Exit (Ent) then 3971 Check_Unreachable_Code (Stmt); 3972 end if; 3973 3974 -- Variables referenced within a loop subject to possible OpenACC 3975 -- offloading may be implicitly written to as part of the OpenACC 3976 -- transaction. Clear flags possibly conveying that they are constant, 3977 -- set for example when the code does not explicitly assign them. 3978 3979 if Is_OpenAcc_Environment (Stmt) then 3980 Disable_Constants (Stmt); 3981 end if; 3982 3983 exception 3984 when Skip_Analysis => 3985 null; 3986 end Analyze_Loop_Statement; 3987 3988 ---------------------------- 3989 -- Analyze_Null_Statement -- 3990 ---------------------------- 3991 3992 -- Note: the semantics of the null statement is implemented by a single 3993 -- null statement, too bad everything isn't as simple as this. 3994 3995 procedure Analyze_Null_Statement (N : Node_Id) is 3996 pragma Warnings (Off, N); 3997 begin 3998 null; 3999 end Analyze_Null_Statement; 4000 4001 ------------------------- 4002 -- Analyze_Target_Name -- 4003 ------------------------- 4004 4005 procedure Analyze_Target_Name (N : Node_Id) is 4006 begin 4007 -- A target name has the type of the left-hand side of the enclosing 4008 -- assignment. 4009 4010 Set_Etype (N, Etype (Name (Current_Assignment))); 4011 end Analyze_Target_Name; 4012 4013 ------------------------ 4014 -- Analyze_Statements -- 4015 ------------------------ 4016 4017 procedure Analyze_Statements (L : List_Id) is 4018 Lab : Entity_Id; 4019 S : Node_Id; 4020 4021 begin 4022 -- The labels declared in the statement list are reachable from 4023 -- statements in the list. We do this as a prepass so that any goto 4024 -- statement will be properly flagged if its target is not reachable. 4025 -- This is not required, but is nice behavior. 4026 4027 S := First (L); 4028 while Present (S) loop 4029 if Nkind (S) = N_Label then 4030 Analyze (Identifier (S)); 4031 Lab := Entity (Identifier (S)); 4032 4033 -- If we found a label mark it as reachable 4034 4035 if Ekind (Lab) = E_Label then 4036 Generate_Definition (Lab); 4037 Set_Reachable (Lab); 4038 4039 if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then 4040 Set_Label_Construct (Parent (Lab), S); 4041 end if; 4042 4043 -- If we failed to find a label, it means the implicit declaration 4044 -- of the label was hidden. A for-loop parameter can do this to 4045 -- a label with the same name inside the loop, since the implicit 4046 -- label declaration is in the innermost enclosing body or block 4047 -- statement. 4048 4049 else 4050 Error_Msg_Sloc := Sloc (Lab); 4051 Error_Msg_N 4052 ("implicit label declaration for & is hidden#", 4053 Identifier (S)); 4054 end if; 4055 end if; 4056 4057 Next (S); 4058 end loop; 4059 4060 -- Perform semantic analysis on all statements 4061 4062 Conditional_Statements_Begin; 4063 4064 S := First (L); 4065 while Present (S) loop 4066 Analyze (S); 4067 4068 -- Remove dimension in all statements 4069 4070 Remove_Dimension_In_Statement (S); 4071 Next (S); 4072 end loop; 4073 4074 Conditional_Statements_End; 4075 4076 -- Make labels unreachable. Visibility is not sufficient, because labels 4077 -- in one if-branch for example are not reachable from the other branch, 4078 -- even though their declarations are in the enclosing declarative part. 4079 4080 S := First (L); 4081 while Present (S) loop 4082 if Nkind (S) = N_Label then 4083 Set_Reachable (Entity (Identifier (S)), False); 4084 end if; 4085 4086 Next (S); 4087 end loop; 4088 end Analyze_Statements; 4089 4090 ---------------------------- 4091 -- Check_Unreachable_Code -- 4092 ---------------------------- 4093 4094 procedure Check_Unreachable_Code (N : Node_Id) is 4095 Error_Node : Node_Id; 4096 P : Node_Id; 4097 4098 begin 4099 if Is_List_Member (N) and then Comes_From_Source (N) then 4100 declare 4101 Nxt : Node_Id; 4102 4103 begin 4104 Nxt := Original_Node (Next (N)); 4105 4106 -- Skip past pragmas 4107 4108 while Nkind (Nxt) = N_Pragma loop 4109 Nxt := Original_Node (Next (Nxt)); 4110 end loop; 4111 4112 -- If a label follows us, then we never have dead code, since 4113 -- someone could branch to the label, so we just ignore it, unless 4114 -- we are in formal mode where goto statements are not allowed. 4115 4116 if Nkind (Nxt) = N_Label 4117 and then not Restriction_Check_Required (SPARK_05) 4118 then 4119 return; 4120 4121 -- Otherwise see if we have a real statement following us 4122 4123 elsif Present (Nxt) 4124 and then Comes_From_Source (Nxt) 4125 and then Is_Statement (Nxt) 4126 then 4127 -- Special very annoying exception. If we have a return that 4128 -- follows a raise, then we allow it without a warning, since 4129 -- the Ada RM annoyingly requires a useless return here. 4130 4131 if Nkind (Original_Node (N)) /= N_Raise_Statement 4132 or else Nkind (Nxt) /= N_Simple_Return_Statement 4133 then 4134 -- The rather strange shenanigans with the warning message 4135 -- here reflects the fact that Kill_Dead_Code is very good 4136 -- at removing warnings in deleted code, and this is one 4137 -- warning we would prefer NOT to have removed. 4138 4139 Error_Node := Nxt; 4140 4141 -- If we have unreachable code, analyze and remove the 4142 -- unreachable code, since it is useless and we don't 4143 -- want to generate junk warnings. 4144 4145 -- We skip this step if we are not in code generation mode 4146 -- or CodePeer mode. 4147 4148 -- This is the one case where we remove dead code in the 4149 -- semantics as opposed to the expander, and we do not want 4150 -- to remove code if we are not in code generation mode, 4151 -- since this messes up the ASIS trees or loses useful 4152 -- information in the CodePeer tree. 4153 4154 -- Note that one might react by moving the whole circuit to 4155 -- exp_ch5, but then we lose the warning in -gnatc mode. 4156 4157 if Operating_Mode = Generate_Code 4158 and then not CodePeer_Mode 4159 then 4160 loop 4161 Nxt := Next (N); 4162 4163 -- Quit deleting when we have nothing more to delete 4164 -- or if we hit a label (since someone could transfer 4165 -- control to a label, so we should not delete it). 4166 4167 exit when No (Nxt) or else Nkind (Nxt) = N_Label; 4168 4169 -- Statement/declaration is to be deleted 4170 4171 Analyze (Nxt); 4172 Remove (Nxt); 4173 Kill_Dead_Code (Nxt); 4174 end loop; 4175 end if; 4176 4177 -- Now issue the warning (or error in formal mode) 4178 4179 if Restriction_Check_Required (SPARK_05) then 4180 Check_SPARK_05_Restriction 4181 ("unreachable code is not allowed", Error_Node); 4182 else 4183 Error_Msg 4184 ("??unreachable code!", Sloc (Error_Node), Error_Node); 4185 end if; 4186 end if; 4187 4188 -- If the unconditional transfer of control instruction is the 4189 -- last statement of a sequence, then see if our parent is one of 4190 -- the constructs for which we count unblocked exits, and if so, 4191 -- adjust the count. 4192 4193 else 4194 P := Parent (N); 4195 4196 -- Statements in THEN part or ELSE part of IF statement 4197 4198 if Nkind (P) = N_If_Statement then 4199 null; 4200 4201 -- Statements in ELSIF part of an IF statement 4202 4203 elsif Nkind (P) = N_Elsif_Part then 4204 P := Parent (P); 4205 pragma Assert (Nkind (P) = N_If_Statement); 4206 4207 -- Statements in CASE statement alternative 4208 4209 elsif Nkind (P) = N_Case_Statement_Alternative then 4210 P := Parent (P); 4211 pragma Assert (Nkind (P) = N_Case_Statement); 4212 4213 -- Statements in body of block 4214 4215 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 4216 and then Nkind (Parent (P)) = N_Block_Statement 4217 then 4218 -- The original loop is now placed inside a block statement 4219 -- due to the expansion of attribute 'Loop_Entry. Return as 4220 -- this is not a "real" block for the purposes of exit 4221 -- counting. 4222 4223 if Nkind (N) = N_Loop_Statement 4224 and then Subject_To_Loop_Entry_Attributes (N) 4225 then 4226 return; 4227 end if; 4228 4229 -- Statements in exception handler in a block 4230 4231 elsif Nkind (P) = N_Exception_Handler 4232 and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements 4233 and then Nkind (Parent (Parent (P))) = N_Block_Statement 4234 then 4235 null; 4236 4237 -- None of these cases, so return 4238 4239 else 4240 return; 4241 end if; 4242 4243 -- This was one of the cases we are looking for (i.e. the 4244 -- parent construct was IF, CASE or block) so decrement count. 4245 4246 Unblocked_Exit_Count := Unblocked_Exit_Count - 1; 4247 end if; 4248 end; 4249 end if; 4250 end Check_Unreachable_Code; 4251 4252 ------------------------ 4253 -- Has_Sec_Stack_Call -- 4254 ------------------------ 4255 4256 function Has_Sec_Stack_Call (N : Node_Id) return Boolean is 4257 function Check_Call (N : Node_Id) return Traverse_Result; 4258 -- Check if N is a function call which uses the secondary stack 4259 4260 ---------------- 4261 -- Check_Call -- 4262 ---------------- 4263 4264 function Check_Call (N : Node_Id) return Traverse_Result is 4265 Nam : Node_Id; 4266 Subp : Entity_Id; 4267 Typ : Entity_Id; 4268 4269 begin 4270 if Nkind (N) = N_Function_Call then 4271 Nam := Name (N); 4272 4273 -- Obtain the subprogram being invoked 4274 4275 loop 4276 if Nkind (Nam) = N_Explicit_Dereference then 4277 Nam := Prefix (Nam); 4278 4279 elsif Nkind (Nam) = N_Selected_Component then 4280 Nam := Selector_Name (Nam); 4281 4282 else 4283 exit; 4284 end if; 4285 end loop; 4286 4287 Subp := Entity (Nam); 4288 4289 if Present (Subp) then 4290 Typ := Etype (Subp); 4291 4292 if Requires_Transient_Scope (Typ) then 4293 return Abandon; 4294 4295 elsif Sec_Stack_Needed_For_Return (Subp) then 4296 return Abandon; 4297 end if; 4298 end if; 4299 end if; 4300 4301 -- Continue traversing the tree 4302 4303 return OK; 4304 end Check_Call; 4305 4306 function Check_Calls is new Traverse_Func (Check_Call); 4307 4308 -- Start of processing for Has_Sec_Stack_Call 4309 4310 begin 4311 return Check_Calls (N) = Abandon; 4312 end Has_Sec_Stack_Call; 4313 4314 ---------------------- 4315 -- Preanalyze_Range -- 4316 ---------------------- 4317 4318 procedure Preanalyze_Range (R_Copy : Node_Id) is 4319 Save_Analysis : constant Boolean := Full_Analysis; 4320 Typ : Entity_Id; 4321 4322 begin 4323 Full_Analysis := False; 4324 Expander_Mode_Save_And_Set (False); 4325 4326 -- In addition to the above we must explicitly suppress the generation 4327 -- of freeze nodes that might otherwise be generated during resolution 4328 -- of the range (e.g. if given by an attribute that will freeze its 4329 -- prefix). 4330 4331 Set_Must_Not_Freeze (R_Copy); 4332 4333 if Nkind (R_Copy) = N_Attribute_Reference then 4334 Set_Must_Not_Freeze (Prefix (R_Copy)); 4335 end if; 4336 4337 Analyze (R_Copy); 4338 4339 if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then 4340 4341 -- Apply preference rules for range of predefined integer types, or 4342 -- check for array or iterable construct for "of" iterator, or 4343 -- diagnose true ambiguity. 4344 4345 declare 4346 I : Interp_Index; 4347 It : Interp; 4348 Found : Entity_Id := Empty; 4349 4350 begin 4351 Get_First_Interp (R_Copy, I, It); 4352 while Present (It.Typ) loop 4353 if Is_Discrete_Type (It.Typ) then 4354 if No (Found) then 4355 Found := It.Typ; 4356 else 4357 if Scope (Found) = Standard_Standard then 4358 null; 4359 4360 elsif Scope (It.Typ) = Standard_Standard then 4361 Found := It.Typ; 4362 4363 else 4364 -- Both of them are user-defined 4365 4366 Error_Msg_N 4367 ("ambiguous bounds in range of iteration", R_Copy); 4368 Error_Msg_N ("\possible interpretations:", R_Copy); 4369 Error_Msg_NE ("\\} ", R_Copy, Found); 4370 Error_Msg_NE ("\\} ", R_Copy, It.Typ); 4371 exit; 4372 end if; 4373 end if; 4374 4375 elsif Nkind (Parent (R_Copy)) = N_Iterator_Specification 4376 and then Of_Present (Parent (R_Copy)) 4377 then 4378 if Is_Array_Type (It.Typ) 4379 or else Has_Aspect (It.Typ, Aspect_Iterator_Element) 4380 or else Has_Aspect (It.Typ, Aspect_Constant_Indexing) 4381 or else Has_Aspect (It.Typ, Aspect_Variable_Indexing) 4382 then 4383 if No (Found) then 4384 Found := It.Typ; 4385 Set_Etype (R_Copy, It.Typ); 4386 4387 else 4388 Error_Msg_N ("ambiguous domain of iteration", R_Copy); 4389 end if; 4390 end if; 4391 end if; 4392 4393 Get_Next_Interp (I, It); 4394 end loop; 4395 end; 4396 end if; 4397 4398 -- Subtype mark in iteration scheme 4399 4400 if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then 4401 null; 4402 4403 -- Expression in range, or Ada 2012 iterator 4404 4405 elsif Nkind (R_Copy) in N_Subexpr then 4406 Resolve (R_Copy); 4407 Typ := Etype (R_Copy); 4408 4409 if Is_Discrete_Type (Typ) then 4410 null; 4411 4412 -- Check that the resulting object is an iterable container 4413 4414 elsif Has_Aspect (Typ, Aspect_Iterator_Element) 4415 or else Has_Aspect (Typ, Aspect_Constant_Indexing) 4416 or else Has_Aspect (Typ, Aspect_Variable_Indexing) 4417 then 4418 null; 4419 4420 -- The expression may yield an implicit reference to an iterable 4421 -- container. Insert explicit dereference so that proper type is 4422 -- visible in the loop. 4423 4424 elsif Has_Implicit_Dereference (Etype (R_Copy)) then 4425 declare 4426 Disc : Entity_Id; 4427 4428 begin 4429 Disc := First_Discriminant (Typ); 4430 while Present (Disc) loop 4431 if Has_Implicit_Dereference (Disc) then 4432 Build_Explicit_Dereference (R_Copy, Disc); 4433 exit; 4434 end if; 4435 4436 Next_Discriminant (Disc); 4437 end loop; 4438 end; 4439 4440 end if; 4441 end if; 4442 4443 Expander_Mode_Restore; 4444 Full_Analysis := Save_Analysis; 4445 end Preanalyze_Range; 4446 4447end Sem_Ch5; 4448