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