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