1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 5 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Aggr; use Exp_Aggr; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Ch11; use Exp_Ch11; 37with Exp_Dbug; use Exp_Dbug; 38with Exp_Pakd; use Exp_Pakd; 39with Exp_Tss; use Exp_Tss; 40with Exp_Util; use Exp_Util; 41with Inline; use Inline; 42with Namet; use Namet; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Opt; use Opt; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sinfo; use Sinfo; 50with Sem; use Sem; 51with Sem_Aux; use Sem_Aux; 52with Sem_Ch3; use Sem_Ch3; 53with Sem_Ch8; use Sem_Ch8; 54with Sem_Ch13; use Sem_Ch13; 55with Sem_Eval; use Sem_Eval; 56with Sem_Res; use Sem_Res; 57with Sem_Util; use Sem_Util; 58with Snames; use Snames; 59with Stand; use Stand; 60with Stringt; use Stringt; 61with Tbuild; use Tbuild; 62with Uintp; use Uintp; 63with Validsw; use Validsw; 64 65package body Exp_Ch5 is 66 67 procedure Build_Formal_Container_Iteration 68 (N : Node_Id; 69 Container : Entity_Id; 70 Cursor : Entity_Id; 71 Init : out Node_Id; 72 Advance : out Node_Id; 73 New_Loop : out Node_Id); 74 -- Utility to create declarations and loop statement for both forms 75 -- of formal container iterators. 76 77 function Convert_To_Iterable_Type 78 (Container : Entity_Id; 79 Loc : Source_Ptr) return Node_Id; 80 -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor 81 -- type, if the type of Container inherited the Iterable aspect from that 82 -- ancestor. 83 84 function Change_Of_Representation (N : Node_Id) return Boolean; 85 -- Determine if the right-hand side of assignment N is a type conversion 86 -- which requires a change of representation. Called only for the array 87 -- and record cases. 88 89 procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id); 90 -- N is an assignment which assigns an array value. This routine process 91 -- the various special cases and checks required for such assignments, 92 -- including change of representation. Rhs is normally simply the right- 93 -- hand side of the assignment, except that if the right-hand side is a 94 -- type conversion or a qualified expression, then the RHS is the actual 95 -- expression inside any such type conversions or qualifications. 96 97 function Expand_Assign_Array_Loop 98 (N : Node_Id; 99 Larray : Entity_Id; 100 Rarray : Entity_Id; 101 L_Type : Entity_Id; 102 R_Type : Entity_Id; 103 Ndim : Pos; 104 Rev : Boolean) return Node_Id; 105 -- N is an assignment statement which assigns an array value. This routine 106 -- expands the assignment into a loop (or nested loops for the case of a 107 -- multi-dimensional array) to do the assignment component by component. 108 -- Larray and Rarray are the entities of the actual arrays on the left-hand 109 -- and right-hand sides. L_Type and R_Type are the types of these arrays 110 -- (which may not be the same, due to either sliding, or to a change of 111 -- representation case). Ndim is the number of dimensions and the parameter 112 -- Rev indicates if the loops run normally (Rev = False), or reversed 113 -- (Rev = True). The value returned is the constructed loop statement. 114 -- Auxiliary declarations are inserted before node N using the standard 115 -- Insert_Actions mechanism. 116 117 procedure Expand_Assign_Record (N : Node_Id); 118 -- N is an assignment of an untagged record value. This routine handles 119 -- the case where the assignment must be made component by component, 120 -- either because the target is not byte aligned, or there is a change 121 -- of representation, or when we have a tagged type with a representation 122 -- clause (this last case is required because holes in the tagged type 123 -- might be filled with components from child types). 124 125 procedure Expand_Assign_With_Target_Names (N : Node_Id); 126 -- (AI12-0125): N is an assignment statement whose RHS contains occurrences 127 -- of @ that designate the value of the LHS of the assignment. If the LHS 128 -- is side-effect free the target names can be replaced with a copy of the 129 -- LHS; otherwise the semantics of the assignment is described in terms of 130 -- a procedure with an in-out parameter, and expanded as such. 131 132 procedure Expand_Formal_Container_Loop (N : Node_Id); 133 -- Use the primitives specified in an Iterable aspect to expand a loop 134 -- over a so-called formal container, primarily for SPARK usage. 135 136 procedure Expand_Formal_Container_Element_Loop (N : Node_Id); 137 -- Same, for an iterator of the form " For E of C". In this case the 138 -- iterator provides the name of the element, and the cursor is generated 139 -- internally. 140 141 procedure Expand_Iterator_Loop (N : Node_Id); 142 -- Expand loop over arrays and containers that uses the form "for X of C" 143 -- with an optional subtype mark, or "for Y in C". 144 145 procedure Expand_Iterator_Loop_Over_Container 146 (N : Node_Id; 147 Isc : Node_Id; 148 I_Spec : Node_Id; 149 Container : Node_Id; 150 Container_Typ : Entity_Id); 151 -- Expand loop over containers that uses the form "for X of C" with an 152 -- optional subtype mark, or "for Y in C". Isc is the iteration scheme. 153 -- I_Spec is the iterator specification and Container is either the 154 -- Container (for OF) or the iterator (for IN). 155 156 procedure Expand_Predicated_Loop (N : Node_Id); 157 -- Expand for loop over predicated subtype 158 159 function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; 160 -- Generate the necessary code for controlled and tagged assignment, that 161 -- is to say, finalization of the target before, adjustment of the target 162 -- after and save and restore of the tag and finalization pointers which 163 -- are not 'part of the value' and must not be changed upon assignment. N 164 -- is the original Assignment node. 165 166 -------------------------------------- 167 -- Build_Formal_Container_Iteration -- 168 -------------------------------------- 169 170 procedure Build_Formal_Container_Iteration 171 (N : Node_Id; 172 Container : Entity_Id; 173 Cursor : Entity_Id; 174 Init : out Node_Id; 175 Advance : out Node_Id; 176 New_Loop : out Node_Id) 177 is 178 Loc : constant Source_Ptr := Sloc (N); 179 Stats : constant List_Id := Statements (N); 180 Typ : constant Entity_Id := Base_Type (Etype (Container)); 181 182 Has_Element_Op : constant Entity_Id := 183 Get_Iterable_Type_Primitive (Typ, Name_Has_Element); 184 185 First_Op : Entity_Id; 186 Next_Op : Entity_Id; 187 188 begin 189 -- Use the proper set of primitives depending on the direction of 190 -- iteration. The legality of a reverse iteration has been checked 191 -- during analysis. 192 193 if Reverse_Present (Iterator_Specification (Iteration_Scheme (N))) then 194 First_Op := Get_Iterable_Type_Primitive (Typ, Name_Last); 195 Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Previous); 196 197 else 198 First_Op := Get_Iterable_Type_Primitive (Typ, Name_First); 199 Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Next); 200 end if; 201 202 -- Declaration for Cursor 203 204 Init := 205 Make_Object_Declaration (Loc, 206 Defining_Identifier => Cursor, 207 Object_Definition => New_Occurrence_Of (Etype (First_Op), Loc), 208 Expression => 209 Make_Function_Call (Loc, 210 Name => New_Occurrence_Of (First_Op, Loc), 211 Parameter_Associations => New_List ( 212 Convert_To_Iterable_Type (Container, Loc)))); 213 214 -- Statement that advances (in the right direction) cursor in loop 215 216 Advance := 217 Make_Assignment_Statement (Loc, 218 Name => New_Occurrence_Of (Cursor, Loc), 219 Expression => 220 Make_Function_Call (Loc, 221 Name => New_Occurrence_Of (Next_Op, Loc), 222 Parameter_Associations => New_List ( 223 Convert_To_Iterable_Type (Container, Loc), 224 New_Occurrence_Of (Cursor, Loc)))); 225 226 -- Iterator is rewritten as a while_loop 227 228 New_Loop := 229 Make_Loop_Statement (Loc, 230 Iteration_Scheme => 231 Make_Iteration_Scheme (Loc, 232 Condition => 233 Make_Function_Call (Loc, 234 Name => New_Occurrence_Of (Has_Element_Op, Loc), 235 Parameter_Associations => New_List ( 236 Convert_To_Iterable_Type (Container, Loc), 237 New_Occurrence_Of (Cursor, Loc)))), 238 Statements => Stats, 239 End_Label => Empty); 240 241 -- If the contruct has a specified loop name, preserve it in the new 242 -- loop, for possible use in exit statements. 243 244 if Present (Identifier (N)) 245 and then Comes_From_Source (Identifier (N)) 246 then 247 Set_Identifier (New_Loop, Identifier (N)); 248 end if; 249 end Build_Formal_Container_Iteration; 250 251 ------------------------------ 252 -- Change_Of_Representation -- 253 ------------------------------ 254 255 function Change_Of_Representation (N : Node_Id) return Boolean is 256 Rhs : constant Node_Id := Expression (N); 257 begin 258 return 259 Nkind (Rhs) = N_Type_Conversion 260 and then 261 not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); 262 end Change_Of_Representation; 263 264 ------------------------------ 265 -- Convert_To_Iterable_Type -- 266 ------------------------------ 267 268 function Convert_To_Iterable_Type 269 (Container : Entity_Id; 270 Loc : Source_Ptr) return Node_Id 271 is 272 Typ : constant Entity_Id := Base_Type (Etype (Container)); 273 Aspect : constant Node_Id := Find_Aspect (Typ, Aspect_Iterable); 274 Result : Node_Id; 275 276 begin 277 Result := New_Occurrence_Of (Container, Loc); 278 279 if Entity (Aspect) /= Typ then 280 Result := 281 Make_Type_Conversion (Loc, 282 Subtype_Mark => New_Occurrence_Of (Entity (Aspect), Loc), 283 Expression => Result); 284 end if; 285 286 return Result; 287 end Convert_To_Iterable_Type; 288 289 ------------------------- 290 -- Expand_Assign_Array -- 291 ------------------------- 292 293 -- There are two issues here. First, do we let Gigi do a block move, or 294 -- do we expand out into a loop? Second, we need to set the two flags 295 -- Forwards_OK and Backwards_OK which show whether the block move (or 296 -- corresponding loops) can be legitimately done in a forwards (low to 297 -- high) or backwards (high to low) manner. 298 299 procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is 300 Loc : constant Source_Ptr := Sloc (N); 301 302 Lhs : constant Node_Id := Name (N); 303 304 Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs); 305 Act_Rhs : Node_Id := Get_Referenced_Object (Rhs); 306 307 L_Type : constant Entity_Id := 308 Underlying_Type (Get_Actual_Subtype (Act_Lhs)); 309 R_Type : Entity_Id := 310 Underlying_Type (Get_Actual_Subtype (Act_Rhs)); 311 312 L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice; 313 R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice; 314 315 Crep : constant Boolean := Change_Of_Representation (N); 316 317 Larray : Node_Id; 318 Rarray : Node_Id; 319 320 Ndim : constant Pos := Number_Dimensions (L_Type); 321 322 Loop_Required : Boolean := False; 323 -- This switch is set to True if the array move must be done using 324 -- an explicit front end generated loop. 325 326 procedure Apply_Dereference (Arg : Node_Id); 327 -- If the argument is an access to an array, and the assignment is 328 -- converted into a procedure call, apply explicit dereference. 329 330 function Has_Address_Clause (Exp : Node_Id) return Boolean; 331 -- Test if Exp is a reference to an array whose declaration has 332 -- an address clause, or it is a slice of such an array. 333 334 function Is_Formal_Array (Exp : Node_Id) return Boolean; 335 -- Test if Exp is a reference to an array which is either a formal 336 -- parameter or a slice of a formal parameter. These are the cases 337 -- where hidden aliasing can occur. 338 339 function Is_Non_Local_Array (Exp : Node_Id) return Boolean; 340 -- Determine if Exp is a reference to an array variable which is other 341 -- than an object defined in the current scope, or a component or a 342 -- slice of such an object. Such objects can be aliased to parameters 343 -- (unlike local array references). 344 345 ----------------------- 346 -- Apply_Dereference -- 347 ----------------------- 348 349 procedure Apply_Dereference (Arg : Node_Id) is 350 Typ : constant Entity_Id := Etype (Arg); 351 begin 352 if Is_Access_Type (Typ) then 353 Rewrite (Arg, Make_Explicit_Dereference (Loc, 354 Prefix => Relocate_Node (Arg))); 355 Analyze_And_Resolve (Arg, Designated_Type (Typ)); 356 end if; 357 end Apply_Dereference; 358 359 ------------------------ 360 -- Has_Address_Clause -- 361 ------------------------ 362 363 function Has_Address_Clause (Exp : Node_Id) return Boolean is 364 begin 365 return 366 (Is_Entity_Name (Exp) and then 367 Present (Address_Clause (Entity (Exp)))) 368 or else 369 (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp))); 370 end Has_Address_Clause; 371 372 --------------------- 373 -- Is_Formal_Array -- 374 --------------------- 375 376 function Is_Formal_Array (Exp : Node_Id) return Boolean is 377 begin 378 return 379 (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp))) 380 or else 381 (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp))); 382 end Is_Formal_Array; 383 384 ------------------------ 385 -- Is_Non_Local_Array -- 386 ------------------------ 387 388 function Is_Non_Local_Array (Exp : Node_Id) return Boolean is 389 begin 390 case Nkind (Exp) is 391 when N_Indexed_Component 392 | N_Selected_Component 393 | N_Slice 394 => 395 return Is_Non_Local_Array (Prefix (Exp)); 396 397 when others => 398 return 399 not (Is_Entity_Name (Exp) 400 and then Scope (Entity (Exp)) = Current_Scope); 401 end case; 402 end Is_Non_Local_Array; 403 404 -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays 405 406 Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs); 407 Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs); 408 409 Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs); 410 Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs); 411 412 -- Start of processing for Expand_Assign_Array 413 414 begin 415 -- Deal with length check. Note that the length check is done with 416 -- respect to the right-hand side as given, not a possible underlying 417 -- renamed object, since this would generate incorrect extra checks. 418 419 Apply_Length_Check (Rhs, L_Type); 420 421 -- We start by assuming that the move can be done in either direction, 422 -- i.e. that the two sides are completely disjoint. 423 424 Set_Forwards_OK (N, True); 425 Set_Backwards_OK (N, True); 426 427 -- Normally it is only the slice case that can lead to overlap, and 428 -- explicit checks for slices are made below. But there is one case 429 -- where the slice can be implicit and invisible to us: when we have a 430 -- one dimensional array, and either both operands are parameters, or 431 -- one is a parameter (which can be a slice passed by reference) and the 432 -- other is a non-local variable. In this case the parameter could be a 433 -- slice that overlaps with the other operand. 434 435 -- However, if the array subtype is a constrained first subtype in the 436 -- parameter case, then we don't have to worry about overlap, since 437 -- slice assignments aren't possible (other than for a slice denoting 438 -- the whole array). 439 440 -- Note: No overlap is possible if there is a change of representation, 441 -- so we can exclude this case. 442 443 if Ndim = 1 444 and then not Crep 445 and then 446 ((Lhs_Formal and Rhs_Formal) 447 or else 448 (Lhs_Formal and Rhs_Non_Local_Var) 449 or else 450 (Rhs_Formal and Lhs_Non_Local_Var)) 451 and then 452 (not Is_Constrained (Etype (Lhs)) 453 or else not Is_First_Subtype (Etype (Lhs))) 454 then 455 Set_Forwards_OK (N, False); 456 Set_Backwards_OK (N, False); 457 458 -- Note: the bit-packed case is not worrisome here, since if we have 459 -- a slice passed as a parameter, it is always aligned on a byte 460 -- boundary, and if there are no explicit slices, the assignment 461 -- can be performed directly. 462 end if; 463 464 -- If either operand has an address clause clear Backwards_OK and 465 -- Forwards_OK, since we cannot tell if the operands overlap. We 466 -- exclude this treatment when Rhs is an aggregate, since we know 467 -- that overlap can't occur. 468 469 if (Has_Address_Clause (Lhs) and then Nkind (Rhs) /= N_Aggregate) 470 or else Has_Address_Clause (Rhs) 471 then 472 Set_Forwards_OK (N, False); 473 Set_Backwards_OK (N, False); 474 end if; 475 476 -- We certainly must use a loop for change of representation and also 477 -- we use the operand of the conversion on the right-hand side as the 478 -- effective right-hand side (the component types must match in this 479 -- situation). 480 481 if Crep then 482 Act_Rhs := Get_Referenced_Object (Rhs); 483 R_Type := Get_Actual_Subtype (Act_Rhs); 484 Loop_Required := True; 485 486 -- We require a loop if the left side is possibly bit unaligned 487 488 elsif Possible_Bit_Aligned_Component (Lhs) 489 or else 490 Possible_Bit_Aligned_Component (Rhs) 491 then 492 Loop_Required := True; 493 494 -- Arrays with controlled components are expanded into a loop to force 495 -- calls to Adjust at the component level. 496 497 elsif Has_Controlled_Component (L_Type) then 498 Loop_Required := True; 499 500 -- If object is atomic/VFA, we cannot tolerate a loop 501 502 elsif Is_Atomic_Or_VFA_Object (Act_Lhs) 503 or else 504 Is_Atomic_Or_VFA_Object (Act_Rhs) 505 then 506 return; 507 508 -- Loop is required if we have atomic components since we have to 509 -- be sure to do any accesses on an element by element basis. 510 511 elsif Has_Atomic_Components (L_Type) 512 or else Has_Atomic_Components (R_Type) 513 or else Is_Atomic_Or_VFA (Component_Type (L_Type)) 514 or else Is_Atomic_Or_VFA (Component_Type (R_Type)) 515 then 516 Loop_Required := True; 517 518 -- Case where no slice is involved 519 520 elsif not L_Slice and not R_Slice then 521 522 -- The following code deals with the case of unconstrained bit packed 523 -- arrays. The problem is that the template for such arrays contains 524 -- the bounds of the actual source level array, but the copy of an 525 -- entire array requires the bounds of the underlying array. It would 526 -- be nice if the back end could take care of this, but right now it 527 -- does not know how, so if we have such a type, then we expand out 528 -- into a loop, which is inefficient but works correctly. If we don't 529 -- do this, we get the wrong length computed for the array to be 530 -- moved. The two cases we need to worry about are: 531 532 -- Explicit dereference of an unconstrained packed array type as in 533 -- the following example: 534 535 -- procedure C52 is 536 -- type BITS is array(INTEGER range <>) of BOOLEAN; 537 -- pragma PACK(BITS); 538 -- type A is access BITS; 539 -- P1,P2 : A; 540 -- begin 541 -- P1 := new BITS (1 .. 65_535); 542 -- P2 := new BITS (1 .. 65_535); 543 -- P2.ALL := P1.ALL; 544 -- end C52; 545 546 -- A formal parameter reference with an unconstrained bit array type 547 -- is the other case we need to worry about (here we assume the same 548 -- BITS type declared above): 549 550 -- procedure Write_All (File : out BITS; Contents : BITS); 551 -- begin 552 -- File.Storage := Contents; 553 -- end Write_All; 554 555 -- We expand to a loop in either of these two cases 556 557 -- Question for future thought. Another potentially more efficient 558 -- approach would be to create the actual subtype, and then do an 559 -- unchecked conversion to this actual subtype ??? 560 561 Check_Unconstrained_Bit_Packed_Array : declare 562 563 function Is_UBPA_Reference (Opnd : Node_Id) return Boolean; 564 -- Function to perform required test for the first case, above 565 -- (dereference of an unconstrained bit packed array). 566 567 ----------------------- 568 -- Is_UBPA_Reference -- 569 ----------------------- 570 571 function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is 572 Typ : constant Entity_Id := Underlying_Type (Etype (Opnd)); 573 P_Type : Entity_Id; 574 Des_Type : Entity_Id; 575 576 begin 577 if Present (Packed_Array_Impl_Type (Typ)) 578 and then Is_Array_Type (Packed_Array_Impl_Type (Typ)) 579 and then not Is_Constrained (Packed_Array_Impl_Type (Typ)) 580 then 581 return True; 582 583 elsif Nkind (Opnd) = N_Explicit_Dereference then 584 P_Type := Underlying_Type (Etype (Prefix (Opnd))); 585 586 if not Is_Access_Type (P_Type) then 587 return False; 588 589 else 590 Des_Type := Designated_Type (P_Type); 591 return 592 Is_Bit_Packed_Array (Des_Type) 593 and then not Is_Constrained (Des_Type); 594 end if; 595 596 else 597 return False; 598 end if; 599 end Is_UBPA_Reference; 600 601 -- Start of processing for Check_Unconstrained_Bit_Packed_Array 602 603 begin 604 if Is_UBPA_Reference (Lhs) 605 or else 606 Is_UBPA_Reference (Rhs) 607 then 608 Loop_Required := True; 609 610 -- Here if we do not have the case of a reference to a bit packed 611 -- unconstrained array case. In this case gigi can most certainly 612 -- handle the assignment if a forwards move is allowed. 613 614 -- (could it handle the backwards case also???) 615 616 elsif Forwards_OK (N) then 617 return; 618 end if; 619 end Check_Unconstrained_Bit_Packed_Array; 620 621 -- The back end can always handle the assignment if the right side is a 622 -- string literal (note that overlap is definitely impossible in this 623 -- case). If the type is packed, a string literal is always converted 624 -- into an aggregate, except in the case of a null slice, for which no 625 -- aggregate can be written. In that case, rewrite the assignment as a 626 -- null statement, a length check has already been emitted to verify 627 -- that the range of the left-hand side is empty. 628 629 -- Note that this code is not executed if we have an assignment of a 630 -- string literal to a non-bit aligned component of a record, a case 631 -- which cannot be handled by the backend. 632 633 elsif Nkind (Rhs) = N_String_Literal then 634 if String_Length (Strval (Rhs)) = 0 635 and then Is_Bit_Packed_Array (L_Type) 636 then 637 Rewrite (N, Make_Null_Statement (Loc)); 638 Analyze (N); 639 end if; 640 641 return; 642 643 -- If either operand is bit packed, then we need a loop, since we can't 644 -- be sure that the slice is byte aligned. Similarly, if either operand 645 -- is a possibly unaligned slice, then we need a loop (since the back 646 -- end cannot handle unaligned slices). 647 648 elsif Is_Bit_Packed_Array (L_Type) 649 or else Is_Bit_Packed_Array (R_Type) 650 or else Is_Possibly_Unaligned_Slice (Lhs) 651 or else Is_Possibly_Unaligned_Slice (Rhs) 652 then 653 Loop_Required := True; 654 655 -- If we are not bit-packed, and we have only one slice, then no overlap 656 -- is possible except in the parameter case, so we can let the back end 657 -- handle things. 658 659 elsif not (L_Slice and R_Slice) then 660 if Forwards_OK (N) then 661 return; 662 end if; 663 end if; 664 665 -- If the right-hand side is a string literal, introduce a temporary for 666 -- it, for use in the generated loop that will follow. 667 668 if Nkind (Rhs) = N_String_Literal then 669 declare 670 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs); 671 Decl : Node_Id; 672 673 begin 674 Decl := 675 Make_Object_Declaration (Loc, 676 Defining_Identifier => Temp, 677 Object_Definition => New_Occurrence_Of (L_Type, Loc), 678 Expression => Relocate_Node (Rhs)); 679 680 Insert_Action (N, Decl); 681 Rewrite (Rhs, New_Occurrence_Of (Temp, Loc)); 682 R_Type := Etype (Temp); 683 end; 684 end if; 685 686 -- Come here to complete the analysis 687 688 -- Loop_Required: Set to True if we know that a loop is required 689 -- regardless of overlap considerations. 690 691 -- Forwards_OK: Set to False if we already know that a forwards 692 -- move is not safe, else set to True. 693 694 -- Backwards_OK: Set to False if we already know that a backwards 695 -- move is not safe, else set to True 696 697 -- Our task at this stage is to complete the overlap analysis, which can 698 -- result in possibly setting Forwards_OK or Backwards_OK to False, and 699 -- then generating the final code, either by deciding that it is OK 700 -- after all to let Gigi handle it, or by generating appropriate code 701 -- in the front end. 702 703 declare 704 L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); 705 R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); 706 707 Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); 708 Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); 709 Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); 710 Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ); 711 712 Act_L_Array : Node_Id; 713 Act_R_Array : Node_Id; 714 715 Cleft_Lo : Node_Id; 716 Cright_Lo : Node_Id; 717 Condition : Node_Id; 718 719 Cresult : Compare_Result; 720 721 begin 722 -- Get the expressions for the arrays. If we are dealing with a 723 -- private type, then convert to the underlying type. We can do 724 -- direct assignments to an array that is a private type, but we 725 -- cannot assign to elements of the array without this extra 726 -- unchecked conversion. 727 728 -- Note: We propagate Parent to the conversion nodes to generate 729 -- a well-formed subtree. 730 731 if Nkind (Act_Lhs) = N_Slice then 732 Larray := Prefix (Act_Lhs); 733 else 734 Larray := Act_Lhs; 735 736 if Is_Private_Type (Etype (Larray)) then 737 declare 738 Par : constant Node_Id := Parent (Larray); 739 begin 740 Larray := 741 Unchecked_Convert_To 742 (Underlying_Type (Etype (Larray)), Larray); 743 Set_Parent (Larray, Par); 744 end; 745 end if; 746 end if; 747 748 if Nkind (Act_Rhs) = N_Slice then 749 Rarray := Prefix (Act_Rhs); 750 else 751 Rarray := Act_Rhs; 752 753 if Is_Private_Type (Etype (Rarray)) then 754 declare 755 Par : constant Node_Id := Parent (Rarray); 756 begin 757 Rarray := 758 Unchecked_Convert_To 759 (Underlying_Type (Etype (Rarray)), Rarray); 760 Set_Parent (Rarray, Par); 761 end; 762 end if; 763 end if; 764 765 -- If both sides are slices, we must figure out whether it is safe 766 -- to do the move in one direction or the other. It is always safe 767 -- if there is a change of representation since obviously two arrays 768 -- with different representations cannot possibly overlap. 769 770 if (not Crep) and L_Slice and R_Slice then 771 Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs)); 772 Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs)); 773 774 -- If both left- and right-hand arrays are entity names, and refer 775 -- to different entities, then we know that the move is safe (the 776 -- two storage areas are completely disjoint). 777 778 if Is_Entity_Name (Act_L_Array) 779 and then Is_Entity_Name (Act_R_Array) 780 and then Entity (Act_L_Array) /= Entity (Act_R_Array) 781 then 782 null; 783 784 -- Otherwise, we assume the worst, which is that the two arrays 785 -- are the same array. There is no need to check if we know that 786 -- is the case, because if we don't know it, we still have to 787 -- assume it. 788 789 -- Generally if the same array is involved, then we have an 790 -- overlapping case. We will have to really assume the worst (i.e. 791 -- set neither of the OK flags) unless we can determine the lower 792 -- or upper bounds at compile time and compare them. 793 794 else 795 Cresult := 796 Compile_Time_Compare 797 (Left_Lo, Right_Lo, Assume_Valid => True); 798 799 if Cresult = Unknown then 800 Cresult := 801 Compile_Time_Compare 802 (Left_Hi, Right_Hi, Assume_Valid => True); 803 end if; 804 805 case Cresult is 806 when EQ | LE | LT => 807 Set_Backwards_OK (N, False); 808 809 when GE | GT => 810 Set_Forwards_OK (N, False); 811 812 when NE | Unknown => 813 Set_Backwards_OK (N, False); 814 Set_Forwards_OK (N, False); 815 end case; 816 end if; 817 end if; 818 819 -- If after that analysis Loop_Required is False, meaning that we 820 -- have not discovered some non-overlap reason for requiring a loop, 821 -- then the outcome depends on the capabilities of the back end. 822 823 if not Loop_Required then 824 -- Assume the back end can deal with all cases of overlap by 825 -- falling back to memmove if it cannot use a more efficient 826 -- approach. 827 828 return; 829 end if; 830 831 -- At this stage we have to generate an explicit loop, and we have 832 -- the following cases: 833 834 -- Forwards_OK = True 835 836 -- Rnn : right_index := right_index'First; 837 -- for Lnn in left-index loop 838 -- left (Lnn) := right (Rnn); 839 -- Rnn := right_index'Succ (Rnn); 840 -- end loop; 841 842 -- Note: the above code MUST be analyzed with checks off, because 843 -- otherwise the Succ could overflow. But in any case this is more 844 -- efficient. 845 846 -- Forwards_OK = False, Backwards_OK = True 847 848 -- Rnn : right_index := right_index'Last; 849 -- for Lnn in reverse left-index loop 850 -- left (Lnn) := right (Rnn); 851 -- Rnn := right_index'Pred (Rnn); 852 -- end loop; 853 854 -- Note: the above code MUST be analyzed with checks off, because 855 -- otherwise the Pred could overflow. But in any case this is more 856 -- efficient. 857 858 -- Forwards_OK = Backwards_OK = False 859 860 -- This only happens if we have the same array on each side. It is 861 -- possible to create situations using overlays that violate this, 862 -- but we simply do not promise to get this "right" in this case. 863 864 -- There are two possible subcases. If the No_Implicit_Conditionals 865 -- restriction is set, then we generate the following code: 866 867 -- declare 868 -- T : constant <operand-type> := rhs; 869 -- begin 870 -- lhs := T; 871 -- end; 872 873 -- If implicit conditionals are permitted, then we generate: 874 875 -- if Left_Lo <= Right_Lo then 876 -- <code for Forwards_OK = True above> 877 -- else 878 -- <code for Backwards_OK = True above> 879 -- end if; 880 881 -- In order to detect possible aliasing, we examine the renamed 882 -- expression when the source or target is a renaming. However, 883 -- the renaming may be intended to capture an address that may be 884 -- affected by subsequent code, and therefore we must recover 885 -- the actual entity for the expansion that follows, not the 886 -- object it renames. In particular, if source or target designate 887 -- a portion of a dynamically allocated object, the pointer to it 888 -- may be reassigned but the renaming preserves the proper location. 889 890 if Is_Entity_Name (Rhs) 891 and then 892 Nkind (Parent (Entity (Rhs))) = N_Object_Renaming_Declaration 893 and then Nkind (Act_Rhs) = N_Slice 894 then 895 Rarray := Rhs; 896 end if; 897 898 if Is_Entity_Name (Lhs) 899 and then 900 Nkind (Parent (Entity (Lhs))) = N_Object_Renaming_Declaration 901 and then Nkind (Act_Lhs) = N_Slice 902 then 903 Larray := Lhs; 904 end if; 905 906 -- Cases where either Forwards_OK or Backwards_OK is true 907 908 if Forwards_OK (N) or else Backwards_OK (N) then 909 if Needs_Finalization (Component_Type (L_Type)) 910 and then Base_Type (L_Type) = Base_Type (R_Type) 911 and then Ndim = 1 912 and then not No_Ctrl_Actions (N) 913 then 914 declare 915 Proc : constant Entity_Id := 916 TSS (Base_Type (L_Type), TSS_Slice_Assign); 917 Actuals : List_Id; 918 919 begin 920 Apply_Dereference (Larray); 921 Apply_Dereference (Rarray); 922 Actuals := New_List ( 923 Duplicate_Subexpr (Larray, Name_Req => True), 924 Duplicate_Subexpr (Rarray, Name_Req => True), 925 Duplicate_Subexpr (Left_Lo, Name_Req => True), 926 Duplicate_Subexpr (Left_Hi, Name_Req => True), 927 Duplicate_Subexpr (Right_Lo, Name_Req => True), 928 Duplicate_Subexpr (Right_Hi, Name_Req => True)); 929 930 Append_To (Actuals, 931 New_Occurrence_Of ( 932 Boolean_Literals (not Forwards_OK (N)), Loc)); 933 934 Rewrite (N, 935 Make_Procedure_Call_Statement (Loc, 936 Name => New_Occurrence_Of (Proc, Loc), 937 Parameter_Associations => Actuals)); 938 end; 939 940 else 941 Rewrite (N, 942 Expand_Assign_Array_Loop 943 (N, Larray, Rarray, L_Type, R_Type, Ndim, 944 Rev => not Forwards_OK (N))); 945 end if; 946 947 -- Case of both are false with No_Implicit_Conditionals 948 949 elsif Restriction_Active (No_Implicit_Conditionals) then 950 declare 951 T : constant Entity_Id := 952 Make_Defining_Identifier (Loc, Chars => Name_T); 953 954 begin 955 Rewrite (N, 956 Make_Block_Statement (Loc, 957 Declarations => New_List ( 958 Make_Object_Declaration (Loc, 959 Defining_Identifier => T, 960 Constant_Present => True, 961 Object_Definition => 962 New_Occurrence_Of (Etype (Rhs), Loc), 963 Expression => Relocate_Node (Rhs))), 964 965 Handled_Statement_Sequence => 966 Make_Handled_Sequence_Of_Statements (Loc, 967 Statements => New_List ( 968 Make_Assignment_Statement (Loc, 969 Name => Relocate_Node (Lhs), 970 Expression => New_Occurrence_Of (T, Loc)))))); 971 end; 972 973 -- Case of both are false with implicit conditionals allowed 974 975 else 976 -- Before we generate this code, we must ensure that the left and 977 -- right side array types are defined. They may be itypes, and we 978 -- cannot let them be defined inside the if, since the first use 979 -- in the then may not be executed. 980 981 Ensure_Defined (L_Type, N); 982 Ensure_Defined (R_Type, N); 983 984 -- We normally compare addresses to find out which way round to 985 -- do the loop, since this is reliable, and handles the cases of 986 -- parameters, conversions etc. But we can't do that in the bit 987 -- packed case, because addresses don't work there. 988 989 if not Is_Bit_Packed_Array (L_Type) then 990 Condition := 991 Make_Op_Le (Loc, 992 Left_Opnd => 993 Unchecked_Convert_To (RTE (RE_Integer_Address), 994 Make_Attribute_Reference (Loc, 995 Prefix => 996 Make_Indexed_Component (Loc, 997 Prefix => 998 Duplicate_Subexpr_Move_Checks (Larray, True), 999 Expressions => New_List ( 1000 Make_Attribute_Reference (Loc, 1001 Prefix => 1002 New_Occurrence_Of 1003 (L_Index_Typ, Loc), 1004 Attribute_Name => Name_First))), 1005 Attribute_Name => Name_Address)), 1006 1007 Right_Opnd => 1008 Unchecked_Convert_To (RTE (RE_Integer_Address), 1009 Make_Attribute_Reference (Loc, 1010 Prefix => 1011 Make_Indexed_Component (Loc, 1012 Prefix => 1013 Duplicate_Subexpr_Move_Checks (Rarray, True), 1014 Expressions => New_List ( 1015 Make_Attribute_Reference (Loc, 1016 Prefix => 1017 New_Occurrence_Of 1018 (R_Index_Typ, Loc), 1019 Attribute_Name => Name_First))), 1020 Attribute_Name => Name_Address))); 1021 1022 -- For the bit packed and VM cases we use the bounds. That's OK, 1023 -- because we don't have to worry about parameters, since they 1024 -- cannot cause overlap. Perhaps we should worry about weird slice 1025 -- conversions ??? 1026 1027 else 1028 -- Copy the bounds 1029 1030 Cleft_Lo := New_Copy_Tree (Left_Lo); 1031 Cright_Lo := New_Copy_Tree (Right_Lo); 1032 1033 -- If the types do not match we add an implicit conversion 1034 -- here to ensure proper match 1035 1036 if Etype (Left_Lo) /= Etype (Right_Lo) then 1037 Cright_Lo := 1038 Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo); 1039 end if; 1040 1041 -- Reset the Analyzed flag, because the bounds of the index 1042 -- type itself may be universal, and must must be reanalyzed 1043 -- to acquire the proper type for the back end. 1044 1045 Set_Analyzed (Cleft_Lo, False); 1046 Set_Analyzed (Cright_Lo, False); 1047 1048 Condition := 1049 Make_Op_Le (Loc, 1050 Left_Opnd => Cleft_Lo, 1051 Right_Opnd => Cright_Lo); 1052 end if; 1053 1054 if Needs_Finalization (Component_Type (L_Type)) 1055 and then Base_Type (L_Type) = Base_Type (R_Type) 1056 and then Ndim = 1 1057 and then not No_Ctrl_Actions (N) 1058 then 1059 1060 -- Call TSS procedure for array assignment, passing the 1061 -- explicit bounds of right- and left-hand sides. 1062 1063 declare 1064 Proc : constant Entity_Id := 1065 TSS (Base_Type (L_Type), TSS_Slice_Assign); 1066 Actuals : List_Id; 1067 1068 begin 1069 Apply_Dereference (Larray); 1070 Apply_Dereference (Rarray); 1071 Actuals := New_List ( 1072 Duplicate_Subexpr (Larray, Name_Req => True), 1073 Duplicate_Subexpr (Rarray, Name_Req => True), 1074 Duplicate_Subexpr (Left_Lo, Name_Req => True), 1075 Duplicate_Subexpr (Left_Hi, Name_Req => True), 1076 Duplicate_Subexpr (Right_Lo, Name_Req => True), 1077 Duplicate_Subexpr (Right_Hi, Name_Req => True)); 1078 1079 Append_To (Actuals, 1080 Make_Op_Not (Loc, 1081 Right_Opnd => Condition)); 1082 1083 Rewrite (N, 1084 Make_Procedure_Call_Statement (Loc, 1085 Name => New_Occurrence_Of (Proc, Loc), 1086 Parameter_Associations => Actuals)); 1087 end; 1088 1089 else 1090 Rewrite (N, 1091 Make_Implicit_If_Statement (N, 1092 Condition => Condition, 1093 1094 Then_Statements => New_List ( 1095 Expand_Assign_Array_Loop 1096 (N, Larray, Rarray, L_Type, R_Type, Ndim, 1097 Rev => False)), 1098 1099 Else_Statements => New_List ( 1100 Expand_Assign_Array_Loop 1101 (N, Larray, Rarray, L_Type, R_Type, Ndim, 1102 Rev => True)))); 1103 end if; 1104 end if; 1105 1106 Analyze (N, Suppress => All_Checks); 1107 end; 1108 1109 exception 1110 when RE_Not_Available => 1111 return; 1112 end Expand_Assign_Array; 1113 1114 ------------------------------ 1115 -- Expand_Assign_Array_Loop -- 1116 ------------------------------ 1117 1118 -- The following is an example of the loop generated for the case of a 1119 -- two-dimensional array: 1120 1121 -- declare 1122 -- R2b : Tm1X1 := 1; 1123 -- begin 1124 -- for L1b in 1 .. 100 loop 1125 -- declare 1126 -- R4b : Tm1X2 := 1; 1127 -- begin 1128 -- for L3b in 1 .. 100 loop 1129 -- vm1 (L1b, L3b) := vm2 (R2b, R4b); 1130 -- R4b := Tm1X2'succ(R4b); 1131 -- end loop; 1132 -- end; 1133 -- R2b := Tm1X1'succ(R2b); 1134 -- end loop; 1135 -- end; 1136 1137 -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand 1138 -- side. The declarations of R2b and R4b are inserted before the original 1139 -- assignment statement. 1140 1141 function Expand_Assign_Array_Loop 1142 (N : Node_Id; 1143 Larray : Entity_Id; 1144 Rarray : Entity_Id; 1145 L_Type : Entity_Id; 1146 R_Type : Entity_Id; 1147 Ndim : Pos; 1148 Rev : Boolean) return Node_Id 1149 is 1150 Loc : constant Source_Ptr := Sloc (N); 1151 1152 Lnn : array (1 .. Ndim) of Entity_Id; 1153 Rnn : array (1 .. Ndim) of Entity_Id; 1154 -- Entities used as subscripts on left and right sides 1155 1156 L_Index_Type : array (1 .. Ndim) of Entity_Id; 1157 R_Index_Type : array (1 .. Ndim) of Entity_Id; 1158 -- Left and right index types 1159 1160 Assign : Node_Id; 1161 1162 F_Or_L : Name_Id; 1163 S_Or_P : Name_Id; 1164 1165 function Build_Step (J : Nat) return Node_Id; 1166 -- The increment step for the index of the right-hand side is written 1167 -- as an attribute reference (Succ or Pred). This function returns 1168 -- the corresponding node, which is placed at the end of the loop body. 1169 1170 ---------------- 1171 -- Build_Step -- 1172 ---------------- 1173 1174 function Build_Step (J : Nat) return Node_Id is 1175 Step : Node_Id; 1176 Lim : Name_Id; 1177 1178 begin 1179 if Rev then 1180 Lim := Name_First; 1181 else 1182 Lim := Name_Last; 1183 end if; 1184 1185 Step := 1186 Make_Assignment_Statement (Loc, 1187 Name => New_Occurrence_Of (Rnn (J), Loc), 1188 Expression => 1189 Make_Attribute_Reference (Loc, 1190 Prefix => 1191 New_Occurrence_Of (R_Index_Type (J), Loc), 1192 Attribute_Name => S_Or_P, 1193 Expressions => New_List ( 1194 New_Occurrence_Of (Rnn (J), Loc)))); 1195 1196 -- Note that on the last iteration of the loop, the index is increased 1197 -- (or decreased) past the corresponding bound. This is consistent with 1198 -- the C semantics of the back-end, where such an off-by-one value on a 1199 -- dead index variable is OK. However, in CodePeer mode this leads to 1200 -- spurious warnings, and thus we place a guard around the attribute 1201 -- reference. For obvious reasons we only do this for CodePeer. 1202 1203 if CodePeer_Mode then 1204 Step := 1205 Make_If_Statement (Loc, 1206 Condition => 1207 Make_Op_Ne (Loc, 1208 Left_Opnd => New_Occurrence_Of (Lnn (J), Loc), 1209 Right_Opnd => 1210 Make_Attribute_Reference (Loc, 1211 Prefix => New_Occurrence_Of (L_Index_Type (J), Loc), 1212 Attribute_Name => Lim)), 1213 Then_Statements => New_List (Step)); 1214 end if; 1215 1216 return Step; 1217 end Build_Step; 1218 1219 -- Start of processing for Expand_Assign_Array_Loop 1220 1221 begin 1222 if Rev then 1223 F_Or_L := Name_Last; 1224 S_Or_P := Name_Pred; 1225 else 1226 F_Or_L := Name_First; 1227 S_Or_P := Name_Succ; 1228 end if; 1229 1230 -- Setup index types and subscript entities 1231 1232 declare 1233 L_Index : Node_Id; 1234 R_Index : Node_Id; 1235 1236 begin 1237 L_Index := First_Index (L_Type); 1238 R_Index := First_Index (R_Type); 1239 1240 for J in 1 .. Ndim loop 1241 Lnn (J) := Make_Temporary (Loc, 'L'); 1242 Rnn (J) := Make_Temporary (Loc, 'R'); 1243 1244 L_Index_Type (J) := Etype (L_Index); 1245 R_Index_Type (J) := Etype (R_Index); 1246 1247 Next_Index (L_Index); 1248 Next_Index (R_Index); 1249 end loop; 1250 end; 1251 1252 -- Now construct the assignment statement 1253 1254 declare 1255 ExprL : constant List_Id := New_List; 1256 ExprR : constant List_Id := New_List; 1257 1258 begin 1259 for J in 1 .. Ndim loop 1260 Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc)); 1261 Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc)); 1262 end loop; 1263 1264 Assign := 1265 Make_Assignment_Statement (Loc, 1266 Name => 1267 Make_Indexed_Component (Loc, 1268 Prefix => Duplicate_Subexpr (Larray, Name_Req => True), 1269 Expressions => ExprL), 1270 Expression => 1271 Make_Indexed_Component (Loc, 1272 Prefix => Duplicate_Subexpr (Rarray, Name_Req => True), 1273 Expressions => ExprR)); 1274 1275 -- We set assignment OK, since there are some cases, e.g. in object 1276 -- declarations, where we are actually assigning into a constant. 1277 -- If there really is an illegality, it was caught long before now, 1278 -- and was flagged when the original assignment was analyzed. 1279 1280 Set_Assignment_OK (Name (Assign)); 1281 1282 -- Propagate the No_Ctrl_Actions flag to individual assignments 1283 1284 Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); 1285 end; 1286 1287 -- Now construct the loop from the inside out, with the last subscript 1288 -- varying most rapidly. Note that Assign is first the raw assignment 1289 -- statement, and then subsequently the loop that wraps it up. 1290 1291 for J in reverse 1 .. Ndim loop 1292 Assign := 1293 Make_Block_Statement (Loc, 1294 Declarations => New_List ( 1295 Make_Object_Declaration (Loc, 1296 Defining_Identifier => Rnn (J), 1297 Object_Definition => 1298 New_Occurrence_Of (R_Index_Type (J), Loc), 1299 Expression => 1300 Make_Attribute_Reference (Loc, 1301 Prefix => New_Occurrence_Of (R_Index_Type (J), Loc), 1302 Attribute_Name => F_Or_L))), 1303 1304 Handled_Statement_Sequence => 1305 Make_Handled_Sequence_Of_Statements (Loc, 1306 Statements => New_List ( 1307 Make_Implicit_Loop_Statement (N, 1308 Iteration_Scheme => 1309 Make_Iteration_Scheme (Loc, 1310 Loop_Parameter_Specification => 1311 Make_Loop_Parameter_Specification (Loc, 1312 Defining_Identifier => Lnn (J), 1313 Reverse_Present => Rev, 1314 Discrete_Subtype_Definition => 1315 New_Occurrence_Of (L_Index_Type (J), Loc))), 1316 1317 Statements => New_List (Assign, Build_Step (J)))))); 1318 end loop; 1319 1320 return Assign; 1321 end Expand_Assign_Array_Loop; 1322 1323 -------------------------- 1324 -- Expand_Assign_Record -- 1325 -------------------------- 1326 1327 procedure Expand_Assign_Record (N : Node_Id) is 1328 Lhs : constant Node_Id := Name (N); 1329 Rhs : Node_Id := Expression (N); 1330 L_Typ : constant Entity_Id := Base_Type (Etype (Lhs)); 1331 1332 begin 1333 -- If change of representation, then extract the real right-hand side 1334 -- from the type conversion, and proceed with component-wise assignment, 1335 -- since the two types are not the same as far as the back end is 1336 -- concerned. 1337 1338 if Change_Of_Representation (N) then 1339 Rhs := Expression (Rhs); 1340 1341 -- If this may be a case of a large bit aligned component, then proceed 1342 -- with component-wise assignment, to avoid possible clobbering of other 1343 -- components sharing bits in the first or last byte of the component to 1344 -- be assigned. 1345 1346 elsif Possible_Bit_Aligned_Component (Lhs) 1347 or 1348 Possible_Bit_Aligned_Component (Rhs) 1349 then 1350 null; 1351 1352 -- If we have a tagged type that has a complete record representation 1353 -- clause, we must do we must do component-wise assignments, since child 1354 -- types may have used gaps for their components, and we might be 1355 -- dealing with a view conversion. 1356 1357 elsif Is_Fully_Repped_Tagged_Type (L_Typ) then 1358 null; 1359 1360 -- If neither condition met, then nothing special to do, the back end 1361 -- can handle assignment of the entire component as a single entity. 1362 1363 else 1364 return; 1365 end if; 1366 1367 -- At this stage we know that we must do a component wise assignment 1368 1369 declare 1370 Loc : constant Source_Ptr := Sloc (N); 1371 R_Typ : constant Entity_Id := Base_Type (Etype (Rhs)); 1372 Decl : constant Node_Id := Declaration_Node (R_Typ); 1373 RDef : Node_Id; 1374 F : Entity_Id; 1375 1376 function Find_Component 1377 (Typ : Entity_Id; 1378 Comp : Entity_Id) return Entity_Id; 1379 -- Find the component with the given name in the underlying record 1380 -- declaration for Typ. We need to use the actual entity because the 1381 -- type may be private and resolution by identifier alone would fail. 1382 1383 function Make_Component_List_Assign 1384 (CL : Node_Id; 1385 U_U : Boolean := False) return List_Id; 1386 -- Returns a sequence of statements to assign the components that 1387 -- are referenced in the given component list. The flag U_U is 1388 -- used to force the usage of the inferred value of the variant 1389 -- part expression as the switch for the generated case statement. 1390 1391 function Make_Field_Assign 1392 (C : Entity_Id; 1393 U_U : Boolean := False) return Node_Id; 1394 -- Given C, the entity for a discriminant or component, build an 1395 -- assignment for the corresponding field values. The flag U_U 1396 -- signals the presence of an Unchecked_Union and forces the usage 1397 -- of the inferred discriminant value of C as the right-hand side 1398 -- of the assignment. 1399 1400 function Make_Field_Assigns (CI : List_Id) return List_Id; 1401 -- Given CI, a component items list, construct series of statements 1402 -- for fieldwise assignment of the corresponding components. 1403 1404 -------------------- 1405 -- Find_Component -- 1406 -------------------- 1407 1408 function Find_Component 1409 (Typ : Entity_Id; 1410 Comp : Entity_Id) return Entity_Id 1411 is 1412 Utyp : constant Entity_Id := Underlying_Type (Typ); 1413 C : Entity_Id; 1414 1415 begin 1416 C := First_Entity (Utyp); 1417 while Present (C) loop 1418 if Chars (C) = Chars (Comp) then 1419 return C; 1420 end if; 1421 1422 Next_Entity (C); 1423 end loop; 1424 1425 raise Program_Error; 1426 end Find_Component; 1427 1428 -------------------------------- 1429 -- Make_Component_List_Assign -- 1430 -------------------------------- 1431 1432 function Make_Component_List_Assign 1433 (CL : Node_Id; 1434 U_U : Boolean := False) return List_Id 1435 is 1436 CI : constant List_Id := Component_Items (CL); 1437 VP : constant Node_Id := Variant_Part (CL); 1438 1439 Alts : List_Id; 1440 DC : Node_Id; 1441 DCH : List_Id; 1442 Expr : Node_Id; 1443 Result : List_Id; 1444 V : Node_Id; 1445 1446 begin 1447 Result := Make_Field_Assigns (CI); 1448 1449 if Present (VP) then 1450 V := First_Non_Pragma (Variants (VP)); 1451 Alts := New_List; 1452 while Present (V) loop 1453 DCH := New_List; 1454 DC := First (Discrete_Choices (V)); 1455 while Present (DC) loop 1456 Append_To (DCH, New_Copy_Tree (DC)); 1457 Next (DC); 1458 end loop; 1459 1460 Append_To (Alts, 1461 Make_Case_Statement_Alternative (Loc, 1462 Discrete_Choices => DCH, 1463 Statements => 1464 Make_Component_List_Assign (Component_List (V)))); 1465 Next_Non_Pragma (V); 1466 end loop; 1467 1468 -- If we have an Unchecked_Union, use the value of the inferred 1469 -- discriminant of the variant part expression as the switch 1470 -- for the case statement. The case statement may later be 1471 -- folded. 1472 1473 if U_U then 1474 Expr := 1475 New_Copy (Get_Discriminant_Value ( 1476 Entity (Name (VP)), 1477 Etype (Rhs), 1478 Discriminant_Constraint (Etype (Rhs)))); 1479 else 1480 Expr := 1481 Make_Selected_Component (Loc, 1482 Prefix => Duplicate_Subexpr (Rhs), 1483 Selector_Name => 1484 Make_Identifier (Loc, Chars (Name (VP)))); 1485 end if; 1486 1487 Append_To (Result, 1488 Make_Case_Statement (Loc, 1489 Expression => Expr, 1490 Alternatives => Alts)); 1491 end if; 1492 1493 return Result; 1494 end Make_Component_List_Assign; 1495 1496 ----------------------- 1497 -- Make_Field_Assign -- 1498 ----------------------- 1499 1500 function Make_Field_Assign 1501 (C : Entity_Id; 1502 U_U : Boolean := False) return Node_Id 1503 is 1504 A : Node_Id; 1505 Disc : Entity_Id; 1506 Expr : Node_Id; 1507 1508 begin 1509 -- The discriminant entity to be used in the retrieval below must 1510 -- be one in the corresponding type, given that the assignment may 1511 -- be between derived and parent types. 1512 1513 if Is_Derived_Type (Etype (Rhs)) then 1514 Disc := Find_Component (R_Typ, C); 1515 else 1516 Disc := C; 1517 end if; 1518 1519 -- In the case of an Unchecked_Union, use the discriminant 1520 -- constraint value as on the right-hand side of the assignment. 1521 1522 if U_U then 1523 Expr := 1524 New_Copy (Get_Discriminant_Value (C, 1525 Etype (Rhs), 1526 Discriminant_Constraint (Etype (Rhs)))); 1527 else 1528 Expr := 1529 Make_Selected_Component (Loc, 1530 Prefix => Duplicate_Subexpr (Rhs), 1531 Selector_Name => New_Occurrence_Of (Disc, Loc)); 1532 end if; 1533 1534 -- Generate the assignment statement. When the left-hand side 1535 -- is an object with an address clause present, force generated 1536 -- temporaries to be renamings so as to correctly assign to any 1537 -- overlaid objects. 1538 1539 A := 1540 Make_Assignment_Statement (Loc, 1541 Name => 1542 Make_Selected_Component (Loc, 1543 Prefix => 1544 Duplicate_Subexpr 1545 (Exp => Lhs, 1546 Name_Req => False, 1547 Renaming_Req => 1548 Is_Entity_Name (Lhs) 1549 and then Present (Address_Clause (Entity (Lhs)))), 1550 Selector_Name => 1551 New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), 1552 Expression => Expr); 1553 1554 -- Set Assignment_OK, so discriminants can be assigned 1555 1556 Set_Assignment_OK (Name (A), True); 1557 1558 if Componentwise_Assignment (N) 1559 and then Nkind (Name (A)) = N_Selected_Component 1560 and then Chars (Selector_Name (Name (A))) = Name_uParent 1561 then 1562 Set_Componentwise_Assignment (A); 1563 end if; 1564 1565 return A; 1566 end Make_Field_Assign; 1567 1568 ------------------------ 1569 -- Make_Field_Assigns -- 1570 ------------------------ 1571 1572 function Make_Field_Assigns (CI : List_Id) return List_Id is 1573 Item : Node_Id; 1574 Result : List_Id; 1575 1576 begin 1577 Item := First (CI); 1578 Result := New_List; 1579 1580 while Present (Item) loop 1581 1582 -- Look for components, but exclude _tag field assignment if 1583 -- the special Componentwise_Assignment flag is set. 1584 1585 if Nkind (Item) = N_Component_Declaration 1586 and then not (Is_Tag (Defining_Identifier (Item)) 1587 and then Componentwise_Assignment (N)) 1588 then 1589 Append_To 1590 (Result, Make_Field_Assign (Defining_Identifier (Item))); 1591 end if; 1592 1593 Next (Item); 1594 end loop; 1595 1596 return Result; 1597 end Make_Field_Assigns; 1598 1599 -- Start of processing for Expand_Assign_Record 1600 1601 begin 1602 -- Note that we use the base types for this processing. This results 1603 -- in some extra work in the constrained case, but the change of 1604 -- representation case is so unusual that it is not worth the effort. 1605 1606 -- First copy the discriminants. This is done unconditionally. It 1607 -- is required in the unconstrained left side case, and also in the 1608 -- case where this assignment was constructed during the expansion 1609 -- of a type conversion (since initialization of discriminants is 1610 -- suppressed in this case). It is unnecessary but harmless in 1611 -- other cases. 1612 1613 -- Special case: no copy if the target has no discriminants 1614 1615 if Has_Discriminants (L_Typ) 1616 and then Is_Unchecked_Union (Base_Type (L_Typ)) 1617 then 1618 null; 1619 1620 elsif Has_Discriminants (L_Typ) then 1621 F := First_Discriminant (R_Typ); 1622 while Present (F) loop 1623 1624 -- If we are expanding the initialization of a derived record 1625 -- that constrains or renames discriminants of the parent, we 1626 -- must use the corresponding discriminant in the parent. 1627 1628 declare 1629 CF : Entity_Id; 1630 1631 begin 1632 if Inside_Init_Proc 1633 and then Present (Corresponding_Discriminant (F)) 1634 then 1635 CF := Corresponding_Discriminant (F); 1636 else 1637 CF := F; 1638 end if; 1639 1640 if Is_Unchecked_Union (Base_Type (R_Typ)) then 1641 1642 -- Within an initialization procedure this is the 1643 -- assignment to an unchecked union component, in which 1644 -- case there is no discriminant to initialize. 1645 1646 if Inside_Init_Proc then 1647 null; 1648 1649 else 1650 -- The assignment is part of a conversion from a 1651 -- derived unchecked union type with an inferable 1652 -- discriminant, to a parent type. 1653 1654 Insert_Action (N, Make_Field_Assign (CF, True)); 1655 end if; 1656 1657 else 1658 Insert_Action (N, Make_Field_Assign (CF)); 1659 end if; 1660 1661 Next_Discriminant (F); 1662 end; 1663 end loop; 1664 1665 -- If the derived type has a stored constraint, assign the value 1666 -- of the corresponding discriminants explicitly, skipping those 1667 -- that are renamed discriminants. We cannot just retrieve them 1668 -- from the Rhs by selected component because they are invisible 1669 -- in the type of the right-hand side. 1670 1671 if Stored_Constraint (R_Typ) /= No_Elist then 1672 declare 1673 Assign : Node_Id; 1674 Discr_Val : Elmt_Id; 1675 1676 begin 1677 Discr_Val := First_Elmt (Stored_Constraint (R_Typ)); 1678 F := First_Entity (R_Typ); 1679 while Present (F) loop 1680 if Ekind (F) = E_Discriminant 1681 and then Is_Completely_Hidden (F) 1682 and then Present (Corresponding_Record_Component (F)) 1683 and then 1684 (not Is_Entity_Name (Node (Discr_Val)) 1685 or else Ekind (Entity (Node (Discr_Val))) /= 1686 E_Discriminant) 1687 then 1688 Assign := 1689 Make_Assignment_Statement (Loc, 1690 Name => 1691 Make_Selected_Component (Loc, 1692 Prefix => Duplicate_Subexpr (Lhs), 1693 Selector_Name => 1694 New_Occurrence_Of 1695 (Corresponding_Record_Component (F), Loc)), 1696 Expression => New_Copy (Node (Discr_Val))); 1697 1698 Set_Assignment_OK (Name (Assign)); 1699 Insert_Action (N, Assign); 1700 Next_Elmt (Discr_Val); 1701 end if; 1702 1703 Next_Entity (F); 1704 end loop; 1705 end; 1706 end if; 1707 end if; 1708 1709 -- We know the underlying type is a record, but its current view 1710 -- may be private. We must retrieve the usable record declaration. 1711 1712 if Nkind_In (Decl, N_Private_Type_Declaration, 1713 N_Private_Extension_Declaration) 1714 and then Present (Full_View (R_Typ)) 1715 then 1716 RDef := Type_Definition (Declaration_Node (Full_View (R_Typ))); 1717 else 1718 RDef := Type_Definition (Decl); 1719 end if; 1720 1721 if Nkind (RDef) = N_Derived_Type_Definition then 1722 RDef := Record_Extension_Part (RDef); 1723 end if; 1724 1725 if Nkind (RDef) = N_Record_Definition 1726 and then Present (Component_List (RDef)) 1727 then 1728 if Is_Unchecked_Union (R_Typ) then 1729 Insert_Actions (N, 1730 Make_Component_List_Assign (Component_List (RDef), True)); 1731 else 1732 Insert_Actions 1733 (N, Make_Component_List_Assign (Component_List (RDef))); 1734 end if; 1735 1736 Rewrite (N, Make_Null_Statement (Loc)); 1737 end if; 1738 end; 1739 end Expand_Assign_Record; 1740 1741 ------------------------------------- 1742 -- Expand_Assign_With_Target_Names -- 1743 ------------------------------------- 1744 1745 procedure Expand_Assign_With_Target_Names (N : Node_Id) is 1746 LHS : constant Node_Id := Name (N); 1747 LHS_Typ : constant Entity_Id := Etype (LHS); 1748 Loc : constant Source_Ptr := Sloc (N); 1749 RHS : constant Node_Id := Expression (N); 1750 1751 Ent : Entity_Id; 1752 -- The entity of the left-hand side 1753 1754 function Replace_Target (N : Node_Id) return Traverse_Result; 1755 -- Replace occurrences of the target name by the proper entity: either 1756 -- the entity of the LHS in simple cases, or the formal of the 1757 -- constructed procedure otherwise. 1758 1759 -------------------- 1760 -- Replace_Target -- 1761 -------------------- 1762 1763 function Replace_Target (N : Node_Id) return Traverse_Result is 1764 begin 1765 if Nkind (N) = N_Target_Name then 1766 Rewrite (N, New_Occurrence_Of (Ent, Sloc (N))); 1767 1768 -- The expression will be reanalyzed when the enclosing assignment 1769 -- is reanalyzed, so reset the entity, which may be a temporary 1770 -- created during analysis, e.g. a loop variable for an iterated 1771 -- component association. However, if entity is callable then 1772 -- resolution has established its proper identity (including in 1773 -- rewritten prefixed calls) so we must preserve it. 1774 1775 elsif Is_Entity_Name (N) then 1776 if Present (Entity (N)) 1777 and then not Is_Overloadable (Entity (N)) 1778 then 1779 Set_Entity (N, Empty); 1780 end if; 1781 end if; 1782 1783 Set_Analyzed (N, False); 1784 return OK; 1785 end Replace_Target; 1786 1787 procedure Replace_Target_Name is new Traverse_Proc (Replace_Target); 1788 1789 -- Local variables 1790 1791 New_RHS : Node_Id; 1792 Proc_Id : Entity_Id; 1793 1794 -- Start of processing for Expand_Assign_With_Target_Names 1795 1796 begin 1797 New_RHS := New_Copy_Tree (RHS); 1798 1799 -- The left-hand side is a direct name 1800 1801 if Is_Entity_Name (LHS) 1802 and then not Is_Renaming_Of_Object (Entity (LHS)) 1803 then 1804 Ent := Entity (LHS); 1805 Replace_Target_Name (New_RHS); 1806 1807 -- Generate: 1808 -- LHS := ... LHS ...; 1809 1810 Rewrite (N, 1811 Make_Assignment_Statement (Loc, 1812 Name => Relocate_Node (LHS), 1813 Expression => New_RHS)); 1814 1815 -- The left-hand side is not a direct name, but is side-effect free. 1816 -- Capture its value in a temporary to avoid multiple evaluations. 1817 1818 elsif Side_Effect_Free (LHS) then 1819 Ent := Make_Temporary (Loc, 'T'); 1820 Replace_Target_Name (New_RHS); 1821 1822 -- Generate: 1823 -- T : LHS_Typ := LHS; 1824 1825 Insert_Before_And_Analyze (N, 1826 Make_Object_Declaration (Loc, 1827 Defining_Identifier => Ent, 1828 Object_Definition => New_Occurrence_Of (LHS_Typ, Loc), 1829 Expression => New_Copy_Tree (LHS))); 1830 1831 -- Generate: 1832 -- LHS := ... T ...; 1833 1834 Rewrite (N, 1835 Make_Assignment_Statement (Loc, 1836 Name => Relocate_Node (LHS), 1837 Expression => New_RHS)); 1838 1839 -- Otherwise wrap the whole assignment statement in a procedure with an 1840 -- IN OUT parameter. The original assignment then becomes a call to the 1841 -- procedure with the left-hand side as an actual. 1842 1843 else 1844 Ent := Make_Temporary (Loc, 'T'); 1845 Replace_Target_Name (New_RHS); 1846 1847 -- Generate: 1848 -- procedure P (T : in out LHS_Typ) is 1849 -- begin 1850 -- T := ... T ...; 1851 -- end P; 1852 1853 Proc_Id := Make_Temporary (Loc, 'P'); 1854 1855 Insert_Before_And_Analyze (N, 1856 Make_Subprogram_Body (Loc, 1857 Specification => 1858 Make_Procedure_Specification (Loc, 1859 Defining_Unit_Name => Proc_Id, 1860 Parameter_Specifications => New_List ( 1861 Make_Parameter_Specification (Loc, 1862 Defining_Identifier => Ent, 1863 In_Present => True, 1864 Out_Present => True, 1865 Parameter_Type => 1866 New_Occurrence_Of (LHS_Typ, Loc)))), 1867 1868 Declarations => Empty_List, 1869 1870 Handled_Statement_Sequence => 1871 Make_Handled_Sequence_Of_Statements (Loc, 1872 Statements => New_List ( 1873 Make_Assignment_Statement (Loc, 1874 Name => New_Occurrence_Of (Ent, Loc), 1875 Expression => New_RHS))))); 1876 1877 -- Generate: 1878 -- P (LHS); 1879 1880 Rewrite (N, 1881 Make_Procedure_Call_Statement (Loc, 1882 Name => New_Occurrence_Of (Proc_Id, Loc), 1883 Parameter_Associations => New_List (Relocate_Node (LHS)))); 1884 end if; 1885 1886 -- Analyze rewritten node, either as assignment or procedure call 1887 1888 Analyze (N); 1889 end Expand_Assign_With_Target_Names; 1890 1891 ----------------------------------- 1892 -- Expand_N_Assignment_Statement -- 1893 ----------------------------------- 1894 1895 -- This procedure implements various cases where an assignment statement 1896 -- cannot just be passed on to the back end in untransformed state. 1897 1898 procedure Expand_N_Assignment_Statement (N : Node_Id) is 1899 Crep : constant Boolean := Change_Of_Representation (N); 1900 Lhs : constant Node_Id := Name (N); 1901 Loc : constant Source_Ptr := Sloc (N); 1902 Rhs : constant Node_Id := Expression (N); 1903 Typ : constant Entity_Id := Underlying_Type (Etype (Lhs)); 1904 Exp : Node_Id; 1905 1906 begin 1907 -- Special case to check right away, if the Componentwise_Assignment 1908 -- flag is set, this is a reanalysis from the expansion of the primitive 1909 -- assignment procedure for a tagged type, and all we need to do is to 1910 -- expand to assignment of components, because otherwise, we would get 1911 -- infinite recursion (since this looks like a tagged assignment which 1912 -- would normally try to *call* the primitive assignment procedure). 1913 1914 if Componentwise_Assignment (N) then 1915 Expand_Assign_Record (N); 1916 return; 1917 end if; 1918 1919 -- Defend against invalid subscripts on left side if we are in standard 1920 -- validity checking mode. No need to do this if we are checking all 1921 -- subscripts. 1922 1923 -- Note that we do this right away, because there are some early return 1924 -- paths in this procedure, and this is required on all paths. 1925 1926 if Validity_Checks_On 1927 and then Validity_Check_Default 1928 and then not Validity_Check_Subscripts 1929 then 1930 Check_Valid_Lvalue_Subscripts (Lhs); 1931 end if; 1932 1933 -- Separate expansion if RHS contain target names. Note that assignment 1934 -- may already have been expanded if RHS is aggregate. 1935 1936 if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then 1937 Expand_Assign_With_Target_Names (N); 1938 return; 1939 end if; 1940 1941 -- Ada 2005 (AI-327): Handle assignment to priority of protected object 1942 1943 -- Rewrite an assignment to X'Priority into a run-time call 1944 1945 -- For example: X'Priority := New_Prio_Expr; 1946 -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr); 1947 1948 -- Note that although X'Priority is notionally an object, it is quite 1949 -- deliberately not defined as an aliased object in the RM. This means 1950 -- that it works fine to rewrite it as a call, without having to worry 1951 -- about complications that would other arise from X'Priority'Access, 1952 -- which is illegal, because of the lack of aliasing. 1953 1954 if Ada_Version >= Ada_2005 then 1955 declare 1956 Call : Node_Id; 1957 Conctyp : Entity_Id; 1958 Ent : Entity_Id; 1959 Subprg : Entity_Id; 1960 RT_Subprg_Name : Node_Id; 1961 1962 begin 1963 -- Handle chains of renamings 1964 1965 Ent := Name (N); 1966 while Nkind (Ent) in N_Has_Entity 1967 and then Present (Entity (Ent)) 1968 and then Present (Renamed_Object (Entity (Ent))) 1969 loop 1970 Ent := Renamed_Object (Entity (Ent)); 1971 end loop; 1972 1973 -- The attribute Priority applied to protected objects has been 1974 -- previously expanded into a call to the Get_Ceiling run-time 1975 -- subprogram. In restricted profiles this is not available. 1976 1977 if Is_Expanded_Priority_Attribute (Ent) then 1978 1979 -- Look for the enclosing concurrent type 1980 1981 Conctyp := Current_Scope; 1982 while not Is_Concurrent_Type (Conctyp) loop 1983 Conctyp := Scope (Conctyp); 1984 end loop; 1985 1986 pragma Assert (Is_Protected_Type (Conctyp)); 1987 1988 -- Generate the first actual of the call 1989 1990 Subprg := Current_Scope; 1991 while not Present (Protected_Body_Subprogram (Subprg)) loop 1992 Subprg := Scope (Subprg); 1993 end loop; 1994 1995 -- Select the appropriate run-time call 1996 1997 if Number_Entries (Conctyp) = 0 then 1998 RT_Subprg_Name := 1999 New_Occurrence_Of (RTE (RE_Set_Ceiling), Loc); 2000 else 2001 RT_Subprg_Name := 2002 New_Occurrence_Of (RTE (RO_PE_Set_Ceiling), Loc); 2003 end if; 2004 2005 Call := 2006 Make_Procedure_Call_Statement (Loc, 2007 Name => RT_Subprg_Name, 2008 Parameter_Associations => New_List ( 2009 New_Copy_Tree (First (Parameter_Associations (Ent))), 2010 Relocate_Node (Expression (N)))); 2011 2012 Rewrite (N, Call); 2013 Analyze (N); 2014 2015 return; 2016 end if; 2017 end; 2018 end if; 2019 2020 -- Deal with assignment checks unless suppressed 2021 2022 if not Suppress_Assignment_Checks (N) then 2023 2024 -- First deal with generation of range check if required 2025 2026 if Do_Range_Check (Rhs) then 2027 Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed); 2028 end if; 2029 2030 -- Then generate predicate check if required 2031 2032 Apply_Predicate_Check (Rhs, Typ); 2033 end if; 2034 2035 -- Check for a special case where a high level transformation is 2036 -- required. If we have either of: 2037 2038 -- P.field := rhs; 2039 -- P (sub) := rhs; 2040 2041 -- where P is a reference to a bit packed array, then we have to unwind 2042 -- the assignment. The exact meaning of being a reference to a bit 2043 -- packed array is as follows: 2044 2045 -- An indexed component whose prefix is a bit packed array is a 2046 -- reference to a bit packed array. 2047 2048 -- An indexed component or selected component whose prefix is a 2049 -- reference to a bit packed array is itself a reference ot a 2050 -- bit packed array. 2051 2052 -- The required transformation is 2053 2054 -- Tnn : prefix_type := P; 2055 -- Tnn.field := rhs; 2056 -- P := Tnn; 2057 2058 -- or 2059 2060 -- Tnn : prefix_type := P; 2061 -- Tnn (subscr) := rhs; 2062 -- P := Tnn; 2063 2064 -- Since P is going to be evaluated more than once, any subscripts 2065 -- in P must have their evaluation forced. 2066 2067 if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component) 2068 and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs)) 2069 then 2070 declare 2071 BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs)); 2072 BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr); 2073 Tnn : constant Entity_Id := 2074 Make_Temporary (Loc, 'T', BPAR_Expr); 2075 2076 begin 2077 -- Insert the post assignment first, because we want to copy the 2078 -- BPAR_Expr tree before it gets analyzed in the context of the 2079 -- pre assignment. Note that we do not analyze the post assignment 2080 -- yet (we cannot till we have completed the analysis of the pre 2081 -- assignment). As usual, the analysis of this post assignment 2082 -- will happen on its own when we "run into" it after finishing 2083 -- the current assignment. 2084 2085 Insert_After (N, 2086 Make_Assignment_Statement (Loc, 2087 Name => New_Copy_Tree (BPAR_Expr), 2088 Expression => New_Occurrence_Of (Tnn, Loc))); 2089 2090 -- At this stage BPAR_Expr is a reference to a bit packed array 2091 -- where the reference was not expanded in the original tree, 2092 -- since it was on the left side of an assignment. But in the 2093 -- pre-assignment statement (the object definition), BPAR_Expr 2094 -- will end up on the right-hand side, and must be reexpanded. To 2095 -- achieve this, we reset the analyzed flag of all selected and 2096 -- indexed components down to the actual indexed component for 2097 -- the packed array. 2098 2099 Exp := BPAR_Expr; 2100 loop 2101 Set_Analyzed (Exp, False); 2102 2103 if Nkind_In (Exp, N_Indexed_Component, 2104 N_Selected_Component) 2105 then 2106 Exp := Prefix (Exp); 2107 else 2108 exit; 2109 end if; 2110 end loop; 2111 2112 -- Now we can insert and analyze the pre-assignment 2113 2114 -- If the right-hand side requires a transient scope, it has 2115 -- already been placed on the stack. However, the declaration is 2116 -- inserted in the tree outside of this scope, and must reflect 2117 -- the proper scope for its variable. This awkward bit is forced 2118 -- by the stricter scope discipline imposed by GCC 2.97. 2119 2120 declare 2121 Uses_Transient_Scope : constant Boolean := 2122 Scope_Is_Transient 2123 and then N = Node_To_Be_Wrapped; 2124 2125 begin 2126 if Uses_Transient_Scope then 2127 Push_Scope (Scope (Current_Scope)); 2128 end if; 2129 2130 Insert_Before_And_Analyze (N, 2131 Make_Object_Declaration (Loc, 2132 Defining_Identifier => Tnn, 2133 Object_Definition => New_Occurrence_Of (BPAR_Typ, Loc), 2134 Expression => BPAR_Expr)); 2135 2136 if Uses_Transient_Scope then 2137 Pop_Scope; 2138 end if; 2139 end; 2140 2141 -- Now fix up the original assignment and continue processing 2142 2143 Rewrite (Prefix (Lhs), 2144 New_Occurrence_Of (Tnn, Loc)); 2145 2146 -- We do not need to reanalyze that assignment, and we do not need 2147 -- to worry about references to the temporary, but we do need to 2148 -- make sure that the temporary is not marked as a true constant 2149 -- since we now have a generated assignment to it. 2150 2151 Set_Is_True_Constant (Tnn, False); 2152 end; 2153 end if; 2154 2155 -- When we have the appropriate type of aggregate in the expression (it 2156 -- has been determined during analysis of the aggregate by setting the 2157 -- delay flag), let's perform in place assignment and thus avoid 2158 -- creating a temporary. 2159 2160 if Is_Delayed_Aggregate (Rhs) then 2161 Convert_Aggr_In_Assignment (N); 2162 Rewrite (N, Make_Null_Statement (Loc)); 2163 Analyze (N); 2164 2165 return; 2166 end if; 2167 2168 -- Apply discriminant check if required. If Lhs is an access type to a 2169 -- designated type with discriminants, we must always check. If the 2170 -- type has unknown discriminants, more elaborate processing below. 2171 2172 if Has_Discriminants (Etype (Lhs)) 2173 and then not Has_Unknown_Discriminants (Etype (Lhs)) 2174 then 2175 -- Skip discriminant check if change of representation. Will be 2176 -- done when the change of representation is expanded out. 2177 2178 if not Crep then 2179 Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs); 2180 end if; 2181 2182 -- If the type is private without discriminants, and the full type 2183 -- has discriminants (necessarily with defaults) a check may still be 2184 -- necessary if the Lhs is aliased. The private discriminants must be 2185 -- visible to build the discriminant constraints. 2186 2187 -- Only an explicit dereference that comes from source indicates 2188 -- aliasing. Access to formals of protected operations and entries 2189 -- create dereferences but are not semantic aliasings. 2190 2191 elsif Is_Private_Type (Etype (Lhs)) 2192 and then Has_Discriminants (Typ) 2193 and then Nkind (Lhs) = N_Explicit_Dereference 2194 and then Comes_From_Source (Lhs) 2195 then 2196 declare 2197 Lt : constant Entity_Id := Etype (Lhs); 2198 Ubt : Entity_Id := Base_Type (Typ); 2199 2200 begin 2201 -- In the case of an expander-generated record subtype whose base 2202 -- type still appears private, Typ will have been set to that 2203 -- private type rather than the underlying record type (because 2204 -- Underlying type will have returned the record subtype), so it's 2205 -- necessary to apply Underlying_Type again to the base type to 2206 -- get the record type we need for the discriminant check. Such 2207 -- subtypes can be created for assignments in certain cases, such 2208 -- as within an instantiation passed this kind of private type. 2209 -- It would be good to avoid this special test, but making changes 2210 -- to prevent this odd form of record subtype seems difficult. ??? 2211 2212 if Is_Private_Type (Ubt) then 2213 Ubt := Underlying_Type (Ubt); 2214 end if; 2215 2216 Set_Etype (Lhs, Ubt); 2217 Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs)); 2218 Apply_Discriminant_Check (Rhs, Ubt, Lhs); 2219 Set_Etype (Lhs, Lt); 2220 end; 2221 2222 -- If the Lhs has a private type with unknown discriminants, it may 2223 -- have a full view with discriminants, but those are nameable only 2224 -- in the underlying type, so convert the Rhs to it before potential 2225 -- checking. Convert Lhs as well, otherwise the actual subtype might 2226 -- not be constructible. If the discriminants have defaults the type 2227 -- is unconstrained and there is nothing to check. 2228 2229 elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) 2230 and then Has_Discriminants (Typ) 2231 and then not Has_Defaulted_Discriminants (Typ) 2232 then 2233 Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); 2234 Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); 2235 Apply_Discriminant_Check (Rhs, Typ, Lhs); 2236 2237 -- In the access type case, we need the same discriminant check, and 2238 -- also range checks if we have an access to constrained array. 2239 2240 elsif Is_Access_Type (Etype (Lhs)) 2241 and then Is_Constrained (Designated_Type (Etype (Lhs))) 2242 then 2243 if Has_Discriminants (Designated_Type (Etype (Lhs))) then 2244 2245 -- Skip discriminant check if change of representation. Will be 2246 -- done when the change of representation is expanded out. 2247 2248 if not Crep then 2249 Apply_Discriminant_Check (Rhs, Etype (Lhs)); 2250 end if; 2251 2252 elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then 2253 Apply_Range_Check (Rhs, Etype (Lhs)); 2254 2255 if Is_Constrained (Etype (Lhs)) then 2256 Apply_Length_Check (Rhs, Etype (Lhs)); 2257 end if; 2258 2259 if Nkind (Rhs) = N_Allocator then 2260 declare 2261 Target_Typ : constant Entity_Id := Etype (Expression (Rhs)); 2262 C_Es : Check_Result; 2263 2264 begin 2265 C_Es := 2266 Get_Range_Checks 2267 (Lhs, 2268 Target_Typ, 2269 Etype (Designated_Type (Etype (Lhs)))); 2270 2271 Insert_Range_Checks 2272 (C_Es, 2273 N, 2274 Target_Typ, 2275 Sloc (Lhs), 2276 Lhs); 2277 end; 2278 end if; 2279 end if; 2280 2281 -- Apply range check for access type case 2282 2283 elsif Is_Access_Type (Etype (Lhs)) 2284 and then Nkind (Rhs) = N_Allocator 2285 and then Nkind (Expression (Rhs)) = N_Qualified_Expression 2286 then 2287 Analyze_And_Resolve (Expression (Rhs)); 2288 Apply_Range_Check 2289 (Expression (Rhs), Designated_Type (Etype (Lhs))); 2290 end if; 2291 2292 -- Ada 2005 (AI-231): Generate the run-time check 2293 2294 if Is_Access_Type (Typ) 2295 and then Can_Never_Be_Null (Etype (Lhs)) 2296 and then not Can_Never_Be_Null (Etype (Rhs)) 2297 2298 -- If an actual is an out parameter of a null-excluding access 2299 -- type, there is access check on entry, so we set the flag 2300 -- Suppress_Assignment_Checks on the generated statement to 2301 -- assign the actual to the parameter block, and we do not want 2302 -- to generate an additional check at this point. 2303 2304 and then not Suppress_Assignment_Checks (N) 2305 then 2306 Apply_Constraint_Check (Rhs, Etype (Lhs)); 2307 end if; 2308 2309 -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a 2310 -- stand-alone obj of an anonymous access type. Do not install the check 2311 -- when the Lhs denotes a container cursor and the Next function employs 2312 -- an access type, because this can never result in a dangling pointer. 2313 2314 if Is_Access_Type (Typ) 2315 and then Is_Entity_Name (Lhs) 2316 and then Ekind (Entity (Lhs)) /= E_Loop_Parameter 2317 and then Present (Effective_Extra_Accessibility (Entity (Lhs))) 2318 then 2319 declare 2320 function Lhs_Entity return Entity_Id; 2321 -- Look through renames to find the underlying entity. 2322 -- For assignment to a rename, we don't care about the 2323 -- Enclosing_Dynamic_Scope of the rename declaration. 2324 2325 ---------------- 2326 -- Lhs_Entity -- 2327 ---------------- 2328 2329 function Lhs_Entity return Entity_Id is 2330 Result : Entity_Id := Entity (Lhs); 2331 2332 begin 2333 while Present (Renamed_Object (Result)) loop 2334 2335 -- Renamed_Object must return an Entity_Name here 2336 -- because of preceding "Present (E_E_A (...))" test. 2337 2338 Result := Entity (Renamed_Object (Result)); 2339 end loop; 2340 2341 return Result; 2342 end Lhs_Entity; 2343 2344 -- Local Declarations 2345 2346 Access_Check : constant Node_Id := 2347 Make_Raise_Program_Error (Loc, 2348 Condition => 2349 Make_Op_Gt (Loc, 2350 Left_Opnd => 2351 Dynamic_Accessibility_Level (Rhs), 2352 Right_Opnd => 2353 Make_Integer_Literal (Loc, 2354 Intval => 2355 Scope_Depth 2356 (Enclosing_Dynamic_Scope 2357 (Lhs_Entity)))), 2358 Reason => PE_Accessibility_Check_Failed); 2359 2360 Access_Level_Update : constant Node_Id := 2361 Make_Assignment_Statement (Loc, 2362 Name => 2363 New_Occurrence_Of 2364 (Effective_Extra_Accessibility 2365 (Entity (Lhs)), Loc), 2366 Expression => 2367 Dynamic_Accessibility_Level (Rhs)); 2368 2369 begin 2370 if not Accessibility_Checks_Suppressed (Entity (Lhs)) then 2371 Insert_Action (N, Access_Check); 2372 end if; 2373 2374 Insert_Action (N, Access_Level_Update); 2375 end; 2376 end if; 2377 2378 -- Case of assignment to a bit packed array element. If there is a 2379 -- change of representation this must be expanded into components, 2380 -- otherwise this is a bit-field assignment. 2381 2382 if Nkind (Lhs) = N_Indexed_Component 2383 and then Is_Bit_Packed_Array (Etype (Prefix (Lhs))) 2384 then 2385 -- Normal case, no change of representation 2386 2387 if not Crep then 2388 Expand_Bit_Packed_Element_Set (N); 2389 return; 2390 2391 -- Change of representation case 2392 2393 else 2394 -- Generate the following, to force component-by-component 2395 -- assignments in an efficient way. Otherwise each component 2396 -- will require a temporary and two bit-field manipulations. 2397 2398 -- T1 : Elmt_Type; 2399 -- T1 := RhS; 2400 -- Lhs := T1; 2401 2402 declare 2403 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T'); 2404 Stats : List_Id; 2405 2406 begin 2407 Stats := 2408 New_List ( 2409 Make_Object_Declaration (Loc, 2410 Defining_Identifier => Tnn, 2411 Object_Definition => 2412 New_Occurrence_Of (Etype (Lhs), Loc)), 2413 Make_Assignment_Statement (Loc, 2414 Name => New_Occurrence_Of (Tnn, Loc), 2415 Expression => Relocate_Node (Rhs)), 2416 Make_Assignment_Statement (Loc, 2417 Name => Relocate_Node (Lhs), 2418 Expression => New_Occurrence_Of (Tnn, Loc))); 2419 2420 Insert_Actions (N, Stats); 2421 Rewrite (N, Make_Null_Statement (Loc)); 2422 Analyze (N); 2423 end; 2424 end if; 2425 2426 -- Build-in-place function call case. This is for assignment statements 2427 -- that come from aggregate component associations or from init procs. 2428 -- User-written assignment statements with b-i-p calls are handled 2429 -- elsewhere. 2430 2431 elsif Is_Build_In_Place_Function_Call (Rhs) then 2432 pragma Assert (not Comes_From_Source (N)); 2433 Make_Build_In_Place_Call_In_Assignment (N, Rhs); 2434 2435 elsif Is_Tagged_Type (Typ) 2436 or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) 2437 then 2438 Tagged_Case : declare 2439 L : List_Id := No_List; 2440 Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N); 2441 2442 begin 2443 -- In the controlled case, we ensure that function calls are 2444 -- evaluated before finalizing the target. In all cases, it makes 2445 -- the expansion easier if the side effects are removed first. 2446 2447 Remove_Side_Effects (Lhs); 2448 Remove_Side_Effects (Rhs); 2449 2450 -- Avoid recursion in the mechanism 2451 2452 Set_Analyzed (N); 2453 2454 -- If dispatching assignment, we need to dispatch to _assign 2455 2456 if Is_Class_Wide_Type (Typ) 2457 2458 -- If the type is tagged, we may as well use the predefined 2459 -- primitive assignment. This avoids inlining a lot of code 2460 -- and in the class-wide case, the assignment is replaced 2461 -- by a dispatching call to _assign. It is suppressed in the 2462 -- case of assignments created by the expander that correspond 2463 -- to initializations, where we do want to copy the tag 2464 -- (Expand_Ctrl_Actions flag is set False in this case). It is 2465 -- also suppressed if restriction No_Dispatching_Calls is in 2466 -- force because in that case predefined primitives are not 2467 -- generated. 2468 2469 or else (Is_Tagged_Type (Typ) 2470 and then Chars (Current_Scope) /= Name_uAssign 2471 and then Expand_Ctrl_Actions 2472 and then 2473 not Restriction_Active (No_Dispatching_Calls)) 2474 then 2475 if Is_Limited_Type (Typ) then 2476 2477 -- This can happen in an instance when the formal is an 2478 -- extension of a limited interface, and the actual is 2479 -- limited. This is an error according to AI05-0087, but 2480 -- is not caught at the point of instantiation in earlier 2481 -- versions. We also must verify that the limited type does 2482 -- not come from source as corner cases may exist where 2483 -- an assignment was not intended like the pathological case 2484 -- of a raise expression within a return statement. 2485 2486 -- This is wrong, error messages cannot be issued during 2487 -- expansion, since they would be missed in -gnatc mode ??? 2488 2489 if Comes_From_Source (N) then 2490 Error_Msg_N 2491 ("assignment not available on limited type", N); 2492 end if; 2493 2494 return; 2495 end if; 2496 2497 -- Fetch the primitive op _assign and proper type to call it. 2498 -- Because of possible conflicts between private and full view, 2499 -- fetch the proper type directly from the operation profile. 2500 2501 declare 2502 Op : constant Entity_Id := 2503 Find_Prim_Op (Typ, Name_uAssign); 2504 F_Typ : Entity_Id := Etype (First_Formal (Op)); 2505 2506 begin 2507 -- If the assignment is dispatching, make sure to use the 2508 -- proper type. 2509 2510 if Is_Class_Wide_Type (Typ) then 2511 F_Typ := Class_Wide_Type (F_Typ); 2512 end if; 2513 2514 L := New_List; 2515 2516 -- In case of assignment to a class-wide tagged type, before 2517 -- the assignment we generate run-time check to ensure that 2518 -- the tags of source and target match. 2519 2520 if not Tag_Checks_Suppressed (Typ) 2521 and then Is_Class_Wide_Type (Typ) 2522 and then Is_Tagged_Type (Typ) 2523 and then Is_Tagged_Type (Underlying_Type (Etype (Rhs))) 2524 then 2525 declare 2526 Lhs_Tag : Node_Id; 2527 Rhs_Tag : Node_Id; 2528 2529 begin 2530 if not Is_Interface (Typ) then 2531 Lhs_Tag := 2532 Make_Selected_Component (Loc, 2533 Prefix => Duplicate_Subexpr (Lhs), 2534 Selector_Name => 2535 Make_Identifier (Loc, Name_uTag)); 2536 Rhs_Tag := 2537 Make_Selected_Component (Loc, 2538 Prefix => Duplicate_Subexpr (Rhs), 2539 Selector_Name => 2540 Make_Identifier (Loc, Name_uTag)); 2541 else 2542 -- Displace the pointer to the base of the objects 2543 -- applying 'Address, which is later expanded into 2544 -- a call to RE_Base_Address. 2545 2546 Lhs_Tag := 2547 Make_Explicit_Dereference (Loc, 2548 Prefix => 2549 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 2550 Make_Attribute_Reference (Loc, 2551 Prefix => Duplicate_Subexpr (Lhs), 2552 Attribute_Name => Name_Address))); 2553 Rhs_Tag := 2554 Make_Explicit_Dereference (Loc, 2555 Prefix => 2556 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 2557 Make_Attribute_Reference (Loc, 2558 Prefix => Duplicate_Subexpr (Rhs), 2559 Attribute_Name => Name_Address))); 2560 end if; 2561 2562 Append_To (L, 2563 Make_Raise_Constraint_Error (Loc, 2564 Condition => 2565 Make_Op_Ne (Loc, 2566 Left_Opnd => Lhs_Tag, 2567 Right_Opnd => Rhs_Tag), 2568 Reason => CE_Tag_Check_Failed)); 2569 end; 2570 end if; 2571 2572 declare 2573 Left_N : Node_Id := Duplicate_Subexpr (Lhs); 2574 Right_N : Node_Id := Duplicate_Subexpr (Rhs); 2575 2576 begin 2577 -- In order to dispatch the call to _assign the type of 2578 -- the actuals must match. Add conversion (if required). 2579 2580 if Etype (Lhs) /= F_Typ then 2581 Left_N := Unchecked_Convert_To (F_Typ, Left_N); 2582 end if; 2583 2584 if Etype (Rhs) /= F_Typ then 2585 Right_N := Unchecked_Convert_To (F_Typ, Right_N); 2586 end if; 2587 2588 Append_To (L, 2589 Make_Procedure_Call_Statement (Loc, 2590 Name => New_Occurrence_Of (Op, Loc), 2591 Parameter_Associations => New_List ( 2592 Node1 => Left_N, 2593 Node2 => Right_N))); 2594 end; 2595 end; 2596 2597 else 2598 L := Make_Tag_Ctrl_Assignment (N); 2599 2600 -- We can't afford to have destructive Finalization Actions in 2601 -- the Self assignment case, so if the target and the source 2602 -- are not obviously different, code is generated to avoid the 2603 -- self assignment case: 2604 2605 -- if lhs'address /= rhs'address then 2606 -- <code for controlled and/or tagged assignment> 2607 -- end if; 2608 2609 -- Skip this if Restriction (No_Finalization) is active 2610 2611 if not Statically_Different (Lhs, Rhs) 2612 and then Expand_Ctrl_Actions 2613 and then not Restriction_Active (No_Finalization) 2614 then 2615 L := New_List ( 2616 Make_Implicit_If_Statement (N, 2617 Condition => 2618 Make_Op_Ne (Loc, 2619 Left_Opnd => 2620 Make_Attribute_Reference (Loc, 2621 Prefix => Duplicate_Subexpr (Lhs), 2622 Attribute_Name => Name_Address), 2623 2624 Right_Opnd => 2625 Make_Attribute_Reference (Loc, 2626 Prefix => Duplicate_Subexpr (Rhs), 2627 Attribute_Name => Name_Address)), 2628 2629 Then_Statements => L)); 2630 end if; 2631 2632 -- We need to set up an exception handler for implementing 2633 -- 7.6.1(18). The remaining adjustments are tackled by the 2634 -- implementation of adjust for record_controllers (see 2635 -- s-finimp.adb). 2636 2637 -- This is skipped if we have no finalization 2638 2639 if Expand_Ctrl_Actions 2640 and then not Restriction_Active (No_Finalization) 2641 then 2642 L := New_List ( 2643 Make_Block_Statement (Loc, 2644 Handled_Statement_Sequence => 2645 Make_Handled_Sequence_Of_Statements (Loc, 2646 Statements => L, 2647 Exception_Handlers => New_List ( 2648 Make_Handler_For_Ctrl_Operation (Loc))))); 2649 end if; 2650 end if; 2651 2652 Rewrite (N, 2653 Make_Block_Statement (Loc, 2654 Handled_Statement_Sequence => 2655 Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); 2656 2657 -- If no restrictions on aborts, protect the whole assignment 2658 -- for controlled objects as per 9.8(11). 2659 2660 if Needs_Finalization (Typ) 2661 and then Expand_Ctrl_Actions 2662 and then Abort_Allowed 2663 then 2664 declare 2665 Blk : constant Entity_Id := 2666 New_Internal_Entity 2667 (E_Block, Current_Scope, Sloc (N), 'B'); 2668 AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); 2669 2670 begin 2671 Set_Is_Abort_Block (N); 2672 2673 Set_Scope (Blk, Current_Scope); 2674 Set_Etype (Blk, Standard_Void_Type); 2675 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); 2676 2677 Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); 2678 Set_At_End_Proc (Handled_Statement_Sequence (N), 2679 New_Occurrence_Of (AUD, Loc)); 2680 2681 -- Present the Abort_Undefer_Direct function to the backend 2682 -- so that it can inline the call to the function. 2683 2684 Add_Inlined_Body (AUD, N); 2685 2686 Expand_At_End_Handler 2687 (Handled_Statement_Sequence (N), Blk); 2688 end; 2689 end if; 2690 2691 -- N has been rewritten to a block statement for which it is 2692 -- known by construction that no checks are necessary: analyze 2693 -- it with all checks suppressed. 2694 2695 Analyze (N, Suppress => All_Checks); 2696 return; 2697 end Tagged_Case; 2698 2699 -- Array types 2700 2701 elsif Is_Array_Type (Typ) then 2702 declare 2703 Actual_Rhs : Node_Id := Rhs; 2704 2705 begin 2706 while Nkind_In (Actual_Rhs, N_Type_Conversion, 2707 N_Qualified_Expression) 2708 loop 2709 Actual_Rhs := Expression (Actual_Rhs); 2710 end loop; 2711 2712 Expand_Assign_Array (N, Actual_Rhs); 2713 return; 2714 end; 2715 2716 -- Record types 2717 2718 elsif Is_Record_Type (Typ) then 2719 Expand_Assign_Record (N); 2720 return; 2721 2722 -- Scalar types. This is where we perform the processing related to the 2723 -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid 2724 -- scalar values. 2725 2726 elsif Is_Scalar_Type (Typ) then 2727 2728 -- Case where right side is known valid 2729 2730 if Expr_Known_Valid (Rhs) then 2731 2732 -- Here the right side is valid, so it is fine. The case to deal 2733 -- with is when the left side is a local variable reference whose 2734 -- value is not currently known to be valid. If this is the case, 2735 -- and the assignment appears in an unconditional context, then 2736 -- we can mark the left side as now being valid if one of these 2737 -- conditions holds: 2738 2739 -- The expression of the right side has Do_Range_Check set so 2740 -- that we know a range check will be performed. Note that it 2741 -- can be the case that a range check is omitted because we 2742 -- make the assumption that we can assume validity for operands 2743 -- appearing in the right side in determining whether a range 2744 -- check is required 2745 2746 -- The subtype of the right side matches the subtype of the 2747 -- left side. In this case, even though we have not checked 2748 -- the range of the right side, we know it is in range of its 2749 -- subtype if the expression is valid. 2750 2751 if Is_Local_Variable_Reference (Lhs) 2752 and then not Is_Known_Valid (Entity (Lhs)) 2753 and then In_Unconditional_Context (N) 2754 then 2755 if Do_Range_Check (Rhs) 2756 or else Etype (Lhs) = Etype (Rhs) 2757 then 2758 Set_Is_Known_Valid (Entity (Lhs), True); 2759 end if; 2760 end if; 2761 2762 -- Case where right side may be invalid in the sense of the RM 2763 -- reference above. The RM does not require that we check for the 2764 -- validity on an assignment, but it does require that the assignment 2765 -- of an invalid value not cause erroneous behavior. 2766 2767 -- The general approach in GNAT is to use the Is_Known_Valid flag 2768 -- to avoid the need for validity checking on assignments. However 2769 -- in some cases, we have to do validity checking in order to make 2770 -- sure that the setting of this flag is correct. 2771 2772 else 2773 -- Validate right side if we are validating copies 2774 2775 if Validity_Checks_On 2776 and then Validity_Check_Copies 2777 then 2778 -- Skip this if left-hand side is an array or record component 2779 -- and elementary component validity checks are suppressed. 2780 2781 if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component) 2782 and then not Validity_Check_Components 2783 then 2784 null; 2785 else 2786 Ensure_Valid (Rhs); 2787 end if; 2788 2789 -- We can propagate this to the left side where appropriate 2790 2791 if Is_Local_Variable_Reference (Lhs) 2792 and then not Is_Known_Valid (Entity (Lhs)) 2793 and then In_Unconditional_Context (N) 2794 then 2795 Set_Is_Known_Valid (Entity (Lhs), True); 2796 end if; 2797 2798 -- Otherwise check to see what should be done 2799 2800 -- If left side is a local variable, then we just set its flag to 2801 -- indicate that its value may no longer be valid, since we are 2802 -- copying a potentially invalid value. 2803 2804 elsif Is_Local_Variable_Reference (Lhs) then 2805 Set_Is_Known_Valid (Entity (Lhs), False); 2806 2807 -- Check for case of a nonlocal variable on the left side which 2808 -- is currently known to be valid. In this case, we simply ensure 2809 -- that the right side is valid. We only play the game of copying 2810 -- validity status for local variables, since we are doing this 2811 -- statically, not by tracing the full flow graph. 2812 2813 elsif Is_Entity_Name (Lhs) 2814 and then Is_Known_Valid (Entity (Lhs)) 2815 then 2816 -- Note: If Validity_Checking mode is set to none, we ignore 2817 -- the Ensure_Valid call so don't worry about that case here. 2818 2819 Ensure_Valid (Rhs); 2820 2821 -- In all other cases, we can safely copy an invalid value without 2822 -- worrying about the status of the left side. Since it is not a 2823 -- variable reference it will not be considered 2824 -- as being known to be valid in any case. 2825 2826 else 2827 null; 2828 end if; 2829 end if; 2830 end if; 2831 2832 exception 2833 when RE_Not_Available => 2834 return; 2835 end Expand_N_Assignment_Statement; 2836 2837 ------------------------------ 2838 -- Expand_N_Block_Statement -- 2839 ------------------------------ 2840 2841 -- Encode entity names defined in block statement 2842 2843 procedure Expand_N_Block_Statement (N : Node_Id) is 2844 begin 2845 Qualify_Entity_Names (N); 2846 end Expand_N_Block_Statement; 2847 2848 ----------------------------- 2849 -- Expand_N_Case_Statement -- 2850 ----------------------------- 2851 2852 procedure Expand_N_Case_Statement (N : Node_Id) is 2853 Loc : constant Source_Ptr := Sloc (N); 2854 Expr : constant Node_Id := Expression (N); 2855 Alt : Node_Id; 2856 Len : Nat; 2857 Cond : Node_Id; 2858 Choice : Node_Id; 2859 Chlist : List_Id; 2860 2861 begin 2862 -- Check for the situation where we know at compile time which branch 2863 -- will be taken. 2864 2865 -- If the value is static but its subtype is predicated and the value 2866 -- does not obey the predicate, the value is marked non-static, and 2867 -- there can be no corresponding static alternative. In that case we 2868 -- replace the case statement with an exception, regardless of whether 2869 -- assertions are enabled or not, unless predicates are ignored. 2870 2871 if Compile_Time_Known_Value (Expr) 2872 and then Has_Predicates (Etype (Expr)) 2873 and then not Predicates_Ignored (Etype (Expr)) 2874 and then not Is_OK_Static_Expression (Expr) 2875 then 2876 Rewrite (N, 2877 Make_Raise_Constraint_Error (Loc, Reason => CE_Invalid_Data)); 2878 Analyze (N); 2879 return; 2880 2881 elsif Compile_Time_Known_Value (Expr) 2882 and then (not Has_Predicates (Etype (Expr)) 2883 or else Is_Static_Expression (Expr)) 2884 then 2885 Alt := Find_Static_Alternative (N); 2886 2887 -- Do not consider controlled objects found in a case statement which 2888 -- actually models a case expression because their early finalization 2889 -- will affect the result of the expression. 2890 2891 if not From_Conditional_Expression (N) then 2892 Process_Statements_For_Controlled_Objects (Alt); 2893 end if; 2894 2895 -- Move statements from this alternative after the case statement. 2896 -- They are already analyzed, so will be skipped by the analyzer. 2897 2898 Insert_List_After (N, Statements (Alt)); 2899 2900 -- That leaves the case statement as a shell. So now we can kill all 2901 -- other alternatives in the case statement. 2902 2903 Kill_Dead_Code (Expression (N)); 2904 2905 declare 2906 Dead_Alt : Node_Id; 2907 2908 begin 2909 -- Loop through case alternatives, skipping pragmas, and skipping 2910 -- the one alternative that we select (and therefore retain). 2911 2912 Dead_Alt := First (Alternatives (N)); 2913 while Present (Dead_Alt) loop 2914 if Dead_Alt /= Alt 2915 and then Nkind (Dead_Alt) = N_Case_Statement_Alternative 2916 then 2917 Kill_Dead_Code (Statements (Dead_Alt), Warn_On_Deleted_Code); 2918 end if; 2919 2920 Next (Dead_Alt); 2921 end loop; 2922 end; 2923 2924 Rewrite (N, Make_Null_Statement (Loc)); 2925 return; 2926 end if; 2927 2928 -- Here if the choice is not determined at compile time 2929 2930 declare 2931 Last_Alt : constant Node_Id := Last (Alternatives (N)); 2932 2933 Others_Present : Boolean; 2934 Others_Node : Node_Id; 2935 2936 Then_Stms : List_Id; 2937 Else_Stms : List_Id; 2938 2939 begin 2940 if Nkind (First (Discrete_Choices (Last_Alt))) = N_Others_Choice then 2941 Others_Present := True; 2942 Others_Node := Last_Alt; 2943 else 2944 Others_Present := False; 2945 end if; 2946 2947 -- First step is to worry about possible invalid argument. The RM 2948 -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is 2949 -- outside the base range), then Constraint_Error must be raised. 2950 2951 -- Case of validity check required (validity checks are on, the 2952 -- expression is not known to be valid, and the case statement 2953 -- comes from source -- no need to validity check internally 2954 -- generated case statements). 2955 2956 if Validity_Check_Default 2957 and then not Predicates_Ignored (Etype (Expr)) 2958 then 2959 Ensure_Valid (Expr); 2960 end if; 2961 2962 -- If there is only a single alternative, just replace it with the 2963 -- sequence of statements since obviously that is what is going to 2964 -- be executed in all cases. 2965 2966 Len := List_Length (Alternatives (N)); 2967 2968 if Len = 1 then 2969 2970 -- We still need to evaluate the expression if it has any side 2971 -- effects. 2972 2973 Remove_Side_Effects (Expression (N)); 2974 Alt := First (Alternatives (N)); 2975 2976 -- Do not consider controlled objects found in a case statement 2977 -- which actually models a case expression because their early 2978 -- finalization will affect the result of the expression. 2979 2980 if not From_Conditional_Expression (N) then 2981 Process_Statements_For_Controlled_Objects (Alt); 2982 end if; 2983 2984 Insert_List_After (N, Statements (Alt)); 2985 2986 -- That leaves the case statement as a shell. The alternative that 2987 -- will be executed is reset to a null list. So now we can kill 2988 -- the entire case statement. 2989 2990 Kill_Dead_Code (Expression (N)); 2991 Rewrite (N, Make_Null_Statement (Loc)); 2992 return; 2993 2994 -- An optimization. If there are only two alternatives, and only 2995 -- a single choice, then rewrite the whole case statement as an 2996 -- if statement, since this can result in subsequent optimizations. 2997 -- This helps not only with case statements in the source of a 2998 -- simple form, but also with generated code (discriminant check 2999 -- functions in particular). 3000 3001 -- Note: it is OK to do this before expanding out choices for any 3002 -- static predicates, since the if statement processing will handle 3003 -- the static predicate case fine. 3004 3005 elsif Len = 2 then 3006 Chlist := Discrete_Choices (First (Alternatives (N))); 3007 3008 if List_Length (Chlist) = 1 then 3009 Choice := First (Chlist); 3010 3011 Then_Stms := Statements (First (Alternatives (N))); 3012 Else_Stms := Statements (Last (Alternatives (N))); 3013 3014 -- For TRUE, generate "expression", not expression = true 3015 3016 if Nkind (Choice) = N_Identifier 3017 and then Entity (Choice) = Standard_True 3018 then 3019 Cond := Expression (N); 3020 3021 -- For FALSE, generate "expression" and switch then/else 3022 3023 elsif Nkind (Choice) = N_Identifier 3024 and then Entity (Choice) = Standard_False 3025 then 3026 Cond := Expression (N); 3027 Else_Stms := Statements (First (Alternatives (N))); 3028 Then_Stms := Statements (Last (Alternatives (N))); 3029 3030 -- For a range, generate "expression in range" 3031 3032 elsif Nkind (Choice) = N_Range 3033 or else (Nkind (Choice) = N_Attribute_Reference 3034 and then Attribute_Name (Choice) = Name_Range) 3035 or else (Is_Entity_Name (Choice) 3036 and then Is_Type (Entity (Choice))) 3037 then 3038 Cond := 3039 Make_In (Loc, 3040 Left_Opnd => Expression (N), 3041 Right_Opnd => Relocate_Node (Choice)); 3042 3043 -- A subtype indication is not a legal operator in a membership 3044 -- test, so retrieve its range. 3045 3046 elsif Nkind (Choice) = N_Subtype_Indication then 3047 Cond := 3048 Make_In (Loc, 3049 Left_Opnd => Expression (N), 3050 Right_Opnd => 3051 Relocate_Node 3052 (Range_Expression (Constraint (Choice)))); 3053 3054 -- For any other subexpression "expression = value" 3055 3056 else 3057 Cond := 3058 Make_Op_Eq (Loc, 3059 Left_Opnd => Expression (N), 3060 Right_Opnd => Relocate_Node (Choice)); 3061 end if; 3062 3063 -- Now rewrite the case as an IF 3064 3065 Rewrite (N, 3066 Make_If_Statement (Loc, 3067 Condition => Cond, 3068 Then_Statements => Then_Stms, 3069 Else_Statements => Else_Stms)); 3070 Analyze (N); 3071 return; 3072 end if; 3073 end if; 3074 3075 -- If the last alternative is not an Others choice, replace it with 3076 -- an N_Others_Choice. Note that we do not bother to call Analyze on 3077 -- the modified case statement, since it's only effect would be to 3078 -- compute the contents of the Others_Discrete_Choices which is not 3079 -- needed by the back end anyway. 3080 3081 -- The reason for this is that the back end always needs some default 3082 -- for a switch, so if we have not supplied one in the processing 3083 -- above for validity checking, then we need to supply one here. 3084 3085 if not Others_Present then 3086 Others_Node := Make_Others_Choice (Sloc (Last_Alt)); 3087 3088 -- If Predicates_Ignored is true the value does not satisfy the 3089 -- predicate, and there is no Others choice, Constraint_Error 3090 -- must be raised (4.5.7 (21/3)). 3091 3092 if Predicates_Ignored (Etype (Expr)) then 3093 declare 3094 Except : constant Node_Id := 3095 Make_Raise_Constraint_Error (Loc, 3096 Reason => CE_Invalid_Data); 3097 New_Alt : constant Node_Id := 3098 Make_Case_Statement_Alternative (Loc, 3099 Discrete_Choices => New_List ( 3100 Make_Others_Choice (Loc)), 3101 Statements => New_List (Except)); 3102 3103 begin 3104 Append (New_Alt, Alternatives (N)); 3105 Analyze_And_Resolve (Except); 3106 end; 3107 3108 else 3109 Set_Others_Discrete_Choices 3110 (Others_Node, Discrete_Choices (Last_Alt)); 3111 Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); 3112 end if; 3113 3114 end if; 3115 3116 -- Deal with possible declarations of controlled objects, and also 3117 -- with rewriting choice sequences for static predicate references. 3118 3119 Alt := First_Non_Pragma (Alternatives (N)); 3120 while Present (Alt) loop 3121 3122 -- Do not consider controlled objects found in a case statement 3123 -- which actually models a case expression because their early 3124 -- finalization will affect the result of the expression. 3125 3126 if not From_Conditional_Expression (N) then 3127 Process_Statements_For_Controlled_Objects (Alt); 3128 end if; 3129 3130 if Has_SP_Choice (Alt) then 3131 Expand_Static_Predicates_In_Choices (Alt); 3132 end if; 3133 3134 Next_Non_Pragma (Alt); 3135 end loop; 3136 end; 3137 end Expand_N_Case_Statement; 3138 3139 ----------------------------- 3140 -- Expand_N_Exit_Statement -- 3141 ----------------------------- 3142 3143 -- The only processing required is to deal with a possible C/Fortran 3144 -- boolean value used as the condition for the exit statement. 3145 3146 procedure Expand_N_Exit_Statement (N : Node_Id) is 3147 begin 3148 Adjust_Condition (Condition (N)); 3149 end Expand_N_Exit_Statement; 3150 3151 ---------------------------------- 3152 -- Expand_Formal_Container_Loop -- 3153 ---------------------------------- 3154 3155 procedure Expand_Formal_Container_Loop (N : Node_Id) is 3156 Loc : constant Source_Ptr := Sloc (N); 3157 Isc : constant Node_Id := Iteration_Scheme (N); 3158 I_Spec : constant Node_Id := Iterator_Specification (Isc); 3159 Cursor : constant Entity_Id := Defining_Identifier (I_Spec); 3160 Container : constant Node_Id := Entity (Name (I_Spec)); 3161 Stats : constant List_Id := Statements (N); 3162 3163 Advance : Node_Id; 3164 Init_Decl : Node_Id; 3165 Init_Name : Entity_Id; 3166 New_Loop : Node_Id; 3167 3168 begin 3169 -- The expansion of a formal container loop resembles the one for Ada 3170 -- containers. The only difference is that the primitives mention the 3171 -- domain of iteration explicitly, and function First applied to the 3172 -- container yields a cursor directly. 3173 3174 -- Cursor : Cursor_type := First (Container); 3175 -- while Has_Element (Cursor, Container) loop 3176 -- <original loop statements> 3177 -- Cursor := Next (Container, Cursor); 3178 -- end loop; 3179 3180 Build_Formal_Container_Iteration 3181 (N, Container, Cursor, Init_Decl, Advance, New_Loop); 3182 3183 Append_To (Stats, Advance); 3184 3185 -- Build a block to capture declaration of the cursor 3186 3187 Rewrite (N, 3188 Make_Block_Statement (Loc, 3189 Declarations => New_List (Init_Decl), 3190 Handled_Statement_Sequence => 3191 Make_Handled_Sequence_Of_Statements (Loc, 3192 Statements => New_List (New_Loop)))); 3193 3194 -- The loop parameter is declared by an object declaration, but within 3195 -- the loop we must prevent user assignments to it, so we analyze the 3196 -- declaration and reset the entity kind, before analyzing the rest of 3197 -- the loop. 3198 3199 Analyze (Init_Decl); 3200 Init_Name := Defining_Identifier (Init_Decl); 3201 Set_Ekind (Init_Name, E_Loop_Parameter); 3202 3203 -- The cursor was marked as a loop parameter to prevent user assignments 3204 -- to it, however this renders the advancement step illegal as it is not 3205 -- possible to change the value of a constant. Flag the advancement step 3206 -- as a legal form of assignment to remedy this side effect. 3207 3208 Set_Assignment_OK (Name (Advance)); 3209 Analyze (N); 3210 3211 -- Because we have to analyze the initial declaration of the loop 3212 -- parameter multiple times its scope is incorrectly set at this point 3213 -- to the one surrounding the block statement - so set the scope 3214 -- manually to be the actual block statement, and indicate that it is 3215 -- not visible after the block has been analyzed. 3216 3217 Set_Scope (Init_Name, Entity (Identifier (N))); 3218 Set_Is_Immediately_Visible (Init_Name, False); 3219 end Expand_Formal_Container_Loop; 3220 3221 ------------------------------------------ 3222 -- Expand_Formal_Container_Element_Loop -- 3223 ------------------------------------------ 3224 3225 procedure Expand_Formal_Container_Element_Loop (N : Node_Id) is 3226 Loc : constant Source_Ptr := Sloc (N); 3227 Isc : constant Node_Id := Iteration_Scheme (N); 3228 I_Spec : constant Node_Id := Iterator_Specification (Isc); 3229 Element : constant Entity_Id := Defining_Identifier (I_Spec); 3230 Container : constant Node_Id := Entity (Name (I_Spec)); 3231 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 3232 Stats : constant List_Id := Statements (N); 3233 3234 Cursor : constant Entity_Id := 3235 Make_Defining_Identifier (Loc, 3236 Chars => New_External_Name (Chars (Element), 'C')); 3237 Elmt_Decl : Node_Id; 3238 Elmt_Ref : Node_Id; 3239 3240 Element_Op : constant Entity_Id := 3241 Get_Iterable_Type_Primitive (Container_Typ, Name_Element); 3242 3243 Advance : Node_Id; 3244 Init : Node_Id; 3245 New_Loop : Node_Id; 3246 3247 begin 3248 -- For an element iterator, the Element aspect must be present, 3249 -- (this is checked during analysis) and the expansion takes the form: 3250 3251 -- Cursor : Cursor_Type := First (Container); 3252 -- Elmt : Element_Type; 3253 -- while Has_Element (Cursor, Container) loop 3254 -- Elmt := Element (Container, Cursor); 3255 -- <original loop statements> 3256 -- Cursor := Next (Container, Cursor); 3257 -- end loop; 3258 3259 -- However this expansion is not legal if the element is indefinite. 3260 -- In that case we create a block to hold a variable declaration 3261 -- initialized with a call to Element, and generate: 3262 3263 -- Cursor : Cursor_Type := First (Container); 3264 -- while Has_Element (Cursor, Container) loop 3265 -- declare 3266 -- Elmt : Element_Type := Element (Container, Cursor); 3267 -- begin 3268 -- <original loop statements> 3269 -- Cursor := Next (Container, Cursor); 3270 -- end; 3271 -- end loop; 3272 3273 Build_Formal_Container_Iteration 3274 (N, Container, Cursor, Init, Advance, New_Loop); 3275 Append_To (Stats, Advance); 3276 3277 Set_Ekind (Cursor, E_Variable); 3278 Insert_Action (N, Init); 3279 3280 -- The loop parameter is declared by an object declaration, but within 3281 -- the loop we must prevent user assignments to it; the following flag 3282 -- accomplishes that. 3283 3284 Set_Is_Loop_Parameter (Element); 3285 3286 -- Declaration for Element 3287 3288 Elmt_Decl := 3289 Make_Object_Declaration (Loc, 3290 Defining_Identifier => Element, 3291 Object_Definition => New_Occurrence_Of (Etype (Element_Op), Loc)); 3292 3293 if not Is_Constrained (Etype (Element_Op)) then 3294 Set_Expression (Elmt_Decl, 3295 Make_Function_Call (Loc, 3296 Name => New_Occurrence_Of (Element_Op, Loc), 3297 Parameter_Associations => New_List ( 3298 Convert_To_Iterable_Type (Container, Loc), 3299 New_Occurrence_Of (Cursor, Loc)))); 3300 3301 Set_Statements (New_Loop, 3302 New_List 3303 (Make_Block_Statement (Loc, 3304 Declarations => New_List (Elmt_Decl), 3305 Handled_Statement_Sequence => 3306 Make_Handled_Sequence_Of_Statements (Loc, 3307 Statements => Stats)))); 3308 3309 else 3310 Elmt_Ref := 3311 Make_Assignment_Statement (Loc, 3312 Name => New_Occurrence_Of (Element, Loc), 3313 Expression => 3314 Make_Function_Call (Loc, 3315 Name => New_Occurrence_Of (Element_Op, Loc), 3316 Parameter_Associations => New_List ( 3317 Convert_To_Iterable_Type (Container, Loc), 3318 New_Occurrence_Of (Cursor, Loc)))); 3319 3320 Prepend (Elmt_Ref, Stats); 3321 3322 -- The element is assignable in the expanded code 3323 3324 Set_Assignment_OK (Name (Elmt_Ref)); 3325 3326 -- The loop is rewritten as a block, to hold the element declaration 3327 3328 New_Loop := 3329 Make_Block_Statement (Loc, 3330 Declarations => New_List (Elmt_Decl), 3331 Handled_Statement_Sequence => 3332 Make_Handled_Sequence_Of_Statements (Loc, 3333 Statements => New_List (New_Loop))); 3334 end if; 3335 3336 -- The element is only modified in expanded code, so it appears as 3337 -- unassigned to the warning machinery. We must suppress this spurious 3338 -- warning explicitly. 3339 3340 Set_Warnings_Off (Element); 3341 3342 Rewrite (N, New_Loop); 3343 Analyze (N); 3344 end Expand_Formal_Container_Element_Loop; 3345 3346 ----------------------------- 3347 -- Expand_N_Goto_Statement -- 3348 ----------------------------- 3349 3350 -- Add poll before goto if polling active 3351 3352 procedure Expand_N_Goto_Statement (N : Node_Id) is 3353 begin 3354 Generate_Poll_Call (N); 3355 end Expand_N_Goto_Statement; 3356 3357 --------------------------- 3358 -- Expand_N_If_Statement -- 3359 --------------------------- 3360 3361 -- First we deal with the case of C and Fortran convention boolean values, 3362 -- with zero/non-zero semantics. 3363 3364 -- Second, we deal with the obvious rewriting for the cases where the 3365 -- condition of the IF is known at compile time to be True or False. 3366 3367 -- Third, we remove elsif parts which have non-empty Condition_Actions and 3368 -- rewrite as independent if statements. For example: 3369 3370 -- if x then xs 3371 -- elsif y then ys 3372 -- ... 3373 -- end if; 3374 3375 -- becomes 3376 -- 3377 -- if x then xs 3378 -- else 3379 -- <<condition actions of y>> 3380 -- if y then ys 3381 -- ... 3382 -- end if; 3383 -- end if; 3384 3385 -- This rewriting is needed if at least one elsif part has a non-empty 3386 -- Condition_Actions list. We also do the same processing if there is a 3387 -- constant condition in an elsif part (in conjunction with the first 3388 -- processing step mentioned above, for the recursive call made to deal 3389 -- with the created inner if, this deals with properly optimizing the 3390 -- cases of constant elsif conditions). 3391 3392 procedure Expand_N_If_Statement (N : Node_Id) is 3393 Loc : constant Source_Ptr := Sloc (N); 3394 Hed : Node_Id; 3395 E : Node_Id; 3396 New_If : Node_Id; 3397 3398 Warn_If_Deleted : constant Boolean := 3399 Warn_On_Deleted_Code and then Comes_From_Source (N); 3400 -- Indicates whether we want warnings when we delete branches of the 3401 -- if statement based on constant condition analysis. We never want 3402 -- these warnings for expander generated code. 3403 3404 begin 3405 -- Do not consider controlled objects found in an if statement which 3406 -- actually models an if expression because their early finalization 3407 -- will affect the result of the expression. 3408 3409 if not From_Conditional_Expression (N) then 3410 Process_Statements_For_Controlled_Objects (N); 3411 end if; 3412 3413 Adjust_Condition (Condition (N)); 3414 3415 -- The following loop deals with constant conditions for the IF. We 3416 -- need a loop because as we eliminate False conditions, we grab the 3417 -- first elsif condition and use it as the primary condition. 3418 3419 while Compile_Time_Known_Value (Condition (N)) loop 3420 3421 -- If condition is True, we can simply rewrite the if statement now 3422 -- by replacing it by the series of then statements. 3423 3424 if Is_True (Expr_Value (Condition (N))) then 3425 3426 -- All the else parts can be killed 3427 3428 Kill_Dead_Code (Elsif_Parts (N), Warn_If_Deleted); 3429 Kill_Dead_Code (Else_Statements (N), Warn_If_Deleted); 3430 3431 Hed := Remove_Head (Then_Statements (N)); 3432 Insert_List_After (N, Then_Statements (N)); 3433 Rewrite (N, Hed); 3434 return; 3435 3436 -- If condition is False, then we can delete the condition and 3437 -- the Then statements 3438 3439 else 3440 -- We do not delete the condition if constant condition warnings 3441 -- are enabled, since otherwise we end up deleting the desired 3442 -- warning. Of course the backend will get rid of this True/False 3443 -- test anyway, so nothing is lost here. 3444 3445 if not Constant_Condition_Warnings then 3446 Kill_Dead_Code (Condition (N)); 3447 end if; 3448 3449 Kill_Dead_Code (Then_Statements (N), Warn_If_Deleted); 3450 3451 -- If there are no elsif statements, then we simply replace the 3452 -- entire if statement by the sequence of else statements. 3453 3454 if No (Elsif_Parts (N)) then 3455 if No (Else_Statements (N)) 3456 or else Is_Empty_List (Else_Statements (N)) 3457 then 3458 Rewrite (N, 3459 Make_Null_Statement (Sloc (N))); 3460 else 3461 Hed := Remove_Head (Else_Statements (N)); 3462 Insert_List_After (N, Else_Statements (N)); 3463 Rewrite (N, Hed); 3464 end if; 3465 3466 return; 3467 3468 -- If there are elsif statements, the first of them becomes the 3469 -- if/then section of the rebuilt if statement This is the case 3470 -- where we loop to reprocess this copied condition. 3471 3472 else 3473 Hed := Remove_Head (Elsif_Parts (N)); 3474 Insert_Actions (N, Condition_Actions (Hed)); 3475 Set_Condition (N, Condition (Hed)); 3476 Set_Then_Statements (N, Then_Statements (Hed)); 3477 3478 -- Hed might have been captured as the condition determining 3479 -- the current value for an entity. Now it is detached from 3480 -- the tree, so a Current_Value pointer in the condition might 3481 -- need to be updated. 3482 3483 Set_Current_Value_Condition (N); 3484 3485 if Is_Empty_List (Elsif_Parts (N)) then 3486 Set_Elsif_Parts (N, No_List); 3487 end if; 3488 end if; 3489 end if; 3490 end loop; 3491 3492 -- Loop through elsif parts, dealing with constant conditions and 3493 -- possible condition actions that are present. 3494 3495 if Present (Elsif_Parts (N)) then 3496 E := First (Elsif_Parts (N)); 3497 while Present (E) loop 3498 3499 -- Do not consider controlled objects found in an if statement 3500 -- which actually models an if expression because their early 3501 -- finalization will affect the result of the expression. 3502 3503 if not From_Conditional_Expression (N) then 3504 Process_Statements_For_Controlled_Objects (E); 3505 end if; 3506 3507 Adjust_Condition (Condition (E)); 3508 3509 -- If there are condition actions, then rewrite the if statement 3510 -- as indicated above. We also do the same rewrite for a True or 3511 -- False condition. The further processing of this constant 3512 -- condition is then done by the recursive call to expand the 3513 -- newly created if statement 3514 3515 if Present (Condition_Actions (E)) 3516 or else Compile_Time_Known_Value (Condition (E)) 3517 then 3518 New_If := 3519 Make_If_Statement (Sloc (E), 3520 Condition => Condition (E), 3521 Then_Statements => Then_Statements (E), 3522 Elsif_Parts => No_List, 3523 Else_Statements => Else_Statements (N)); 3524 3525 -- Elsif parts for new if come from remaining elsif's of parent 3526 3527 while Present (Next (E)) loop 3528 if No (Elsif_Parts (New_If)) then 3529 Set_Elsif_Parts (New_If, New_List); 3530 end if; 3531 3532 Append (Remove_Next (E), Elsif_Parts (New_If)); 3533 end loop; 3534 3535 Set_Else_Statements (N, New_List (New_If)); 3536 3537 if Present (Condition_Actions (E)) then 3538 Insert_List_Before (New_If, Condition_Actions (E)); 3539 end if; 3540 3541 Remove (E); 3542 3543 if Is_Empty_List (Elsif_Parts (N)) then 3544 Set_Elsif_Parts (N, No_List); 3545 end if; 3546 3547 Analyze (New_If); 3548 3549 -- Note this is not an implicit if statement, since it is part 3550 -- of an explicit if statement in the source (or of an implicit 3551 -- if statement that has already been tested). We set the flag 3552 -- after calling Analyze to avoid generating extra warnings 3553 -- specific to pure if statements, however (see 3554 -- Sem_Ch5.Analyze_If_Statement). 3555 3556 Set_Comes_From_Source (New_If, Comes_From_Source (N)); 3557 return; 3558 3559 -- No special processing for that elsif part, move to next 3560 3561 else 3562 Next (E); 3563 end if; 3564 end loop; 3565 end if; 3566 3567 -- Some more optimizations applicable if we still have an IF statement 3568 3569 if Nkind (N) /= N_If_Statement then 3570 return; 3571 end if; 3572 3573 -- Another optimization, special cases that can be simplified 3574 3575 -- if expression then 3576 -- return true; 3577 -- else 3578 -- return false; 3579 -- end if; 3580 3581 -- can be changed to: 3582 3583 -- return expression; 3584 3585 -- and 3586 3587 -- if expression then 3588 -- return false; 3589 -- else 3590 -- return true; 3591 -- end if; 3592 3593 -- can be changed to: 3594 3595 -- return not (expression); 3596 3597 -- Only do these optimizations if we are at least at -O1 level and 3598 -- do not do them if control flow optimizations are suppressed. 3599 3600 if Optimization_Level > 0 3601 and then not Opt.Suppress_Control_Flow_Optimizations 3602 then 3603 if Nkind (N) = N_If_Statement 3604 and then No (Elsif_Parts (N)) 3605 and then Present (Else_Statements (N)) 3606 and then List_Length (Then_Statements (N)) = 1 3607 and then List_Length (Else_Statements (N)) = 1 3608 then 3609 declare 3610 Then_Stm : constant Node_Id := First (Then_Statements (N)); 3611 Else_Stm : constant Node_Id := First (Else_Statements (N)); 3612 3613 begin 3614 if Nkind (Then_Stm) = N_Simple_Return_Statement 3615 and then 3616 Nkind (Else_Stm) = N_Simple_Return_Statement 3617 then 3618 declare 3619 Then_Expr : constant Node_Id := Expression (Then_Stm); 3620 Else_Expr : constant Node_Id := Expression (Else_Stm); 3621 3622 begin 3623 if Nkind (Then_Expr) = N_Identifier 3624 and then 3625 Nkind (Else_Expr) = N_Identifier 3626 then 3627 if Entity (Then_Expr) = Standard_True 3628 and then Entity (Else_Expr) = Standard_False 3629 then 3630 Rewrite (N, 3631 Make_Simple_Return_Statement (Loc, 3632 Expression => Relocate_Node (Condition (N)))); 3633 Analyze (N); 3634 return; 3635 3636 elsif Entity (Then_Expr) = Standard_False 3637 and then Entity (Else_Expr) = Standard_True 3638 then 3639 Rewrite (N, 3640 Make_Simple_Return_Statement (Loc, 3641 Expression => 3642 Make_Op_Not (Loc, 3643 Right_Opnd => 3644 Relocate_Node (Condition (N))))); 3645 Analyze (N); 3646 return; 3647 end if; 3648 end if; 3649 end; 3650 end if; 3651 end; 3652 end if; 3653 end if; 3654 end Expand_N_If_Statement; 3655 3656 -------------------------- 3657 -- Expand_Iterator_Loop -- 3658 -------------------------- 3659 3660 procedure Expand_Iterator_Loop (N : Node_Id) is 3661 Isc : constant Node_Id := Iteration_Scheme (N); 3662 I_Spec : constant Node_Id := Iterator_Specification (Isc); 3663 3664 Container : constant Node_Id := Name (I_Spec); 3665 Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 3666 3667 begin 3668 -- Processing for arrays 3669 3670 if Is_Array_Type (Container_Typ) then 3671 pragma Assert (Of_Present (I_Spec)); 3672 Expand_Iterator_Loop_Over_Array (N); 3673 3674 elsif Has_Aspect (Container_Typ, Aspect_Iterable) then 3675 if Of_Present (I_Spec) then 3676 Expand_Formal_Container_Element_Loop (N); 3677 else 3678 Expand_Formal_Container_Loop (N); 3679 end if; 3680 3681 -- Processing for containers 3682 3683 else 3684 Expand_Iterator_Loop_Over_Container 3685 (N, Isc, I_Spec, Container, Container_Typ); 3686 end if; 3687 end Expand_Iterator_Loop; 3688 3689 ------------------------------------- 3690 -- Expand_Iterator_Loop_Over_Array -- 3691 ------------------------------------- 3692 3693 procedure Expand_Iterator_Loop_Over_Array (N : Node_Id) is 3694 Isc : constant Node_Id := Iteration_Scheme (N); 3695 I_Spec : constant Node_Id := Iterator_Specification (Isc); 3696 Array_Node : constant Node_Id := Name (I_Spec); 3697 Array_Typ : constant Entity_Id := Base_Type (Etype (Array_Node)); 3698 Array_Dim : constant Pos := Number_Dimensions (Array_Typ); 3699 Id : constant Entity_Id := Defining_Identifier (I_Spec); 3700 Loc : constant Source_Ptr := Sloc (Isc); 3701 Stats : constant List_Id := Statements (N); 3702 Core_Loop : Node_Id; 3703 Dim1 : Int; 3704 Ind_Comp : Node_Id; 3705 Iterator : Entity_Id; 3706 3707 -- Start of processing for Expand_Iterator_Loop_Over_Array 3708 3709 begin 3710 -- for Element of Array loop 3711 3712 -- It requires an internally generated cursor to iterate over the array 3713 3714 pragma Assert (Of_Present (I_Spec)); 3715 3716 Iterator := Make_Temporary (Loc, 'C'); 3717 3718 -- Generate: 3719 -- Element : Component_Type renames Array (Iterator); 3720 -- Iterator is the index value, or a list of index values 3721 -- in the case of a multidimensional array. 3722 3723 Ind_Comp := 3724 Make_Indexed_Component (Loc, 3725 Prefix => New_Copy_Tree (Array_Node), 3726 Expressions => New_List (New_Occurrence_Of (Iterator, Loc))); 3727 3728 -- Propagate the original node to the copy since the analysis of the 3729 -- following object renaming declaration relies on the original node. 3730 3731 Set_Original_Node (Prefix (Ind_Comp), Original_Node (Array_Node)); 3732 3733 Prepend_To (Stats, 3734 Make_Object_Renaming_Declaration (Loc, 3735 Defining_Identifier => Id, 3736 Subtype_Mark => 3737 New_Occurrence_Of (Component_Type (Array_Typ), Loc), 3738 Name => Ind_Comp)); 3739 3740 -- Mark the loop variable as needing debug info, so that expansion 3741 -- of the renaming will result in Materialize_Entity getting set via 3742 -- Debug_Renaming_Declaration. (This setting is needed here because 3743 -- the setting in Freeze_Entity comes after the expansion, which is 3744 -- too late. ???) 3745 3746 Set_Debug_Info_Needed (Id); 3747 3748 -- Generate: 3749 3750 -- for Iterator in [reverse] Array'Range (Array_Dim) loop 3751 -- Element : Component_Type renames Array (Iterator); 3752 -- <original loop statements> 3753 -- end loop; 3754 3755 -- If this is an iteration over a multidimensional array, the 3756 -- innermost loop is over the last dimension in Ada, and over 3757 -- the first dimension in Fortran. 3758 3759 if Convention (Array_Typ) = Convention_Fortran then 3760 Dim1 := 1; 3761 else 3762 Dim1 := Array_Dim; 3763 end if; 3764 3765 Core_Loop := 3766 Make_Loop_Statement (Sloc (N), 3767 Iteration_Scheme => 3768 Make_Iteration_Scheme (Loc, 3769 Loop_Parameter_Specification => 3770 Make_Loop_Parameter_Specification (Loc, 3771 Defining_Identifier => Iterator, 3772 Discrete_Subtype_Definition => 3773 Make_Attribute_Reference (Loc, 3774 Prefix => New_Copy_Tree (Array_Node), 3775 Attribute_Name => Name_Range, 3776 Expressions => New_List ( 3777 Make_Integer_Literal (Loc, Dim1))), 3778 Reverse_Present => Reverse_Present (I_Spec))), 3779 Statements => Stats, 3780 End_Label => Empty); 3781 3782 -- Processing for multidimensional array. The body of each loop is 3783 -- a loop over a previous dimension, going in decreasing order in Ada 3784 -- and in increasing order in Fortran. 3785 3786 if Array_Dim > 1 then 3787 for Dim in 1 .. Array_Dim - 1 loop 3788 if Convention (Array_Typ) = Convention_Fortran then 3789 Dim1 := Dim + 1; 3790 else 3791 Dim1 := Array_Dim - Dim; 3792 end if; 3793 3794 Iterator := Make_Temporary (Loc, 'C'); 3795 3796 -- Generate the dimension loops starting from the innermost one 3797 3798 -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop 3799 -- <core loop> 3800 -- end loop; 3801 3802 Core_Loop := 3803 Make_Loop_Statement (Sloc (N), 3804 Iteration_Scheme => 3805 Make_Iteration_Scheme (Loc, 3806 Loop_Parameter_Specification => 3807 Make_Loop_Parameter_Specification (Loc, 3808 Defining_Identifier => Iterator, 3809 Discrete_Subtype_Definition => 3810 Make_Attribute_Reference (Loc, 3811 Prefix => New_Copy_Tree (Array_Node), 3812 Attribute_Name => Name_Range, 3813 Expressions => New_List ( 3814 Make_Integer_Literal (Loc, Dim1))), 3815 Reverse_Present => Reverse_Present (I_Spec))), 3816 Statements => New_List (Core_Loop), 3817 End_Label => Empty); 3818 3819 -- Update the previously created object renaming declaration with 3820 -- the new iterator, by adding the index of the next loop to the 3821 -- indexed component, in the order that corresponds to the 3822 -- convention. 3823 3824 if Convention (Array_Typ) = Convention_Fortran then 3825 Append_To (Expressions (Ind_Comp), 3826 New_Occurrence_Of (Iterator, Loc)); 3827 else 3828 Prepend_To (Expressions (Ind_Comp), 3829 New_Occurrence_Of (Iterator, Loc)); 3830 end if; 3831 end loop; 3832 end if; 3833 3834 -- Inherit the loop identifier from the original loop. This ensures that 3835 -- the scope stack is consistent after the rewriting. 3836 3837 if Present (Identifier (N)) then 3838 Set_Identifier (Core_Loop, Relocate_Node (Identifier (N))); 3839 end if; 3840 3841 Rewrite (N, Core_Loop); 3842 Analyze (N); 3843 end Expand_Iterator_Loop_Over_Array; 3844 3845 ----------------------------------------- 3846 -- Expand_Iterator_Loop_Over_Container -- 3847 ----------------------------------------- 3848 3849 -- For a 'for ... in' loop, such as: 3850 3851 -- for Cursor in Iterator_Function (...) loop 3852 -- ... 3853 -- end loop; 3854 3855 -- we generate: 3856 3857 -- Iter : Iterator_Type := Iterator_Function (...); 3858 -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse" 3859 -- while Has_Element (Cursor) loop 3860 -- ... 3861 -- 3862 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse" 3863 -- end loop; 3864 3865 -- For a 'for ... of' loop, such as: 3866 3867 -- for X of Container loop 3868 -- ... 3869 -- end loop; 3870 3871 -- the RM implies the generation of: 3872 3873 -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator 3874 -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse" 3875 -- while Has_Element (Cursor) loop 3876 -- declare 3877 -- X : Element_Type renames Element (Cursor).Element.all; 3878 -- -- or Constant_Element 3879 -- begin 3880 -- ... 3881 -- end; 3882 -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse" 3883 -- end loop; 3884 3885 -- In the general case, we do what the RM says. However, the operations 3886 -- Element and Iter.Next are slow, which is bad inside a loop, because they 3887 -- involve dispatching via interfaces, secondary stack manipulation, 3888 -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the 3889 -- predefined containers, we use an equivalent but optimized expansion. 3890 3891 -- In the optimized case, we make use of these: 3892 3893 -- procedure Next (Position : in out Cursor); -- instead of Iter.Next 3894 3895 -- function Pseudo_Reference 3896 -- (Container : aliased Vector'Class) return Reference_Control_Type; 3897 3898 -- type Element_Access is access all Element_Type; 3899 3900 -- function Get_Element_Access 3901 -- (Position : Cursor) return not null Element_Access; 3902 3903 -- Next is declared in the visible part of the container packages. 3904 -- The other three are added in the private part. (We're not supposed to 3905 -- pollute the namespace for clients. The compiler has no trouble breaking 3906 -- privacy to call things in the private part of an instance.) 3907 3908 -- Source: 3909 3910 -- for X of My_Vector loop 3911 -- X.Count := X.Count + 1; 3912 -- ... 3913 -- end loop; 3914 3915 -- The compiler will generate: 3916 3917 -- Iter : Reversible_Iterator'Class := Iterate (My_Vector); 3918 -- -- Reversible_Iterator is an interface. Iterate is the 3919 -- -- Default_Iterator aspect of Vector. This increments Lock, 3920 -- -- disallowing tampering with cursors. Unfortunately, it does not 3921 -- -- increment Busy. The result of Iterate is Limited_Controlled; 3922 -- -- finalization will decrement Lock. This is a build-in-place 3923 -- -- dispatching call to Iterate. 3924 3925 -- Cur : Cursor := First (Iter); -- or Last 3926 -- -- Dispatching call via interface. 3927 3928 -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector); 3929 -- -- Pseudo_Reference increments Busy, to detect tampering with 3930 -- -- elements, as required by RM. Also redundantly increment 3931 -- -- Lock. Finalization of Control will decrement both Busy and 3932 -- -- Lock. Pseudo_Reference returns a record containing a pointer to 3933 -- -- My_Vector, used by Finalize. 3934 -- -- 3935 -- -- Control is not used below, except to finalize it -- it's purely 3936 -- -- an RAII thing. This is needed because we are eliminating the 3937 -- -- call to Reference within the loop. 3938 3939 -- while Has_Element (Cur) loop 3940 -- declare 3941 -- X : My_Element renames Get_Element_Access (Cur).all; 3942 -- -- Get_Element_Access returns a pointer to the element 3943 -- -- designated by Cur. No dispatching here, and no horsing 3944 -- -- around with access discriminants. This is instead of the 3945 -- -- existing 3946 -- -- 3947 -- -- X : My_Element renames Reference (Cur).Element.all; 3948 -- -- 3949 -- -- which creates a controlled object. 3950 -- begin 3951 -- -- Any attempt to tamper with My_Vector here in the loop 3952 -- -- will correctly raise Program_Error, because of the 3953 -- -- Control. 3954 -- 3955 -- X.Count := X.Count + 1; 3956 -- ... 3957 -- 3958 -- Next (Cur); -- or Prev 3959 -- -- This is instead of "Cur := Next (Iter, Cur);" 3960 -- end; 3961 -- -- No finalization here 3962 -- end loop; 3963 -- Finalize Iter and Control here, decrementing Lock twice and Busy 3964 -- once. 3965 3966 -- This optimization makes "for ... of" loops over 30 times faster in cases 3967 -- measured. 3968 3969 procedure Expand_Iterator_Loop_Over_Container 3970 (N : Node_Id; 3971 Isc : Node_Id; 3972 I_Spec : Node_Id; 3973 Container : Node_Id; 3974 Container_Typ : Entity_Id) 3975 is 3976 Id : constant Entity_Id := Defining_Identifier (I_Spec); 3977 Elem_Typ : constant Entity_Id := Etype (Id); 3978 Id_Kind : constant Entity_Kind := Ekind (Id); 3979 Loc : constant Source_Ptr := Sloc (N); 3980 Stats : constant List_Id := Statements (N); 3981 3982 Cursor : Entity_Id; 3983 Decl : Node_Id; 3984 Iter_Type : Entity_Id; 3985 Iterator : Entity_Id; 3986 Name_Init : Name_Id; 3987 Name_Step : Name_Id; 3988 New_Loop : Node_Id; 3989 3990 Fast_Element_Access_Op : Entity_Id := Empty; 3991 Fast_Step_Op : Entity_Id := Empty; 3992 -- Only for optimized version of "for ... of" 3993 3994 Iter_Pack : Entity_Id; 3995 -- The package in which the iterator interface is instantiated. This is 3996 -- typically an instance within the container package. 3997 3998 Pack : Entity_Id; 3999 -- The package in which the container type is declared 4000 4001 begin 4002 -- Determine the advancement and initialization steps for the cursor. 4003 -- Analysis of the expanded loop will verify that the container has a 4004 -- reverse iterator. 4005 4006 if Reverse_Present (I_Spec) then 4007 Name_Init := Name_Last; 4008 Name_Step := Name_Previous; 4009 else 4010 Name_Init := Name_First; 4011 Name_Step := Name_Next; 4012 end if; 4013 4014 -- The type of the iterator is the return type of the Iterate function 4015 -- used. For the "of" form this is the default iterator for the type, 4016 -- otherwise it is the type of the explicit function used in the 4017 -- iterator specification. The most common case will be an Iterate 4018 -- function in the container package. 4019 4020 -- The Iterator type is declared in an instance within the container 4021 -- package itself, for example: 4022 4023 -- package Vector_Iterator_Interfaces is new 4024 -- Ada.Iterator_Interfaces (Cursor, Has_Element); 4025 4026 -- If the container type is a derived type, the cursor type is found in 4027 -- the package of the ultimate ancestor type. 4028 4029 if Is_Derived_Type (Container_Typ) then 4030 Pack := Scope (Root_Type (Container_Typ)); 4031 else 4032 Pack := Scope (Container_Typ); 4033 end if; 4034 4035 if Of_Present (I_Spec) then 4036 Handle_Of : declare 4037 Container_Arg : Node_Id; 4038 4039 function Get_Default_Iterator 4040 (T : Entity_Id) return Entity_Id; 4041 -- Return the default iterator for a specific type. If the type is 4042 -- derived, we return the inherited or overridden one if 4043 -- appropriate. 4044 4045 -------------------------- 4046 -- Get_Default_Iterator -- 4047 -------------------------- 4048 4049 function Get_Default_Iterator 4050 (T : Entity_Id) return Entity_Id 4051 is 4052 Iter : constant Entity_Id := 4053 Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator)); 4054 Prim : Elmt_Id; 4055 Op : Entity_Id; 4056 4057 begin 4058 Container_Arg := New_Copy_Tree (Container); 4059 4060 -- A previous version of GNAT allowed indexing aspects to be 4061 -- redefined on derived container types, while the default 4062 -- iterator was inherited from the parent type. This 4063 -- nonstandard extension is preserved for use by the 4064 -- modeling project under debug flag -gnatd.X. 4065 4066 if Debug_Flag_Dot_XX then 4067 if Base_Type (Etype (Container)) /= 4068 Base_Type (Etype (First_Formal (Iter))) 4069 then 4070 Container_Arg := 4071 Make_Type_Conversion (Loc, 4072 Subtype_Mark => 4073 New_Occurrence_Of 4074 (Etype (First_Formal (Iter)), Loc), 4075 Expression => Container_Arg); 4076 end if; 4077 4078 return Iter; 4079 4080 elsif Is_Derived_Type (T) then 4081 4082 -- The default iterator must be a primitive operation of the 4083 -- type, at the same dispatch slot position. The DT position 4084 -- may not be established if type is not frozen yet. 4085 4086 Prim := First_Elmt (Primitive_Operations (T)); 4087 while Present (Prim) loop 4088 Op := Node (Prim); 4089 4090 if Alias (Op) = Iter 4091 or else 4092 (Chars (Op) = Chars (Iter) 4093 and then Present (DTC_Entity (Op)) 4094 and then DT_Position (Op) = DT_Position (Iter)) 4095 then 4096 return Op; 4097 end if; 4098 4099 Next_Elmt (Prim); 4100 end loop; 4101 4102 -- If we didn't find it, then our parent type is not 4103 -- iterable, so we return the Default_Iterator aspect of 4104 -- this type. 4105 4106 return Iter; 4107 4108 -- Otherwise not a derived type 4109 4110 else 4111 return Iter; 4112 end if; 4113 end Get_Default_Iterator; 4114 4115 -- Local variables 4116 4117 Default_Iter : Entity_Id; 4118 Ent : Entity_Id; 4119 4120 Reference_Control_Type : Entity_Id := Empty; 4121 Pseudo_Reference : Entity_Id := Empty; 4122 4123 -- Start of processing for Handle_Of 4124 4125 begin 4126 if Is_Class_Wide_Type (Container_Typ) then 4127 Default_Iter := 4128 Get_Default_Iterator (Etype (Base_Type (Container_Typ))); 4129 else 4130 Default_Iter := Get_Default_Iterator (Etype (Container)); 4131 end if; 4132 4133 Cursor := Make_Temporary (Loc, 'C'); 4134 4135 -- For a container element iterator, the iterator type is obtained 4136 -- from the corresponding aspect, whose return type is descended 4137 -- from the corresponding interface type in some instance of 4138 -- Ada.Iterator_Interfaces. The actuals of that instantiation 4139 -- are Cursor and Has_Element. 4140 4141 Iter_Type := Etype (Default_Iter); 4142 4143 -- The iterator type, which is a class-wide type, may itself be 4144 -- derived locally, so the desired instantiation is the scope of 4145 -- the root type of the iterator type. 4146 4147 Iter_Pack := Scope (Root_Type (Etype (Iter_Type))); 4148 4149 -- Find declarations needed for "for ... of" optimization 4150 4151 Ent := First_Entity (Pack); 4152 while Present (Ent) loop 4153 if Chars (Ent) = Name_Get_Element_Access then 4154 Fast_Element_Access_Op := Ent; 4155 4156 elsif Chars (Ent) = Name_Step 4157 and then Ekind (Ent) = E_Procedure 4158 then 4159 Fast_Step_Op := Ent; 4160 4161 elsif Chars (Ent) = Name_Reference_Control_Type then 4162 Reference_Control_Type := Ent; 4163 4164 elsif Chars (Ent) = Name_Pseudo_Reference then 4165 Pseudo_Reference := Ent; 4166 end if; 4167 4168 Next_Entity (Ent); 4169 end loop; 4170 4171 if Present (Reference_Control_Type) 4172 and then Present (Pseudo_Reference) 4173 then 4174 Insert_Action (N, 4175 Make_Object_Declaration (Loc, 4176 Defining_Identifier => Make_Temporary (Loc, 'D'), 4177 Object_Definition => 4178 New_Occurrence_Of (Reference_Control_Type, Loc), 4179 Expression => 4180 Make_Function_Call (Loc, 4181 Name => 4182 New_Occurrence_Of (Pseudo_Reference, Loc), 4183 Parameter_Associations => 4184 New_List (New_Copy_Tree (Container_Arg))))); 4185 end if; 4186 4187 -- Rewrite domain of iteration as a call to the default iterator 4188 -- for the container type. The formal may be an access parameter 4189 -- in which case we must build a reference to the container. 4190 4191 declare 4192 Arg : Node_Id; 4193 begin 4194 if Is_Access_Type (Etype (First_Entity (Default_Iter))) then 4195 Arg := 4196 Make_Attribute_Reference (Loc, 4197 Prefix => Container_Arg, 4198 Attribute_Name => Name_Unrestricted_Access); 4199 else 4200 Arg := Container_Arg; 4201 end if; 4202 4203 Rewrite (Name (I_Spec), 4204 Make_Function_Call (Loc, 4205 Name => 4206 New_Occurrence_Of (Default_Iter, Loc), 4207 Parameter_Associations => New_List (Arg))); 4208 end; 4209 4210 Analyze_And_Resolve (Name (I_Spec)); 4211 4212 -- Find cursor type in proper iterator package, which is an 4213 -- instantiation of Iterator_Interfaces. 4214 4215 Ent := First_Entity (Iter_Pack); 4216 while Present (Ent) loop 4217 if Chars (Ent) = Name_Cursor then 4218 Set_Etype (Cursor, Etype (Ent)); 4219 exit; 4220 end if; 4221 4222 Next_Entity (Ent); 4223 end loop; 4224 4225 if Present (Fast_Element_Access_Op) then 4226 Decl := 4227 Make_Object_Renaming_Declaration (Loc, 4228 Defining_Identifier => Id, 4229 Subtype_Mark => 4230 New_Occurrence_Of (Elem_Typ, Loc), 4231 Name => 4232 Make_Explicit_Dereference (Loc, 4233 Prefix => 4234 Make_Function_Call (Loc, 4235 Name => 4236 New_Occurrence_Of (Fast_Element_Access_Op, Loc), 4237 Parameter_Associations => 4238 New_List (New_Occurrence_Of (Cursor, Loc))))); 4239 4240 else 4241 Decl := 4242 Make_Object_Renaming_Declaration (Loc, 4243 Defining_Identifier => Id, 4244 Subtype_Mark => 4245 New_Occurrence_Of (Elem_Typ, Loc), 4246 Name => 4247 Make_Indexed_Component (Loc, 4248 Prefix => Relocate_Node (Container_Arg), 4249 Expressions => 4250 New_List (New_Occurrence_Of (Cursor, Loc)))); 4251 end if; 4252 4253 -- The defining identifier in the iterator is user-visible and 4254 -- must be visible in the debugger. 4255 4256 Set_Debug_Info_Needed (Id); 4257 4258 -- If the container does not have a variable indexing aspect, 4259 -- the element is a constant in the loop. The container itself 4260 -- may be constant, in which case the element is a constant as 4261 -- well. The container has been rewritten as a call to Iterate, 4262 -- so examine original node. 4263 4264 if No (Find_Value_Of_Aspect 4265 (Container_Typ, Aspect_Variable_Indexing)) 4266 or else not Is_Variable (Original_Node (Container)) 4267 then 4268 Set_Ekind (Id, E_Constant); 4269 end if; 4270 4271 Prepend_To (Stats, Decl); 4272 end Handle_Of; 4273 4274 -- X in Iterate (S) : type of iterator is type of explicitly given 4275 -- Iterate function, and the loop variable is the cursor. It will be 4276 -- assigned in the loop and must be a variable. 4277 4278 else 4279 Iter_Type := Etype (Name (I_Spec)); 4280 4281 -- The iterator type, which is a class-wide type, may itself be 4282 -- derived locally, so the desired instantiation is the scope of 4283 -- the root type of the iterator type, as in the "of" case. 4284 4285 Iter_Pack := Scope (Root_Type (Etype (Iter_Type))); 4286 Cursor := Id; 4287 end if; 4288 4289 Iterator := Make_Temporary (Loc, 'I'); 4290 4291 -- For both iterator forms, add a call to the step operation to advance 4292 -- the cursor. Generate: 4293 4294 -- Cursor := Iterator.Next (Cursor); 4295 4296 -- or else 4297 4298 -- Cursor := Next (Cursor); 4299 4300 if Present (Fast_Element_Access_Op) and then Present (Fast_Step_Op) then 4301 declare 4302 Curs_Name : constant Node_Id := New_Occurrence_Of (Cursor, Loc); 4303 Step_Call : Node_Id; 4304 4305 begin 4306 Step_Call := 4307 Make_Procedure_Call_Statement (Loc, 4308 Name => 4309 New_Occurrence_Of (Fast_Step_Op, Loc), 4310 Parameter_Associations => New_List (Curs_Name)); 4311 4312 Append_To (Stats, Step_Call); 4313 Set_Assignment_OK (Curs_Name); 4314 end; 4315 4316 else 4317 declare 4318 Rhs : Node_Id; 4319 4320 begin 4321 Rhs := 4322 Make_Function_Call (Loc, 4323 Name => 4324 Make_Selected_Component (Loc, 4325 Prefix => New_Occurrence_Of (Iterator, Loc), 4326 Selector_Name => Make_Identifier (Loc, Name_Step)), 4327 Parameter_Associations => New_List ( 4328 New_Occurrence_Of (Cursor, Loc))); 4329 4330 Append_To (Stats, 4331 Make_Assignment_Statement (Loc, 4332 Name => New_Occurrence_Of (Cursor, Loc), 4333 Expression => Rhs)); 4334 Set_Assignment_OK (Name (Last (Stats))); 4335 end; 4336 end if; 4337 4338 -- Generate: 4339 -- while Has_Element (Cursor) loop 4340 -- <Stats> 4341 -- end loop; 4342 4343 -- Has_Element is the second actual in the iterator package 4344 4345 New_Loop := 4346 Make_Loop_Statement (Loc, 4347 Iteration_Scheme => 4348 Make_Iteration_Scheme (Loc, 4349 Condition => 4350 Make_Function_Call (Loc, 4351 Name => 4352 New_Occurrence_Of 4353 (Next_Entity (First_Entity (Iter_Pack)), Loc), 4354 Parameter_Associations => New_List ( 4355 New_Occurrence_Of (Cursor, Loc)))), 4356 4357 Statements => Stats, 4358 End_Label => Empty); 4359 4360 -- If present, preserve identifier of loop, which can be used in an exit 4361 -- statement in the body. 4362 4363 if Present (Identifier (N)) then 4364 Set_Identifier (New_Loop, Relocate_Node (Identifier (N))); 4365 end if; 4366 4367 -- Create the declarations for Iterator and cursor and insert them 4368 -- before the source loop. Given that the domain of iteration is already 4369 -- an entity, the iterator is just a renaming of that entity. Possible 4370 -- optimization ??? 4371 4372 Insert_Action (N, 4373 Make_Object_Renaming_Declaration (Loc, 4374 Defining_Identifier => Iterator, 4375 Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), 4376 Name => Relocate_Node (Name (I_Spec)))); 4377 4378 -- Create declaration for cursor 4379 4380 declare 4381 Cursor_Decl : constant Node_Id := 4382 Make_Object_Declaration (Loc, 4383 Defining_Identifier => Cursor, 4384 Object_Definition => 4385 New_Occurrence_Of (Etype (Cursor), Loc), 4386 Expression => 4387 Make_Selected_Component (Loc, 4388 Prefix => 4389 New_Occurrence_Of (Iterator, Loc), 4390 Selector_Name => 4391 Make_Identifier (Loc, Name_Init))); 4392 4393 begin 4394 -- The cursor is only modified in expanded code, so it appears 4395 -- as unassigned to the warning machinery. We must suppress this 4396 -- spurious warning explicitly. The cursor's kind is that of the 4397 -- original loop parameter (it is a constant if the domain of 4398 -- iteration is constant). 4399 4400 Set_Warnings_Off (Cursor); 4401 Set_Assignment_OK (Cursor_Decl); 4402 4403 Insert_Action (N, Cursor_Decl); 4404 Set_Ekind (Cursor, Id_Kind); 4405 end; 4406 4407 -- If the range of iteration is given by a function call that returns 4408 -- a container, the finalization actions have been saved in the 4409 -- Condition_Actions of the iterator. Insert them now at the head of 4410 -- the loop. 4411 4412 if Present (Condition_Actions (Isc)) then 4413 Insert_List_Before (N, Condition_Actions (Isc)); 4414 end if; 4415 4416 Rewrite (N, New_Loop); 4417 Analyze (N); 4418 end Expand_Iterator_Loop_Over_Container; 4419 4420 ----------------------------- 4421 -- Expand_N_Loop_Statement -- 4422 ----------------------------- 4423 4424 -- 1. Remove null loop entirely 4425 -- 2. Deal with while condition for C/Fortran boolean 4426 -- 3. Deal with loops with a non-standard enumeration type range 4427 -- 4. Deal with while loops where Condition_Actions is set 4428 -- 5. Deal with loops over predicated subtypes 4429 -- 6. Deal with loops with iterators over arrays and containers 4430 -- 7. Insert polling call if required 4431 4432 procedure Expand_N_Loop_Statement (N : Node_Id) is 4433 Loc : constant Source_Ptr := Sloc (N); 4434 Scheme : constant Node_Id := Iteration_Scheme (N); 4435 Stmt : Node_Id; 4436 4437 begin 4438 -- Delete null loop 4439 4440 if Is_Null_Loop (N) then 4441 Rewrite (N, Make_Null_Statement (Loc)); 4442 return; 4443 end if; 4444 4445 -- Deal with condition for C/Fortran Boolean 4446 4447 if Present (Scheme) then 4448 Adjust_Condition (Condition (Scheme)); 4449 end if; 4450 4451 -- Generate polling call 4452 4453 if Is_Non_Empty_List (Statements (N)) then 4454 Generate_Poll_Call (First (Statements (N))); 4455 end if; 4456 4457 -- Nothing more to do for plain loop with no iteration scheme 4458 4459 if No (Scheme) then 4460 null; 4461 4462 -- Case of for loop (Loop_Parameter_Specification present) 4463 4464 -- Note: we do not have to worry about validity checking of the for loop 4465 -- range bounds here, since they were frozen with constant declarations 4466 -- and it is during that process that the validity checking is done. 4467 4468 elsif Present (Loop_Parameter_Specification (Scheme)) then 4469 declare 4470 LPS : constant Node_Id := 4471 Loop_Parameter_Specification (Scheme); 4472 Loop_Id : constant Entity_Id := Defining_Identifier (LPS); 4473 Ltype : constant Entity_Id := Etype (Loop_Id); 4474 Btype : constant Entity_Id := Base_Type (Ltype); 4475 Expr : Node_Id; 4476 Decls : List_Id; 4477 New_Id : Entity_Id; 4478 4479 begin 4480 -- Deal with loop over predicates 4481 4482 if Is_Discrete_Type (Ltype) 4483 and then Present (Predicate_Function (Ltype)) 4484 then 4485 Expand_Predicated_Loop (N); 4486 4487 -- Handle the case where we have a for loop with the range type 4488 -- being an enumeration type with non-standard representation. 4489 -- In this case we expand: 4490 4491 -- for x in [reverse] a .. b loop 4492 -- ... 4493 -- end loop; 4494 4495 -- to 4496 4497 -- for xP in [reverse] integer 4498 -- range etype'Pos (a) .. etype'Pos (b) 4499 -- loop 4500 -- declare 4501 -- x : constant etype := Pos_To_Rep (xP); 4502 -- begin 4503 -- ... 4504 -- end; 4505 -- end loop; 4506 4507 elsif Is_Enumeration_Type (Btype) 4508 and then Present (Enum_Pos_To_Rep (Btype)) 4509 then 4510 New_Id := 4511 Make_Defining_Identifier (Loc, 4512 Chars => New_External_Name (Chars (Loop_Id), 'P')); 4513 4514 -- If the type has a contiguous representation, successive 4515 -- values can be generated as offsets from the first literal. 4516 4517 if Has_Contiguous_Rep (Btype) then 4518 Expr := 4519 Unchecked_Convert_To (Btype, 4520 Make_Op_Add (Loc, 4521 Left_Opnd => 4522 Make_Integer_Literal (Loc, 4523 Enumeration_Rep (First_Literal (Btype))), 4524 Right_Opnd => New_Occurrence_Of (New_Id, Loc))); 4525 else 4526 -- Use the constructed array Enum_Pos_To_Rep 4527 4528 Expr := 4529 Make_Indexed_Component (Loc, 4530 Prefix => 4531 New_Occurrence_Of (Enum_Pos_To_Rep (Btype), Loc), 4532 Expressions => 4533 New_List (New_Occurrence_Of (New_Id, Loc))); 4534 end if; 4535 4536 -- Build declaration for loop identifier 4537 4538 Decls := 4539 New_List ( 4540 Make_Object_Declaration (Loc, 4541 Defining_Identifier => Loop_Id, 4542 Constant_Present => True, 4543 Object_Definition => New_Occurrence_Of (Ltype, Loc), 4544 Expression => Expr)); 4545 4546 Rewrite (N, 4547 Make_Loop_Statement (Loc, 4548 Identifier => Identifier (N), 4549 4550 Iteration_Scheme => 4551 Make_Iteration_Scheme (Loc, 4552 Loop_Parameter_Specification => 4553 Make_Loop_Parameter_Specification (Loc, 4554 Defining_Identifier => New_Id, 4555 Reverse_Present => Reverse_Present (LPS), 4556 4557 Discrete_Subtype_Definition => 4558 Make_Subtype_Indication (Loc, 4559 4560 Subtype_Mark => 4561 New_Occurrence_Of (Standard_Natural, Loc), 4562 4563 Constraint => 4564 Make_Range_Constraint (Loc, 4565 Range_Expression => 4566 Make_Range (Loc, 4567 4568 Low_Bound => 4569 Make_Attribute_Reference (Loc, 4570 Prefix => 4571 New_Occurrence_Of (Btype, Loc), 4572 4573 Attribute_Name => Name_Pos, 4574 4575 Expressions => New_List ( 4576 Relocate_Node 4577 (Type_Low_Bound (Ltype)))), 4578 4579 High_Bound => 4580 Make_Attribute_Reference (Loc, 4581 Prefix => 4582 New_Occurrence_Of (Btype, Loc), 4583 4584 Attribute_Name => Name_Pos, 4585 4586 Expressions => New_List ( 4587 Relocate_Node 4588 (Type_High_Bound 4589 (Ltype))))))))), 4590 4591 Statements => New_List ( 4592 Make_Block_Statement (Loc, 4593 Declarations => Decls, 4594 Handled_Statement_Sequence => 4595 Make_Handled_Sequence_Of_Statements (Loc, 4596 Statements => Statements (N)))), 4597 4598 End_Label => End_Label (N))); 4599 4600 -- The loop parameter's entity must be removed from the loop 4601 -- scope's entity list and rendered invisible, since it will 4602 -- now be located in the new block scope. Any other entities 4603 -- already associated with the loop scope, such as the loop 4604 -- parameter's subtype, will remain there. 4605 4606 -- In an element loop, the loop will contain a declaration for 4607 -- a cursor variable; otherwise the loop id is the first entity 4608 -- in the scope constructed for the loop. 4609 4610 if Comes_From_Source (Loop_Id) then 4611 pragma Assert (First_Entity (Scope (Loop_Id)) = Loop_Id); 4612 null; 4613 end if; 4614 4615 Set_First_Entity (Scope (Loop_Id), Next_Entity (Loop_Id)); 4616 Remove_Homonym (Loop_Id); 4617 4618 if Last_Entity (Scope (Loop_Id)) = Loop_Id then 4619 Set_Last_Entity (Scope (Loop_Id), Empty); 4620 end if; 4621 4622 Analyze (N); 4623 4624 -- Nothing to do with other cases of for loops 4625 4626 else 4627 null; 4628 end if; 4629 end; 4630 4631 -- Second case, if we have a while loop with Condition_Actions set, then 4632 -- we change it into a plain loop: 4633 4634 -- while C loop 4635 -- ... 4636 -- end loop; 4637 4638 -- changed to: 4639 4640 -- loop 4641 -- <<condition actions>> 4642 -- exit when not C; 4643 -- ... 4644 -- end loop 4645 4646 elsif Present (Scheme) 4647 and then Present (Condition_Actions (Scheme)) 4648 and then Present (Condition (Scheme)) 4649 then 4650 declare 4651 ES : Node_Id; 4652 4653 begin 4654 ES := 4655 Make_Exit_Statement (Sloc (Condition (Scheme)), 4656 Condition => 4657 Make_Op_Not (Sloc (Condition (Scheme)), 4658 Right_Opnd => Condition (Scheme))); 4659 4660 Prepend (ES, Statements (N)); 4661 Insert_List_Before (ES, Condition_Actions (Scheme)); 4662 4663 -- This is not an implicit loop, since it is generated in response 4664 -- to the loop statement being processed. If this is itself 4665 -- implicit, the restriction has already been checked. If not, 4666 -- it is an explicit loop. 4667 4668 Rewrite (N, 4669 Make_Loop_Statement (Sloc (N), 4670 Identifier => Identifier (N), 4671 Statements => Statements (N), 4672 End_Label => End_Label (N))); 4673 4674 Analyze (N); 4675 end; 4676 4677 -- Here to deal with iterator case 4678 4679 elsif Present (Scheme) 4680 and then Present (Iterator_Specification (Scheme)) 4681 then 4682 Expand_Iterator_Loop (N); 4683 4684 -- An iterator loop may generate renaming declarations for elements 4685 -- that require debug information. This is the case in particular 4686 -- with element iterators, where debug information must be generated 4687 -- for the temporary that holds the element value. These temporaries 4688 -- are created within a transient block whose local declarations are 4689 -- transferred to the loop, which now has nontrivial local objects. 4690 4691 if Nkind (N) = N_Loop_Statement 4692 and then Present (Identifier (N)) 4693 then 4694 Qualify_Entity_Names (N); 4695 end if; 4696 end if; 4697 4698 -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop 4699 -- is transformed into a conditional block where the original loop is 4700 -- the sole statement. Inspect the statements of the nested loop for 4701 -- controlled objects. 4702 4703 Stmt := N; 4704 4705 if Subject_To_Loop_Entry_Attributes (Stmt) then 4706 Stmt := Find_Loop_In_Conditional_Block (Stmt); 4707 end if; 4708 4709 Process_Statements_For_Controlled_Objects (Stmt); 4710 end Expand_N_Loop_Statement; 4711 4712 ---------------------------- 4713 -- Expand_Predicated_Loop -- 4714 ---------------------------- 4715 4716 -- Note: the expander can handle generation of loops over predicated 4717 -- subtypes for both the dynamic and static cases. Depending on what 4718 -- we decide is allowed in Ada 2012 mode and/or extensions allowed 4719 -- mode, the semantic analyzer may disallow one or both forms. 4720 4721 procedure Expand_Predicated_Loop (N : Node_Id) is 4722 Loc : constant Source_Ptr := Sloc (N); 4723 Isc : constant Node_Id := Iteration_Scheme (N); 4724 LPS : constant Node_Id := Loop_Parameter_Specification (Isc); 4725 Loop_Id : constant Entity_Id := Defining_Identifier (LPS); 4726 Ltype : constant Entity_Id := Etype (Loop_Id); 4727 Stat : constant List_Id := Static_Discrete_Predicate (Ltype); 4728 Stmts : constant List_Id := Statements (N); 4729 4730 begin 4731 -- Case of iteration over non-static predicate, should not be possible 4732 -- since this is not allowed by the semantics and should have been 4733 -- caught during analysis of the loop statement. 4734 4735 if No (Stat) then 4736 raise Program_Error; 4737 4738 -- If the predicate list is empty, that corresponds to a predicate of 4739 -- False, in which case the loop won't run at all, and we rewrite the 4740 -- entire loop as a null statement. 4741 4742 elsif Is_Empty_List (Stat) then 4743 Rewrite (N, Make_Null_Statement (Loc)); 4744 Analyze (N); 4745 4746 -- For expansion over a static predicate we generate the following 4747 4748 -- declare 4749 -- J : Ltype := min-val; 4750 -- begin 4751 -- loop 4752 -- body 4753 -- case J is 4754 -- when endpoint => J := startpoint; 4755 -- when endpoint => J := startpoint; 4756 -- ... 4757 -- when max-val => exit; 4758 -- when others => J := Lval'Succ (J); 4759 -- end case; 4760 -- end loop; 4761 -- end; 4762 4763 -- with min-val replaced by max-val and Succ replaced by Pred if the 4764 -- loop parameter specification carries a Reverse indicator. 4765 4766 -- To make this a little clearer, let's take a specific example: 4767 4768 -- type Int is range 1 .. 10; 4769 -- subtype StaticP is Int with 4770 -- predicate => StaticP in 3 | 10 | 5 .. 7; 4771 -- ... 4772 -- for L in StaticP loop 4773 -- Put_Line ("static:" & J'Img); 4774 -- end loop; 4775 4776 -- In this case, the loop is transformed into 4777 4778 -- begin 4779 -- J : L := 3; 4780 -- loop 4781 -- body 4782 -- case J is 4783 -- when 3 => J := 5; 4784 -- when 7 => J := 10; 4785 -- when 10 => exit; 4786 -- when others => J := L'Succ (J); 4787 -- end case; 4788 -- end loop; 4789 -- end; 4790 4791 -- In addition, if the loop specification is given by a subtype 4792 -- indication that constrains a predicated type, the bounds of 4793 -- iteration are given by those of the subtype indication. 4794 4795 else 4796 Static_Predicate : declare 4797 S : Node_Id; 4798 D : Node_Id; 4799 P : Node_Id; 4800 Alts : List_Id; 4801 Cstm : Node_Id; 4802 4803 -- If the domain is an itype, note the bounds of its range. 4804 4805 L_Hi : Node_Id := Empty; 4806 L_Lo : Node_Id := Empty; 4807 4808 function Lo_Val (N : Node_Id) return Node_Id; 4809 -- Given static expression or static range, returns an identifier 4810 -- whose value is the low bound of the expression value or range. 4811 4812 function Hi_Val (N : Node_Id) return Node_Id; 4813 -- Given static expression or static range, returns an identifier 4814 -- whose value is the high bound of the expression value or range. 4815 4816 ------------ 4817 -- Hi_Val -- 4818 ------------ 4819 4820 function Hi_Val (N : Node_Id) return Node_Id is 4821 begin 4822 if Is_OK_Static_Expression (N) then 4823 return New_Copy (N); 4824 else 4825 pragma Assert (Nkind (N) = N_Range); 4826 return New_Copy (High_Bound (N)); 4827 end if; 4828 end Hi_Val; 4829 4830 ------------ 4831 -- Lo_Val -- 4832 ------------ 4833 4834 function Lo_Val (N : Node_Id) return Node_Id is 4835 begin 4836 if Is_OK_Static_Expression (N) then 4837 return New_Copy (N); 4838 else 4839 pragma Assert (Nkind (N) = N_Range); 4840 return New_Copy (Low_Bound (N)); 4841 end if; 4842 end Lo_Val; 4843 4844 -- Start of processing for Static_Predicate 4845 4846 begin 4847 -- Convert loop identifier to normal variable and reanalyze it so 4848 -- that this conversion works. We have to use the same defining 4849 -- identifier, since there may be references in the loop body. 4850 4851 Set_Analyzed (Loop_Id, False); 4852 Set_Ekind (Loop_Id, E_Variable); 4853 4854 -- In most loops the loop variable is assigned in various 4855 -- alternatives in the body. However, in the rare case when 4856 -- the range specifies a single element, the loop variable 4857 -- may trigger a spurious warning that is could be constant. 4858 -- This warning might as well be suppressed. 4859 4860 Set_Warnings_Off (Loop_Id); 4861 4862 if Is_Itype (Ltype) then 4863 L_Hi := High_Bound (Scalar_Range (Ltype)); 4864 L_Lo := Low_Bound (Scalar_Range (Ltype)); 4865 end if; 4866 4867 -- Loop to create branches of case statement 4868 4869 Alts := New_List; 4870 4871 if Reverse_Present (LPS) then 4872 4873 -- Initial value is largest value in predicate. 4874 4875 if Is_Itype (Ltype) then 4876 D := 4877 Make_Object_Declaration (Loc, 4878 Defining_Identifier => Loop_Id, 4879 Object_Definition => New_Occurrence_Of (Ltype, Loc), 4880 Expression => L_Hi); 4881 4882 else 4883 D := 4884 Make_Object_Declaration (Loc, 4885 Defining_Identifier => Loop_Id, 4886 Object_Definition => New_Occurrence_Of (Ltype, Loc), 4887 Expression => Hi_Val (Last (Stat))); 4888 end if; 4889 4890 P := Last (Stat); 4891 while Present (P) loop 4892 if No (Prev (P)) then 4893 S := Make_Exit_Statement (Loc); 4894 else 4895 S := 4896 Make_Assignment_Statement (Loc, 4897 Name => New_Occurrence_Of (Loop_Id, Loc), 4898 Expression => Hi_Val (Prev (P))); 4899 Set_Suppress_Assignment_Checks (S); 4900 end if; 4901 4902 Append_To (Alts, 4903 Make_Case_Statement_Alternative (Loc, 4904 Statements => New_List (S), 4905 Discrete_Choices => New_List (Lo_Val (P)))); 4906 4907 Prev (P); 4908 end loop; 4909 4910 if Is_Itype (Ltype) 4911 and then Is_OK_Static_Expression (L_Lo) 4912 and then 4913 Expr_Value (L_Lo) /= Expr_Value (Lo_Val (First (Stat))) 4914 then 4915 Append_To (Alts, 4916 Make_Case_Statement_Alternative (Loc, 4917 Statements => New_List (Make_Exit_Statement (Loc)), 4918 Discrete_Choices => New_List (L_Lo))); 4919 end if; 4920 4921 else 4922 -- Initial value is smallest value in predicate 4923 4924 if Is_Itype (Ltype) then 4925 D := 4926 Make_Object_Declaration (Loc, 4927 Defining_Identifier => Loop_Id, 4928 Object_Definition => New_Occurrence_Of (Ltype, Loc), 4929 Expression => L_Lo); 4930 else 4931 D := 4932 Make_Object_Declaration (Loc, 4933 Defining_Identifier => Loop_Id, 4934 Object_Definition => New_Occurrence_Of (Ltype, Loc), 4935 Expression => Lo_Val (First (Stat))); 4936 end if; 4937 4938 P := First (Stat); 4939 while Present (P) loop 4940 if No (Next (P)) then 4941 S := Make_Exit_Statement (Loc); 4942 else 4943 S := 4944 Make_Assignment_Statement (Loc, 4945 Name => New_Occurrence_Of (Loop_Id, Loc), 4946 Expression => Lo_Val (Next (P))); 4947 Set_Suppress_Assignment_Checks (S); 4948 end if; 4949 4950 Append_To (Alts, 4951 Make_Case_Statement_Alternative (Loc, 4952 Statements => New_List (S), 4953 Discrete_Choices => New_List (Hi_Val (P)))); 4954 4955 Next (P); 4956 end loop; 4957 4958 if Is_Itype (Ltype) 4959 and then Is_OK_Static_Expression (L_Hi) 4960 and then 4961 Expr_Value (L_Hi) /= Expr_Value (Lo_Val (Last (Stat))) 4962 then 4963 Append_To (Alts, 4964 Make_Case_Statement_Alternative (Loc, 4965 Statements => New_List (Make_Exit_Statement (Loc)), 4966 Discrete_Choices => New_List (L_Hi))); 4967 end if; 4968 end if; 4969 4970 -- Add others choice 4971 4972 declare 4973 Name_Next : Name_Id; 4974 4975 begin 4976 if Reverse_Present (LPS) then 4977 Name_Next := Name_Pred; 4978 else 4979 Name_Next := Name_Succ; 4980 end if; 4981 4982 S := 4983 Make_Assignment_Statement (Loc, 4984 Name => New_Occurrence_Of (Loop_Id, Loc), 4985 Expression => 4986 Make_Attribute_Reference (Loc, 4987 Prefix => New_Occurrence_Of (Ltype, Loc), 4988 Attribute_Name => Name_Next, 4989 Expressions => New_List ( 4990 New_Occurrence_Of (Loop_Id, Loc)))); 4991 Set_Suppress_Assignment_Checks (S); 4992 end; 4993 4994 Append_To (Alts, 4995 Make_Case_Statement_Alternative (Loc, 4996 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 4997 Statements => New_List (S))); 4998 4999 -- Construct case statement and append to body statements 5000 5001 Cstm := 5002 Make_Case_Statement (Loc, 5003 Expression => New_Occurrence_Of (Loop_Id, Loc), 5004 Alternatives => Alts); 5005 Append_To (Stmts, Cstm); 5006 5007 -- Rewrite the loop 5008 5009 Set_Suppress_Assignment_Checks (D); 5010 5011 Rewrite (N, 5012 Make_Block_Statement (Loc, 5013 Declarations => New_List (D), 5014 Handled_Statement_Sequence => 5015 Make_Handled_Sequence_Of_Statements (Loc, 5016 Statements => New_List ( 5017 Make_Loop_Statement (Loc, 5018 Statements => Stmts, 5019 End_Label => Empty))))); 5020 5021 Analyze (N); 5022 end Static_Predicate; 5023 end if; 5024 end Expand_Predicated_Loop; 5025 5026 ------------------------------ 5027 -- Make_Tag_Ctrl_Assignment -- 5028 ------------------------------ 5029 5030 function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is 5031 Asn : constant Node_Id := Relocate_Node (N); 5032 L : constant Node_Id := Name (N); 5033 Loc : constant Source_Ptr := Sloc (N); 5034 Res : constant List_Id := New_List; 5035 T : constant Entity_Id := Underlying_Type (Etype (L)); 5036 5037 Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T); 5038 Ctrl_Act : constant Boolean := Needs_Finalization (T) 5039 and then not No_Ctrl_Actions (N); 5040 Save_Tag : constant Boolean := Is_Tagged_Type (T) 5041 and then not Comp_Asn 5042 and then not No_Ctrl_Actions (N) 5043 and then Tagged_Type_Expansion; 5044 Adj_Call : Node_Id; 5045 Fin_Call : Node_Id; 5046 Tag_Id : Entity_Id; 5047 5048 begin 5049 -- Finalize the target of the assignment when controlled 5050 5051 -- We have two exceptions here: 5052 5053 -- 1. If we are in an init proc since it is an initialization more 5054 -- than an assignment. 5055 5056 -- 2. If the left-hand side is a temporary that was not initialized 5057 -- (or the parent part of a temporary since it is the case in 5058 -- extension aggregates). Such a temporary does not come from 5059 -- source. We must examine the original node for the prefix, because 5060 -- it may be a component of an entry formal, in which case it has 5061 -- been rewritten and does not appear to come from source either. 5062 5063 -- Case of init proc 5064 5065 if not Ctrl_Act then 5066 null; 5067 5068 -- The left-hand side is an uninitialized temporary object 5069 5070 elsif Nkind (L) = N_Type_Conversion 5071 and then Is_Entity_Name (Expression (L)) 5072 and then Nkind (Parent (Entity (Expression (L)))) = 5073 N_Object_Declaration 5074 and then No_Initialization (Parent (Entity (Expression (L)))) 5075 then 5076 null; 5077 5078 else 5079 Fin_Call := 5080 Make_Final_Call 5081 (Obj_Ref => Duplicate_Subexpr_No_Checks (L), 5082 Typ => Etype (L)); 5083 5084 if Present (Fin_Call) then 5085 Append_To (Res, Fin_Call); 5086 end if; 5087 end if; 5088 5089 -- Save the Tag in a local variable Tag_Id 5090 5091 if Save_Tag then 5092 Tag_Id := Make_Temporary (Loc, 'A'); 5093 5094 Append_To (Res, 5095 Make_Object_Declaration (Loc, 5096 Defining_Identifier => Tag_Id, 5097 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), 5098 Expression => 5099 Make_Selected_Component (Loc, 5100 Prefix => Duplicate_Subexpr_No_Checks (L), 5101 Selector_Name => 5102 New_Occurrence_Of (First_Tag_Component (T), Loc)))); 5103 5104 -- Otherwise Tag_Id is not used 5105 5106 else 5107 Tag_Id := Empty; 5108 end if; 5109 5110 -- If the tagged type has a full rep clause, expand the assignment into 5111 -- component-wise assignments. Mark the node as unanalyzed in order to 5112 -- generate the proper code and propagate this scenario by setting a 5113 -- flag to avoid infinite recursion. 5114 5115 if Comp_Asn then 5116 Set_Analyzed (Asn, False); 5117 Set_Componentwise_Assignment (Asn, True); 5118 end if; 5119 5120 Append_To (Res, Asn); 5121 5122 -- Restore the tag 5123 5124 if Save_Tag then 5125 Append_To (Res, 5126 Make_Assignment_Statement (Loc, 5127 Name => 5128 Make_Selected_Component (Loc, 5129 Prefix => Duplicate_Subexpr_No_Checks (L), 5130 Selector_Name => 5131 New_Occurrence_Of (First_Tag_Component (T), Loc)), 5132 Expression => New_Occurrence_Of (Tag_Id, Loc))); 5133 end if; 5134 5135 -- Adjust the target after the assignment when controlled (not in the 5136 -- init proc since it is an initialization more than an assignment). 5137 5138 if Ctrl_Act then 5139 Adj_Call := 5140 Make_Adjust_Call 5141 (Obj_Ref => Duplicate_Subexpr_Move_Checks (L), 5142 Typ => Etype (L)); 5143 5144 if Present (Adj_Call) then 5145 Append_To (Res, Adj_Call); 5146 end if; 5147 end if; 5148 5149 return Res; 5150 5151 exception 5152 5153 -- Could use comment here ??? 5154 5155 when RE_Not_Available => 5156 return Empty_List; 5157 end Make_Tag_Ctrl_Assignment; 5158 5159end Exp_Ch5; 5160