1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 4 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Aggr; use Exp_Aggr; 33with Exp_Ch3; use Exp_Ch3; 34with Exp_Ch7; use Exp_Ch7; 35with Exp_Ch9; use Exp_Ch9; 36with Exp_Disp; use Exp_Disp; 37with Exp_Fixd; use Exp_Fixd; 38with Exp_Pakd; use Exp_Pakd; 39with Exp_Tss; use Exp_Tss; 40with Exp_Util; use Exp_Util; 41with Exp_VFpt; use Exp_VFpt; 42with Hostparm; use Hostparm; 43with Inline; use Inline; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Opt; use Opt; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Cat; use Sem_Cat; 50with Sem_Ch13; use Sem_Ch13; 51with Sem_Eval; use Sem_Eval; 52with Sem_Res; use Sem_Res; 53with Sem_Type; use Sem_Type; 54with Sem_Util; use Sem_Util; 55with Sem_Warn; use Sem_Warn; 56with Sinfo; use Sinfo; 57with Sinfo.CN; use Sinfo.CN; 58with Snames; use Snames; 59with Stand; use Stand; 60with Targparm; use Targparm; 61with Tbuild; use Tbuild; 62with Ttypes; use Ttypes; 63with Uintp; use Uintp; 64with Urealp; use Urealp; 65with Validsw; use Validsw; 66 67package body Exp_Ch4 is 68 69 ------------------------ 70 -- Local Subprograms -- 71 ------------------------ 72 73 procedure Binary_Op_Validity_Checks (N : Node_Id); 74 pragma Inline (Binary_Op_Validity_Checks); 75 -- Performs validity checks for a binary operator 76 77 procedure Build_Boolean_Array_Proc_Call 78 (N : Node_Id; 79 Op1 : Node_Id; 80 Op2 : Node_Id); 81 -- If an boolean array assignment can be done in place, build call to 82 -- corresponding library procedure. 83 84 procedure Expand_Allocator_Expression (N : Node_Id); 85 -- Subsidiary to Expand_N_Allocator, for the case when the expression 86 -- is a qualified expression or an aggregate. 87 88 procedure Expand_Array_Comparison (N : Node_Id); 89 -- This routine handles expansion of the comparison operators (N_Op_Lt, 90 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic 91 -- code for these operators is similar, differing only in the details of 92 -- the actual comparison call that is made. Special processing (call a 93 -- run-time routine) 94 95 function Expand_Array_Equality 96 (Nod : Node_Id; 97 Typ : Entity_Id; 98 A_Typ : Entity_Id; 99 Lhs : Node_Id; 100 Rhs : Node_Id; 101 Bodies : List_Id) 102 return Node_Id; 103 -- Expand an array equality into a call to a function implementing this 104 -- equality, and a call to it. Loc is the location for the generated 105 -- nodes. Typ is the type of the array, and Lhs, Rhs are the array 106 -- expressions to be compared. A_Typ is the type of the arguments, 107 -- which may be a private type, in which case Typ is its full view. 108 -- Bodies is a list on which to attach bodies of local functions that 109 -- are created in the process. This is the responsibility of the 110 -- caller to insert those bodies at the right place. Nod provides 111 -- the Sloc value for the generated code. 112 113 procedure Expand_Boolean_Operator (N : Node_Id); 114 -- Common expansion processing for Boolean operators (And, Or, Xor) 115 -- for the case of array type arguments. 116 117 function Expand_Composite_Equality 118 (Nod : Node_Id; 119 Typ : Entity_Id; 120 Lhs : Node_Id; 121 Rhs : Node_Id; 122 Bodies : List_Id) 123 return Node_Id; 124 -- Local recursive function used to expand equality for nested 125 -- composite types. Used by Expand_Record/Array_Equality, Bodies 126 -- is a list on which to attach bodies of local functions that are 127 -- created in the process. This is the responsability of the caller 128 -- to insert those bodies at the right place. Nod provides the Sloc 129 -- value for generated code. 130 131 procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id); 132 -- This routine handles expansion of concatenation operations, where 133 -- N is the N_Op_Concat node being expanded and Operands is the list 134 -- of operands (at least two are present). The caller has dealt with 135 -- converting any singleton operands into singleton aggregates. 136 137 procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id); 138 -- Routine to expand concatenation of 2-5 operands (in the list Operands) 139 -- and replace node Cnode with the result of the contatenation. If there 140 -- are two operands, they can be string or character. If there are more 141 -- than two operands, then are always of type string (i.e. the caller has 142 -- already converted character operands to strings in this case). 143 144 procedure Fixup_Universal_Fixed_Operation (N : Node_Id); 145 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is 146 -- universal fixed. We do not have such a type at runtime, so the 147 -- purpose of this routine is to find the real type by looking up 148 -- the tree. We also determine if the operation must be rounded. 149 150 function Get_Allocator_Final_List 151 (N : Node_Id; 152 T : Entity_Id; 153 PtrT : Entity_Id) 154 return Entity_Id; 155 -- If the designated type is controlled, build final_list expression 156 -- for created object. If context is an access parameter, create a 157 -- local access type to have a usable finalization list. 158 159 procedure Insert_Dereference_Action (N : Node_Id); 160 -- N is an expression whose type is an access. When the type is derived 161 -- from Checked_Pool, expands a call to the primitive 'dereference'. 162 163 function Make_Array_Comparison_Op 164 (Typ : Entity_Id; 165 Nod : Node_Id) 166 return Node_Id; 167 -- Comparisons between arrays are expanded in line. This function 168 -- produces the body of the implementation of (a > b), where a and b 169 -- are one-dimensional arrays of some discrete type. The original 170 -- node is then expanded into the appropriate call to this function. 171 -- Nod provides the Sloc value for the generated code. 172 173 function Make_Boolean_Array_Op 174 (Typ : Entity_Id; 175 N : Node_Id) 176 return Node_Id; 177 -- Boolean operations on boolean arrays are expanded in line. This 178 -- function produce the body for the node N, which is (a and b), 179 -- (a or b), or (a xor b). It is used only the normal case and not 180 -- the packed case. The type involved, Typ, is the Boolean array type, 181 -- and the logical operations in the body are simple boolean operations. 182 -- Note that Typ is always a constrained type (the caller has ensured 183 -- this by using Convert_To_Actual_Subtype if necessary). 184 185 procedure Rewrite_Comparison (N : Node_Id); 186 -- N is the node for a compile time comparison. If this outcome of this 187 -- comparison can be determined at compile time, then the node N can be 188 -- rewritten with True or False. If the outcome cannot be determined at 189 -- compile time, the call has no effect. 190 191 function Tagged_Membership (N : Node_Id) return Node_Id; 192 -- Construct the expression corresponding to the tagged membership test. 193 -- Deals with a second operand being (or not) a class-wide type. 194 195 function Safe_In_Place_Array_Op 196 (Lhs : Node_Id; 197 Op1 : Node_Id; 198 Op2 : Node_Id) 199 return Boolean; 200 -- In the context of an assignment, where the right-hand side is a 201 -- boolean operation on arrays, check whether operation can be performed 202 -- in place. 203 204 procedure Unary_Op_Validity_Checks (N : Node_Id); 205 pragma Inline (Unary_Op_Validity_Checks); 206 -- Performs validity checks for a unary operator 207 208 ------------------------------- 209 -- Binary_Op_Validity_Checks -- 210 ------------------------------- 211 212 procedure Binary_Op_Validity_Checks (N : Node_Id) is 213 begin 214 if Validity_Checks_On and Validity_Check_Operands then 215 Ensure_Valid (Left_Opnd (N)); 216 Ensure_Valid (Right_Opnd (N)); 217 end if; 218 end Binary_Op_Validity_Checks; 219 220 ------------------------------------ 221 -- Build_Boolean_Array_Proc_Call -- 222 ------------------------------------ 223 224 procedure Build_Boolean_Array_Proc_Call 225 (N : Node_Id; 226 Op1 : Node_Id; 227 Op2 : Node_Id) 228 is 229 Loc : constant Source_Ptr := Sloc (N); 230 Kind : constant Node_Kind := Nkind (Expression (N)); 231 Target : constant Node_Id := 232 Make_Attribute_Reference (Loc, 233 Prefix => Name (N), 234 Attribute_Name => Name_Address); 235 236 Arg1 : constant Node_Id := Op1; 237 Arg2 : Node_Id := Op2; 238 Call_Node : Node_Id; 239 Proc_Name : Entity_Id; 240 241 begin 242 if Kind = N_Op_Not then 243 if Nkind (Op1) in N_Binary_Op then 244 245 -- Use negated version of the binary operators. 246 247 if Nkind (Op1) = N_Op_And then 248 Proc_Name := RTE (RE_Vector_Nand); 249 250 elsif Nkind (Op1) = N_Op_Or then 251 Proc_Name := RTE (RE_Vector_Nor); 252 253 else pragma Assert (Nkind (Op1) = N_Op_Xor); 254 Proc_Name := RTE (RE_Vector_Xor); 255 end if; 256 257 Call_Node := 258 Make_Procedure_Call_Statement (Loc, 259 Name => New_Occurrence_Of (Proc_Name, Loc), 260 261 Parameter_Associations => New_List ( 262 Target, 263 Make_Attribute_Reference (Loc, 264 Prefix => Left_Opnd (Op1), 265 Attribute_Name => Name_Address), 266 267 Make_Attribute_Reference (Loc, 268 Prefix => Right_Opnd (Op1), 269 Attribute_Name => Name_Address), 270 271 Make_Attribute_Reference (Loc, 272 Prefix => Left_Opnd (Op1), 273 Attribute_Name => Name_Length))); 274 275 else 276 Proc_Name := RTE (RE_Vector_Not); 277 278 Call_Node := 279 Make_Procedure_Call_Statement (Loc, 280 Name => New_Occurrence_Of (Proc_Name, Loc), 281 Parameter_Associations => New_List ( 282 Target, 283 284 Make_Attribute_Reference (Loc, 285 Prefix => Op1, 286 Attribute_Name => Name_Address), 287 288 Make_Attribute_Reference (Loc, 289 Prefix => Op1, 290 Attribute_Name => Name_Length))); 291 end if; 292 293 else 294 -- We use the following equivalences: 295 296 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) 297 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) 298 -- (not X) xor (not Y) = X xor Y 299 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) 300 301 if Nkind (Op1) = N_Op_Not then 302 if Kind = N_Op_And then 303 Proc_Name := RTE (RE_Vector_Nor); 304 305 elsif Kind = N_Op_Or then 306 Proc_Name := RTE (RE_Vector_Nand); 307 308 else 309 Proc_Name := RTE (RE_Vector_Xor); 310 end if; 311 312 else 313 if Kind = N_Op_And then 314 Proc_Name := RTE (RE_Vector_And); 315 316 elsif Kind = N_Op_Or then 317 Proc_Name := RTE (RE_Vector_Or); 318 319 elsif Nkind (Op2) = N_Op_Not then 320 Proc_Name := RTE (RE_Vector_Nxor); 321 Arg2 := Right_Opnd (Op2); 322 323 else 324 Proc_Name := RTE (RE_Vector_Xor); 325 end if; 326 end if; 327 328 Call_Node := 329 Make_Procedure_Call_Statement (Loc, 330 Name => New_Occurrence_Of (Proc_Name, Loc), 331 Parameter_Associations => New_List ( 332 Target, 333 Make_Attribute_Reference (Loc, 334 Prefix => Arg1, 335 Attribute_Name => Name_Address), 336 Make_Attribute_Reference (Loc, 337 Prefix => Arg2, 338 Attribute_Name => Name_Address), 339 Make_Attribute_Reference (Loc, 340 Prefix => Op1, 341 Attribute_Name => Name_Length))); 342 end if; 343 344 Rewrite (N, Call_Node); 345 Analyze (N); 346 347 exception 348 when RE_Not_Available => 349 return; 350 end Build_Boolean_Array_Proc_Call; 351 352 --------------------------------- 353 -- Expand_Allocator_Expression -- 354 --------------------------------- 355 356 procedure Expand_Allocator_Expression (N : Node_Id) is 357 Loc : constant Source_Ptr := Sloc (N); 358 Exp : constant Node_Id := Expression (Expression (N)); 359 Indic : constant Node_Id := Subtype_Mark (Expression (N)); 360 PtrT : constant Entity_Id := Etype (N); 361 T : constant Entity_Id := Entity (Indic); 362 Flist : Node_Id; 363 Node : Node_Id; 364 Temp : Entity_Id; 365 366 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); 367 368 Tag_Assign : Node_Id; 369 Tmp_Node : Node_Id; 370 371 begin 372 if Is_Tagged_Type (T) or else Controlled_Type (T) then 373 374 -- Actions inserted before: 375 -- Temp : constant ptr_T := new T'(Expression); 376 -- <no CW> Temp._tag := T'tag; 377 -- <CTRL> Adjust (Finalizable (Temp.all)); 378 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all)); 379 380 -- We analyze by hand the new internal allocator to avoid 381 -- any recursion and inappropriate call to Initialize 382 if not Aggr_In_Place then 383 Remove_Side_Effects (Exp); 384 end if; 385 386 Temp := 387 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 388 389 -- For a class wide allocation generate the following code: 390 391 -- type Equiv_Record is record ... end record; 392 -- implicit subtype CW is <Class_Wide_Subytpe>; 393 -- temp : PtrT := new CW'(CW!(expr)); 394 395 if Is_Class_Wide_Type (T) then 396 Expand_Subtype_From_Expr (Empty, T, Indic, Exp); 397 398 Set_Expression (Expression (N), 399 Unchecked_Convert_To (Entity (Indic), Exp)); 400 401 Analyze_And_Resolve (Expression (N), Entity (Indic)); 402 end if; 403 404 if Aggr_In_Place then 405 Tmp_Node := 406 Make_Object_Declaration (Loc, 407 Defining_Identifier => Temp, 408 Object_Definition => New_Reference_To (PtrT, Loc), 409 Expression => 410 Make_Allocator (Loc, 411 New_Reference_To (Etype (Exp), Loc))); 412 413 Set_Comes_From_Source 414 (Expression (Tmp_Node), Comes_From_Source (N)); 415 416 Set_No_Initialization (Expression (Tmp_Node)); 417 Insert_Action (N, Tmp_Node); 418 419 if Controlled_Type (T) 420 and then Ekind (PtrT) = E_Anonymous_Access_Type 421 then 422 -- Create local finalization list for access parameter. 423 424 Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); 425 end if; 426 427 Convert_Aggr_In_Allocator (Tmp_Node, Exp); 428 else 429 Node := Relocate_Node (N); 430 Set_Analyzed (Node); 431 Insert_Action (N, 432 Make_Object_Declaration (Loc, 433 Defining_Identifier => Temp, 434 Constant_Present => True, 435 Object_Definition => New_Reference_To (PtrT, Loc), 436 Expression => Node)); 437 end if; 438 439 -- Suppress the tag assignment when Java_VM because JVM tags 440 -- are represented implicitly in objects. 441 442 if Is_Tagged_Type (T) 443 and then not Is_Class_Wide_Type (T) 444 and then not Java_VM 445 then 446 Tag_Assign := 447 Make_Assignment_Statement (Loc, 448 Name => 449 Make_Selected_Component (Loc, 450 Prefix => New_Reference_To (Temp, Loc), 451 Selector_Name => 452 New_Reference_To (Tag_Component (T), Loc)), 453 454 Expression => 455 Unchecked_Convert_To (RTE (RE_Tag), 456 New_Reference_To (Access_Disp_Table (T), Loc))); 457 458 -- The previous assignment has to be done in any case 459 460 Set_Assignment_OK (Name (Tag_Assign)); 461 Insert_Action (N, Tag_Assign); 462 463 elsif Is_Private_Type (T) 464 and then Is_Tagged_Type (Underlying_Type (T)) 465 and then not Java_VM 466 then 467 declare 468 Utyp : constant Entity_Id := Underlying_Type (T); 469 Ref : constant Node_Id := 470 Unchecked_Convert_To (Utyp, 471 Make_Explicit_Dereference (Loc, 472 New_Reference_To (Temp, Loc))); 473 474 begin 475 Tag_Assign := 476 Make_Assignment_Statement (Loc, 477 Name => 478 Make_Selected_Component (Loc, 479 Prefix => Ref, 480 Selector_Name => 481 New_Reference_To (Tag_Component (Utyp), Loc)), 482 483 Expression => 484 Unchecked_Convert_To (RTE (RE_Tag), 485 New_Reference_To ( 486 Access_Disp_Table (Utyp), Loc))); 487 488 Set_Assignment_OK (Name (Tag_Assign)); 489 Insert_Action (N, Tag_Assign); 490 end; 491 end if; 492 493 if Controlled_Type (Designated_Type (PtrT)) 494 and then Controlled_Type (T) 495 then 496 declare 497 Attach : Node_Id; 498 Apool : constant Entity_Id := 499 Associated_Storage_Pool (PtrT); 500 501 begin 502 -- If it is an allocation on the secondary stack 503 -- (i.e. a value returned from a function), the object 504 -- is attached on the caller side as soon as the call 505 -- is completed (see Expand_Ctrl_Function_Call) 506 507 if Is_RTE (Apool, RE_SS_Pool) then 508 declare 509 F : constant Entity_Id := 510 Make_Defining_Identifier (Loc, 511 New_Internal_Name ('F')); 512 begin 513 Insert_Action (N, 514 Make_Object_Declaration (Loc, 515 Defining_Identifier => F, 516 Object_Definition => New_Reference_To (RTE 517 (RE_Finalizable_Ptr), Loc))); 518 519 Flist := New_Reference_To (F, Loc); 520 Attach := Make_Integer_Literal (Loc, 1); 521 end; 522 523 -- Normal case, not a secondary stack allocation 524 525 else 526 Flist := Find_Final_List (PtrT); 527 Attach := Make_Integer_Literal (Loc, 2); 528 end if; 529 530 if not Aggr_In_Place then 531 Insert_Actions (N, 532 Make_Adjust_Call ( 533 Ref => 534 535 -- An unchecked conversion is needed in the 536 -- classwide case because the designated type 537 -- can be an ancestor of the subtype mark of 538 -- the allocator. 539 540 Unchecked_Convert_To (T, 541 Make_Explicit_Dereference (Loc, 542 New_Reference_To (Temp, Loc))), 543 544 Typ => T, 545 Flist_Ref => Flist, 546 With_Attach => Attach)); 547 end if; 548 end; 549 end if; 550 551 Rewrite (N, New_Reference_To (Temp, Loc)); 552 Analyze_And_Resolve (N, PtrT); 553 554 elsif Aggr_In_Place then 555 Temp := 556 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 557 Tmp_Node := 558 Make_Object_Declaration (Loc, 559 Defining_Identifier => Temp, 560 Object_Definition => New_Reference_To (PtrT, Loc), 561 Expression => Make_Allocator (Loc, 562 New_Reference_To (Etype (Exp), Loc))); 563 564 Set_Comes_From_Source 565 (Expression (Tmp_Node), Comes_From_Source (N)); 566 567 Set_No_Initialization (Expression (Tmp_Node)); 568 Insert_Action (N, Tmp_Node); 569 Convert_Aggr_In_Allocator (Tmp_Node, Exp); 570 Rewrite (N, New_Reference_To (Temp, Loc)); 571 Analyze_And_Resolve (N, PtrT); 572 573 elsif Is_Access_Type (Designated_Type (PtrT)) 574 and then Nkind (Exp) = N_Allocator 575 and then Nkind (Expression (Exp)) /= N_Qualified_Expression 576 then 577 -- Apply constraint to designated subtype indication. 578 579 Apply_Constraint_Check (Expression (Exp), 580 Designated_Type (Designated_Type (PtrT)), 581 No_Sliding => True); 582 583 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then 584 585 -- Propagate constraint_error to enclosing allocator 586 587 Rewrite (Exp, New_Copy (Expression (Exp))); 588 end if; 589 else 590 -- First check against the type of the qualified expression 591 -- 592 -- NOTE: The commented call should be correct, but for 593 -- some reason causes the compiler to bomb (sigsegv) on 594 -- ACVC test c34007g, so for now we just perform the old 595 -- (incorrect) test against the designated subtype with 596 -- no sliding in the else part of the if statement below. 597 -- ??? 598 -- 599 -- Apply_Constraint_Check (Exp, T, No_Sliding => True); 600 601 -- A check is also needed in cases where the designated 602 -- subtype is constrained and differs from the subtype 603 -- given in the qualified expression. Note that the check 604 -- on the qualified expression does not allow sliding, 605 -- but this check does (a relaxation from Ada 83). 606 607 if Is_Constrained (Designated_Type (PtrT)) 608 and then not Subtypes_Statically_Match 609 (T, Designated_Type (PtrT)) 610 then 611 Apply_Constraint_Check 612 (Exp, Designated_Type (PtrT), No_Sliding => False); 613 614 -- The nonsliding check should really be performed 615 -- (unconditionally) against the subtype of the 616 -- qualified expression, but that causes a problem 617 -- with c34007g (see above), so for now we retain this. 618 619 else 620 Apply_Constraint_Check 621 (Exp, Designated_Type (PtrT), No_Sliding => True); 622 end if; 623 end if; 624 625 exception 626 when RE_Not_Available => 627 return; 628 end Expand_Allocator_Expression; 629 630 ----------------------------- 631 -- Expand_Array_Comparison -- 632 ----------------------------- 633 634 -- Expansion is only required in the case of array types. For the 635 -- unpacked case, an appropriate runtime routine is called. For 636 -- packed cases, and also in some other cases where a runtime 637 -- routine cannot be called, the form of the expansion is: 638 639 -- [body for greater_nn; boolean_expression] 640 641 -- The body is built by Make_Array_Comparison_Op, and the form of the 642 -- Boolean expression depends on the operator involved. 643 644 procedure Expand_Array_Comparison (N : Node_Id) is 645 Loc : constant Source_Ptr := Sloc (N); 646 Op1 : Node_Id := Left_Opnd (N); 647 Op2 : Node_Id := Right_Opnd (N); 648 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 649 Ctyp : constant Entity_Id := Component_Type (Typ1); 650 651 Expr : Node_Id; 652 Func_Body : Node_Id; 653 Func_Name : Entity_Id; 654 655 Comp : RE_Id; 656 657 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; 658 -- True for byte addressable target 659 660 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; 661 -- Returns True if the length of the given operand is known to be 662 -- less than 4. Returns False if this length is known to be four 663 -- or greater or is not known at compile time. 664 665 ------------------------ 666 -- Length_Less_Than_4 -- 667 ------------------------ 668 669 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is 670 Otyp : constant Entity_Id := Etype (Opnd); 671 672 begin 673 if Ekind (Otyp) = E_String_Literal_Subtype then 674 return String_Literal_Length (Otyp) < 4; 675 676 else 677 declare 678 Ityp : constant Entity_Id := Etype (First_Index (Otyp)); 679 Lo : constant Node_Id := Type_Low_Bound (Ityp); 680 Hi : constant Node_Id := Type_High_Bound (Ityp); 681 Lov : Uint; 682 Hiv : Uint; 683 684 begin 685 if Compile_Time_Known_Value (Lo) then 686 Lov := Expr_Value (Lo); 687 else 688 return False; 689 end if; 690 691 if Compile_Time_Known_Value (Hi) then 692 Hiv := Expr_Value (Hi); 693 else 694 return False; 695 end if; 696 697 return Hiv < Lov + 3; 698 end; 699 end if; 700 end Length_Less_Than_4; 701 702 -- Start of processing for Expand_Array_Comparison 703 704 begin 705 -- Deal first with unpacked case, where we can call a runtime routine 706 -- except that we avoid this for targets for which are not addressable 707 -- by bytes, and for the JVM, since the JVM does not support direct 708 -- addressing of array components. 709 710 if not Is_Bit_Packed_Array (Typ1) 711 and then Byte_Addressable 712 and then not Java_VM 713 then 714 -- The call we generate is: 715 716 -- Compare_Array_xn[_Unaligned] 717 -- (left'address, right'address, left'length, right'length) <op> 0 718 719 -- x = U for unsigned, S for signed 720 -- n = 8,16,32,64 for component size 721 -- Add _Unaligned if length < 4 and component size is 8. 722 -- <op> is the standard comparison operator 723 724 if Component_Size (Typ1) = 8 then 725 if Length_Less_Than_4 (Op1) 726 or else 727 Length_Less_Than_4 (Op2) 728 then 729 if Is_Unsigned_Type (Ctyp) then 730 Comp := RE_Compare_Array_U8_Unaligned; 731 else 732 Comp := RE_Compare_Array_S8_Unaligned; 733 end if; 734 735 else 736 if Is_Unsigned_Type (Ctyp) then 737 Comp := RE_Compare_Array_U8; 738 else 739 Comp := RE_Compare_Array_S8; 740 end if; 741 end if; 742 743 elsif Component_Size (Typ1) = 16 then 744 if Is_Unsigned_Type (Ctyp) then 745 Comp := RE_Compare_Array_U16; 746 else 747 Comp := RE_Compare_Array_S16; 748 end if; 749 750 elsif Component_Size (Typ1) = 32 then 751 if Is_Unsigned_Type (Ctyp) then 752 Comp := RE_Compare_Array_U32; 753 else 754 Comp := RE_Compare_Array_S32; 755 end if; 756 757 else pragma Assert (Component_Size (Typ1) = 64); 758 if Is_Unsigned_Type (Ctyp) then 759 Comp := RE_Compare_Array_U64; 760 else 761 Comp := RE_Compare_Array_S64; 762 end if; 763 end if; 764 765 Remove_Side_Effects (Op1, Name_Req => True); 766 Remove_Side_Effects (Op2, Name_Req => True); 767 768 Rewrite (Op1, 769 Make_Function_Call (Sloc (Op1), 770 Name => New_Occurrence_Of (RTE (Comp), Loc), 771 772 Parameter_Associations => New_List ( 773 Make_Attribute_Reference (Loc, 774 Prefix => Relocate_Node (Op1), 775 Attribute_Name => Name_Address), 776 777 Make_Attribute_Reference (Loc, 778 Prefix => Relocate_Node (Op2), 779 Attribute_Name => Name_Address), 780 781 Make_Attribute_Reference (Loc, 782 Prefix => Relocate_Node (Op1), 783 Attribute_Name => Name_Length), 784 785 Make_Attribute_Reference (Loc, 786 Prefix => Relocate_Node (Op2), 787 Attribute_Name => Name_Length)))); 788 789 Rewrite (Op2, 790 Make_Integer_Literal (Sloc (Op2), 791 Intval => Uint_0)); 792 793 Analyze_And_Resolve (Op1, Standard_Integer); 794 Analyze_And_Resolve (Op2, Standard_Integer); 795 return; 796 end if; 797 798 -- Cases where we cannot make runtime call 799 800 -- For (a <= b) we convert to not (a > b) 801 802 if Chars (N) = Name_Op_Le then 803 Rewrite (N, 804 Make_Op_Not (Loc, 805 Right_Opnd => 806 Make_Op_Gt (Loc, 807 Left_Opnd => Op1, 808 Right_Opnd => Op2))); 809 Analyze_And_Resolve (N, Standard_Boolean); 810 return; 811 812 -- For < the Boolean expression is 813 -- greater__nn (op2, op1) 814 815 elsif Chars (N) = Name_Op_Lt then 816 Func_Body := Make_Array_Comparison_Op (Typ1, N); 817 818 -- Switch operands 819 820 Op1 := Right_Opnd (N); 821 Op2 := Left_Opnd (N); 822 823 -- For (a >= b) we convert to not (a < b) 824 825 elsif Chars (N) = Name_Op_Ge then 826 Rewrite (N, 827 Make_Op_Not (Loc, 828 Right_Opnd => 829 Make_Op_Lt (Loc, 830 Left_Opnd => Op1, 831 Right_Opnd => Op2))); 832 Analyze_And_Resolve (N, Standard_Boolean); 833 return; 834 835 -- For > the Boolean expression is 836 -- greater__nn (op1, op2) 837 838 else 839 pragma Assert (Chars (N) = Name_Op_Gt); 840 Func_Body := Make_Array_Comparison_Op (Typ1, N); 841 end if; 842 843 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 844 Expr := 845 Make_Function_Call (Loc, 846 Name => New_Reference_To (Func_Name, Loc), 847 Parameter_Associations => New_List (Op1, Op2)); 848 849 Insert_Action (N, Func_Body); 850 Rewrite (N, Expr); 851 Analyze_And_Resolve (N, Standard_Boolean); 852 853 exception 854 when RE_Not_Available => 855 return; 856 end Expand_Array_Comparison; 857 858 --------------------------- 859 -- Expand_Array_Equality -- 860 --------------------------- 861 862 -- Expand an equality function for multi-dimensional arrays. Here is 863 -- an example of such a function for Nb_Dimension = 2 864 865 -- function Enn (A : arr; B : arr) return boolean is 866 -- begin 867 -- if (A'length (1) = 0 or else A'length (2) = 0) 868 -- and then 869 -- (B'length (1) = 0 or else B'length (2) = 0) 870 -- then 871 -- return True; -- RM 4.5.2(22) 872 -- end if; 873 -- 874 -- if A'length (1) /= B'length (1) 875 -- or else 876 -- A'length (2) /= B'length (2) 877 -- then 878 -- return False; -- RM 4.5.2(23) 879 -- end if; 880 -- 881 -- declare 882 -- A1 : Index_type_1 := A'first (1) 883 -- B1 : Index_Type_1 := B'first (1) 884 -- begin 885 -- loop 886 -- declare 887 -- A2 : Index_type_2 := A'first (2); 888 -- B2 : Index_type_2 := B'first (2) 889 -- begin 890 -- loop 891 -- if A (A1, A2) /= B (B1, B2) then 892 -- return False; 893 -- end if; 894 -- 895 -- exit when A2 = A'last (2); 896 -- A2 := Index_type2'succ (A2); 897 -- B2 := Index_type2'succ (B2); 898 -- end loop; 899 -- end; 900 -- 901 -- exit when A1 = A'last (1); 902 -- A1 := Index_type1'succ (A1); 903 -- B1 := Index_type1'succ (B1); 904 -- end loop; 905 -- end; 906 -- 907 -- return true; 908 -- end Enn; 909 910 function Expand_Array_Equality 911 (Nod : Node_Id; 912 Typ : Entity_Id; 913 A_Typ : Entity_Id; 914 Lhs : Node_Id; 915 Rhs : Node_Id; 916 Bodies : List_Id) 917 return Node_Id 918 is 919 Loc : constant Source_Ptr := Sloc (Nod); 920 Decls : constant List_Id := New_List; 921 Index_List1 : constant List_Id := New_List; 922 Index_List2 : constant List_Id := New_List; 923 924 Actuals : List_Id; 925 Formals : List_Id; 926 Func_Name : Entity_Id; 927 Func_Body : Node_Id; 928 929 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 930 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 931 932 function Arr_Attr 933 (Arr : Entity_Id; 934 Nam : Name_Id; 935 Num : Int) 936 return Node_Id; 937 -- This builds the attribute reference Arr'Nam (Expr). 938 939 function Component_Equality (Typ : Entity_Id) return Node_Id; 940 -- Create one statement to compare corresponding components, 941 -- designated by a full set of indices. 942 943 function Handle_One_Dimension 944 (N : Int; 945 Index : Node_Id) 946 return Node_Id; 947 -- This procedure returns a declare block: 948 -- 949 -- declare 950 -- An : Index_Type_n := A'First (n); 951 -- Bn : Index_Type_n := B'First (n); 952 -- begin 953 -- loop 954 -- xxx 955 -- exit when An = A'Last (n); 956 -- An := Index_Type_n'Succ (An) 957 -- Bn := Index_Type_n'Succ (Bn) 958 -- end loop; 959 -- end; 960 -- 961 -- where N is the value of "n" in the above code. Index is the 962 -- N'th index node, whose Etype is Index_Type_n in the above code. 963 -- The xxx statement is either the declare block for the next 964 -- dimension or if this is the last dimension the comparison 965 -- of corresponding components of the arrays. 966 -- 967 -- The actual way the code works is to return the comparison 968 -- of corresponding components for the N+1 call. That's neater! 969 970 function Test_Empty_Arrays return Node_Id; 971 -- This function constructs the test for both arrays being empty 972 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) 973 -- and then 974 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) 975 976 function Test_Lengths_Correspond return Node_Id; 977 -- This function constructs the test for arrays having different 978 -- lengths in at least one index position, in which case resull 979 980 -- A'length (1) /= B'length (1) 981 -- or else 982 -- A'length (2) /= B'length (2) 983 -- or else 984 -- ... 985 986 -------------- 987 -- Arr_Attr -- 988 -------------- 989 990 function Arr_Attr 991 (Arr : Entity_Id; 992 Nam : Name_Id; 993 Num : Int) 994 return Node_Id 995 is 996 begin 997 return 998 Make_Attribute_Reference (Loc, 999 Attribute_Name => Nam, 1000 Prefix => New_Reference_To (Arr, Loc), 1001 Expressions => New_List (Make_Integer_Literal (Loc, Num))); 1002 end Arr_Attr; 1003 1004 ------------------------ 1005 -- Component_Equality -- 1006 ------------------------ 1007 1008 function Component_Equality (Typ : Entity_Id) return Node_Id is 1009 Test : Node_Id; 1010 L, R : Node_Id; 1011 1012 begin 1013 -- if a(i1...) /= b(j1...) then return false; end if; 1014 1015 L := 1016 Make_Indexed_Component (Loc, 1017 Prefix => Make_Identifier (Loc, Chars (A)), 1018 Expressions => Index_List1); 1019 1020 R := 1021 Make_Indexed_Component (Loc, 1022 Prefix => Make_Identifier (Loc, Chars (B)), 1023 Expressions => Index_List2); 1024 1025 Test := Expand_Composite_Equality 1026 (Nod, Component_Type (Typ), L, R, Decls); 1027 1028 return 1029 Make_Implicit_If_Statement (Nod, 1030 Condition => Make_Op_Not (Loc, Right_Opnd => Test), 1031 Then_Statements => New_List ( 1032 Make_Return_Statement (Loc, 1033 Expression => New_Occurrence_Of (Standard_False, Loc)))); 1034 end Component_Equality; 1035 1036 -------------------------- 1037 -- Handle_One_Dimension -- 1038 --------------------------- 1039 1040 function Handle_One_Dimension 1041 (N : Int; 1042 Index : Node_Id) 1043 return Node_Id 1044 is 1045 An : constant Entity_Id := Make_Defining_Identifier (Loc, 1046 Chars => New_Internal_Name ('A')); 1047 Bn : constant Entity_Id := Make_Defining_Identifier (Loc, 1048 Chars => New_Internal_Name ('B')); 1049 Index_Type_n : Entity_Id; 1050 1051 begin 1052 if N > Number_Dimensions (Typ) then 1053 return Component_Equality (Typ); 1054 end if; 1055 1056 -- Case where we generate a declare block 1057 1058 Index_Type_n := Base_Type (Etype (Index)); 1059 Append (New_Reference_To (An, Loc), Index_List1); 1060 Append (New_Reference_To (Bn, Loc), Index_List2); 1061 1062 return 1063 Make_Block_Statement (Loc, 1064 Declarations => New_List ( 1065 Make_Object_Declaration (Loc, 1066 Defining_Identifier => An, 1067 Object_Definition => 1068 New_Reference_To (Index_Type_n, Loc), 1069 Expression => Arr_Attr (A, Name_First, N)), 1070 1071 Make_Object_Declaration (Loc, 1072 Defining_Identifier => Bn, 1073 Object_Definition => 1074 New_Reference_To (Index_Type_n, Loc), 1075 Expression => Arr_Attr (B, Name_First, N))), 1076 1077 Handled_Statement_Sequence => 1078 Make_Handled_Sequence_Of_Statements (Loc, 1079 Statements => New_List ( 1080 Make_Implicit_Loop_Statement (Nod, 1081 Statements => New_List ( 1082 Handle_One_Dimension (N + 1, Next_Index (Index)), 1083 1084 Make_Exit_Statement (Loc, 1085 Condition => 1086 Make_Op_Eq (Loc, 1087 Left_Opnd => New_Reference_To (An, Loc), 1088 Right_Opnd => Arr_Attr (A, Name_Last, N))), 1089 1090 Make_Assignment_Statement (Loc, 1091 Name => New_Reference_To (An, Loc), 1092 Expression => 1093 Make_Attribute_Reference (Loc, 1094 Prefix => 1095 New_Reference_To (Index_Type_n, Loc), 1096 Attribute_Name => Name_Succ, 1097 Expressions => New_List ( 1098 New_Reference_To (An, Loc)))), 1099 1100 Make_Assignment_Statement (Loc, 1101 Name => New_Reference_To (Bn, Loc), 1102 Expression => 1103 Make_Attribute_Reference (Loc, 1104 Prefix => 1105 New_Reference_To (Index_Type_n, Loc), 1106 Attribute_Name => Name_Succ, 1107 Expressions => New_List ( 1108 New_Reference_To (Bn, Loc))))))))); 1109 end Handle_One_Dimension; 1110 1111 ----------------------- 1112 -- Test_Empty_Arrays -- 1113 ----------------------- 1114 1115 function Test_Empty_Arrays return Node_Id is 1116 Alist : Node_Id; 1117 Blist : Node_Id; 1118 1119 Atest : Node_Id; 1120 Btest : Node_Id; 1121 1122 begin 1123 Alist := Empty; 1124 Blist := Empty; 1125 for J in 1 .. Number_Dimensions (Typ) loop 1126 Atest := 1127 Make_Op_Eq (Loc, 1128 Left_Opnd => Arr_Attr (A, Name_Length, J), 1129 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1130 1131 Btest := 1132 Make_Op_Eq (Loc, 1133 Left_Opnd => Arr_Attr (B, Name_Length, J), 1134 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1135 1136 if No (Alist) then 1137 Alist := Atest; 1138 Blist := Btest; 1139 1140 else 1141 Alist := 1142 Make_Or_Else (Loc, 1143 Left_Opnd => Relocate_Node (Alist), 1144 Right_Opnd => Atest); 1145 1146 Blist := 1147 Make_Or_Else (Loc, 1148 Left_Opnd => Relocate_Node (Blist), 1149 Right_Opnd => Btest); 1150 end if; 1151 end loop; 1152 1153 return 1154 Make_And_Then (Loc, 1155 Left_Opnd => Alist, 1156 Right_Opnd => Blist); 1157 end Test_Empty_Arrays; 1158 1159 ----------------------------- 1160 -- Test_Lengths_Correspond -- 1161 ----------------------------- 1162 1163 function Test_Lengths_Correspond return Node_Id is 1164 Result : Node_Id; 1165 Rtest : Node_Id; 1166 1167 begin 1168 Result := Empty; 1169 for J in 1 .. Number_Dimensions (Typ) loop 1170 Rtest := 1171 Make_Op_Ne (Loc, 1172 Left_Opnd => Arr_Attr (A, Name_Length, J), 1173 Right_Opnd => Arr_Attr (B, Name_Length, J)); 1174 1175 if No (Result) then 1176 Result := Rtest; 1177 else 1178 Result := 1179 Make_Or_Else (Loc, 1180 Left_Opnd => Relocate_Node (Result), 1181 Right_Opnd => Rtest); 1182 end if; 1183 end loop; 1184 1185 return Result; 1186 end Test_Lengths_Correspond; 1187 1188 -- Start of processing for Expand_Array_Equality 1189 1190 begin 1191 Formals := New_List ( 1192 Make_Parameter_Specification (Loc, 1193 Defining_Identifier => A, 1194 Parameter_Type => New_Reference_To (Typ, Loc)), 1195 1196 Make_Parameter_Specification (Loc, 1197 Defining_Identifier => B, 1198 Parameter_Type => New_Reference_To (Typ, Loc))); 1199 1200 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); 1201 1202 -- Build statement sequence for function 1203 1204 Func_Body := 1205 Make_Subprogram_Body (Loc, 1206 Specification => 1207 Make_Function_Specification (Loc, 1208 Defining_Unit_Name => Func_Name, 1209 Parameter_Specifications => Formals, 1210 Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), 1211 1212 Declarations => Decls, 1213 1214 Handled_Statement_Sequence => 1215 Make_Handled_Sequence_Of_Statements (Loc, 1216 Statements => New_List ( 1217 1218 Make_Implicit_If_Statement (Nod, 1219 Condition => Test_Empty_Arrays, 1220 Then_Statements => New_List ( 1221 Make_Return_Statement (Loc, 1222 Expression => 1223 New_Occurrence_Of (Standard_True, Loc)))), 1224 1225 Make_Implicit_If_Statement (Nod, 1226 Condition => Test_Lengths_Correspond, 1227 Then_Statements => New_List ( 1228 Make_Return_Statement (Loc, 1229 Expression => 1230 New_Occurrence_Of (Standard_False, Loc)))), 1231 1232 Handle_One_Dimension (1, First_Index (Typ)), 1233 1234 Make_Return_Statement (Loc, 1235 Expression => New_Occurrence_Of (Standard_True, Loc))))); 1236 1237 Set_Has_Completion (Func_Name, True); 1238 1239 -- If the array type is distinct from the type of the arguments, 1240 -- it is the full view of a private type. Apply an unchecked 1241 -- conversion to insure that analysis of the call succeeds. 1242 1243 if Base_Type (A_Typ) /= Base_Type (Typ) then 1244 Actuals := New_List ( 1245 OK_Convert_To (Typ, Lhs), 1246 OK_Convert_To (Typ, Rhs)); 1247 else 1248 Actuals := New_List (Lhs, Rhs); 1249 end if; 1250 1251 Append_To (Bodies, Func_Body); 1252 1253 return 1254 Make_Function_Call (Loc, 1255 Name => New_Reference_To (Func_Name, Loc), 1256 Parameter_Associations => Actuals); 1257 end Expand_Array_Equality; 1258 1259 ----------------------------- 1260 -- Expand_Boolean_Operator -- 1261 ----------------------------- 1262 1263 -- Note that we first get the actual subtypes of the operands, 1264 -- since we always want to deal with types that have bounds. 1265 1266 procedure Expand_Boolean_Operator (N : Node_Id) is 1267 Typ : constant Entity_Id := Etype (N); 1268 1269 begin 1270 if Is_Bit_Packed_Array (Typ) then 1271 Expand_Packed_Boolean_Operator (N); 1272 1273 else 1274 -- For the normal non-packed case, the general expansion is 1275 -- to build a function for carrying out the comparison (using 1276 -- Make_Boolean_Array_Op) and then inserting it into the tree. 1277 -- The original operator node is then rewritten as a call to 1278 -- this function. 1279 1280 declare 1281 Loc : constant Source_Ptr := Sloc (N); 1282 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 1283 R : constant Node_Id := Relocate_Node (Right_Opnd (N)); 1284 Func_Body : Node_Id; 1285 Func_Name : Entity_Id; 1286 1287 begin 1288 Convert_To_Actual_Subtype (L); 1289 Convert_To_Actual_Subtype (R); 1290 Ensure_Defined (Etype (L), N); 1291 Ensure_Defined (Etype (R), N); 1292 Apply_Length_Check (R, Etype (L)); 1293 1294 if Nkind (Parent (N)) = N_Assignment_Statement 1295 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) 1296 then 1297 Build_Boolean_Array_Proc_Call (Parent (N), L, R); 1298 1299 elsif Nkind (Parent (N)) = N_Op_Not 1300 and then Nkind (N) = N_Op_And 1301 and then 1302 Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) 1303 then 1304 return; 1305 else 1306 1307 Func_Body := Make_Boolean_Array_Op (Etype (L), N); 1308 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 1309 Insert_Action (N, Func_Body); 1310 1311 -- Now rewrite the expression with a call 1312 1313 Rewrite (N, 1314 Make_Function_Call (Loc, 1315 Name => New_Reference_To (Func_Name, Loc), 1316 Parameter_Associations => 1317 New_List 1318 (L, Make_Type_Conversion 1319 (Loc, New_Reference_To (Etype (L), Loc), R)))); 1320 1321 Analyze_And_Resolve (N, Typ); 1322 end if; 1323 end; 1324 end if; 1325 end Expand_Boolean_Operator; 1326 1327 ------------------------------- 1328 -- Expand_Composite_Equality -- 1329 ------------------------------- 1330 1331 -- This function is only called for comparing internal fields of composite 1332 -- types when these fields are themselves composites. This is a special 1333 -- case because it is not possible to respect normal Ada visibility rules. 1334 1335 function Expand_Composite_Equality 1336 (Nod : Node_Id; 1337 Typ : Entity_Id; 1338 Lhs : Node_Id; 1339 Rhs : Node_Id; 1340 Bodies : List_Id) 1341 return Node_Id 1342 is 1343 Loc : constant Source_Ptr := Sloc (Nod); 1344 Full_Type : Entity_Id; 1345 Prim : Elmt_Id; 1346 Eq_Op : Entity_Id; 1347 1348 begin 1349 if Is_Private_Type (Typ) then 1350 Full_Type := Underlying_Type (Typ); 1351 else 1352 Full_Type := Typ; 1353 end if; 1354 1355 -- Defense against malformed private types with no completion 1356 -- the error will be diagnosed later by check_completion 1357 1358 if No (Full_Type) then 1359 return New_Reference_To (Standard_False, Loc); 1360 end if; 1361 1362 Full_Type := Base_Type (Full_Type); 1363 1364 if Is_Array_Type (Full_Type) then 1365 1366 -- If the operand is an elementary type other than a floating-point 1367 -- type, then we can simply use the built-in block bitwise equality, 1368 -- since the predefined equality operators always apply and bitwise 1369 -- equality is fine for all these cases. 1370 1371 if Is_Elementary_Type (Component_Type (Full_Type)) 1372 and then not Is_Floating_Point_Type (Component_Type (Full_Type)) 1373 then 1374 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 1375 1376 -- For composite component types, and floating-point types, use 1377 -- the expansion. This deals with tagged component types (where 1378 -- we use the applicable equality routine) and floating-point, 1379 -- (where we need to worry about negative zeroes), and also the 1380 -- case of any composite type recursively containing such fields. 1381 1382 else 1383 return Expand_Array_Equality 1384 (Nod, Full_Type, Typ, Lhs, Rhs, Bodies); 1385 end if; 1386 1387 elsif Is_Tagged_Type (Full_Type) then 1388 1389 -- Call the primitive operation "=" of this type 1390 1391 if Is_Class_Wide_Type (Full_Type) then 1392 Full_Type := Root_Type (Full_Type); 1393 end if; 1394 1395 -- If this is derived from an untagged private type completed 1396 -- with a tagged type, it does not have a full view, so we 1397 -- use the primitive operations of the private type. 1398 -- This check should no longer be necessary when these 1399 -- types receive their full views ??? 1400 1401 if Is_Private_Type (Typ) 1402 and then not Is_Tagged_Type (Typ) 1403 and then not Is_Controlled (Typ) 1404 and then Is_Derived_Type (Typ) 1405 and then No (Full_View (Typ)) 1406 then 1407 Prim := First_Elmt (Collect_Primitive_Operations (Typ)); 1408 else 1409 Prim := First_Elmt (Primitive_Operations (Full_Type)); 1410 end if; 1411 1412 loop 1413 Eq_Op := Node (Prim); 1414 exit when Chars (Eq_Op) = Name_Op_Eq 1415 and then Etype (First_Formal (Eq_Op)) = 1416 Etype (Next_Formal (First_Formal (Eq_Op))); 1417 Next_Elmt (Prim); 1418 pragma Assert (Present (Prim)); 1419 end loop; 1420 1421 Eq_Op := Node (Prim); 1422 1423 return 1424 Make_Function_Call (Loc, 1425 Name => New_Reference_To (Eq_Op, Loc), 1426 Parameter_Associations => 1427 New_List 1428 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), 1429 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); 1430 1431 elsif Is_Record_Type (Full_Type) then 1432 Eq_Op := TSS (Full_Type, TSS_Composite_Equality); 1433 1434 if Present (Eq_Op) then 1435 if Etype (First_Formal (Eq_Op)) /= Full_Type then 1436 1437 -- Inherited equality from parent type. Convert the actuals 1438 -- to match signature of operation. 1439 1440 declare 1441 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 1442 1443 begin 1444 return 1445 Make_Function_Call (Loc, 1446 Name => New_Reference_To (Eq_Op, Loc), 1447 Parameter_Associations => 1448 New_List (OK_Convert_To (T, Lhs), 1449 OK_Convert_To (T, Rhs))); 1450 end; 1451 1452 else 1453 return 1454 Make_Function_Call (Loc, 1455 Name => New_Reference_To (Eq_Op, Loc), 1456 Parameter_Associations => New_List (Lhs, Rhs)); 1457 end if; 1458 1459 else 1460 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); 1461 end if; 1462 1463 else 1464 -- It can be a simple record or the full view of a scalar private 1465 1466 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 1467 end if; 1468 end Expand_Composite_Equality; 1469 1470 ------------------------------ 1471 -- Expand_Concatenate_Other -- 1472 ------------------------------ 1473 1474 -- Let n be the number of array operands to be concatenated, Base_Typ 1475 -- their base type, Ind_Typ their index type, and Arr_Typ the original 1476 -- array type to which the concatenantion operator applies, then the 1477 -- following subprogram is constructed: 1478 1479 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is 1480 -- L : Ind_Typ; 1481 -- begin 1482 -- if S1'Length /= 0 then 1483 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained 1484 -- XXX = Arr_Typ'First otherwise 1485 -- elsif S2'Length /= 0 then 1486 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained 1487 -- YYY = Arr_Typ'First otherwise 1488 -- ... 1489 -- elsif Sn-1'Length /= 0 then 1490 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained 1491 -- ZZZ = Arr_Typ'First otherwise 1492 -- else 1493 -- return Sn; 1494 -- end if; 1495 1496 -- declare 1497 -- P : Ind_Typ; 1498 -- H : Ind_Typ := 1499 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length) 1500 -- + Ind_Typ'Pos (L)); 1501 -- R : Base_Typ (L .. H); 1502 -- begin 1503 -- if S1'Length /= 0 then 1504 -- P := S1'First; 1505 -- loop 1506 -- R (L) := S1 (P); 1507 -- L := Ind_Typ'Succ (L); 1508 -- exit when P = S1'Last; 1509 -- P := Ind_Typ'Succ (P); 1510 -- end loop; 1511 -- end if; 1512 -- 1513 -- if S2'Length /= 0 then 1514 -- L := Ind_Typ'Succ (L); 1515 -- loop 1516 -- R (L) := S2 (P); 1517 -- L := Ind_Typ'Succ (L); 1518 -- exit when P = S2'Last; 1519 -- P := Ind_Typ'Succ (P); 1520 -- end loop; 1521 -- end if; 1522 1523 -- ... 1524 1525 -- if Sn'Length /= 0 then 1526 -- P := Sn'First; 1527 -- loop 1528 -- R (L) := Sn (P); 1529 -- L := Ind_Typ'Succ (L); 1530 -- exit when P = Sn'Last; 1531 -- P := Ind_Typ'Succ (P); 1532 -- end loop; 1533 -- end if; 1534 1535 -- return R; 1536 -- end; 1537 -- end Cnn;] 1538 1539 procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is 1540 Loc : constant Source_Ptr := Sloc (Cnode); 1541 Nb_Opnds : constant Nat := List_Length (Opnds); 1542 1543 Arr_Typ : constant Entity_Id := Etype (Entity (Cnode)); 1544 Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode)); 1545 Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ)); 1546 1547 Func_Id : Node_Id; 1548 Func_Spec : Node_Id; 1549 Param_Specs : List_Id; 1550 1551 Func_Body : Node_Id; 1552 Func_Decls : List_Id; 1553 Func_Stmts : List_Id; 1554 1555 L_Decl : Node_Id; 1556 1557 If_Stmt : Node_Id; 1558 Elsif_List : List_Id; 1559 1560 Declare_Block : Node_Id; 1561 Declare_Decls : List_Id; 1562 Declare_Stmts : List_Id; 1563 1564 H_Decl : Node_Id; 1565 H_Init : Node_Id; 1566 P_Decl : Node_Id; 1567 R_Decl : Node_Id; 1568 R_Constr : Node_Id; 1569 R_Range : Node_Id; 1570 1571 Params : List_Id; 1572 Operand : Node_Id; 1573 1574 function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id; 1575 -- Builds the sequence of statement: 1576 -- P := Si'First; 1577 -- loop 1578 -- R (L) := Si (P); 1579 -- L := Ind_Typ'Succ (L); 1580 -- exit when P = Si'Last; 1581 -- P := Ind_Typ'Succ (P); 1582 -- end loop; 1583 -- 1584 -- where i is the input parameter I given. 1585 -- If the flag Last is true, the exit statement is emitted before 1586 -- incrementing the lower bound, to prevent the creation out of 1587 -- bound values. 1588 1589 function Init_L (I : Nat) return Node_Id; 1590 -- Builds the statement: 1591 -- L := Arr_Typ'First; If Arr_Typ is constrained 1592 -- L := Si'First; otherwise (where I is the input param given) 1593 1594 function H return Node_Id; 1595 -- Builds reference to identifier H. 1596 1597 function Ind_Val (E : Node_Id) return Node_Id; 1598 -- Builds expression Ind_Typ'Val (E); 1599 1600 function L return Node_Id; 1601 -- Builds reference to identifier L. 1602 1603 function L_Pos return Node_Id; 1604 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). 1605 -- We qualify the expression to avoid universal_integer computations 1606 -- whenever possible, in the expression for the upper bound H. 1607 1608 function L_Succ return Node_Id; 1609 -- Builds expression Ind_Typ'Succ (L). 1610 1611 function One return Node_Id; 1612 -- Builds integer literal one. 1613 1614 function P return Node_Id; 1615 -- Builds reference to identifier P. 1616 1617 function P_Succ return Node_Id; 1618 -- Builds expression Ind_Typ'Succ (P). 1619 1620 function R return Node_Id; 1621 -- Builds reference to identifier R. 1622 1623 function S (I : Nat) return Node_Id; 1624 -- Builds reference to identifier Si, where I is the value given. 1625 1626 function S_First (I : Nat) return Node_Id; 1627 -- Builds expression Si'First, where I is the value given. 1628 1629 function S_Last (I : Nat) return Node_Id; 1630 -- Builds expression Si'Last, where I is the value given. 1631 1632 function S_Length (I : Nat) return Node_Id; 1633 -- Builds expression Si'Length, where I is the value given. 1634 1635 function S_Length_Test (I : Nat) return Node_Id; 1636 -- Builds expression Si'Length /= 0, where I is the value given. 1637 1638 ------------------- 1639 -- Copy_Into_R_S -- 1640 ------------------- 1641 1642 function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is 1643 Stmts : constant List_Id := New_List; 1644 P_Start : Node_Id; 1645 Loop_Stmt : Node_Id; 1646 R_Copy : Node_Id; 1647 Exit_Stmt : Node_Id; 1648 L_Inc : Node_Id; 1649 P_Inc : Node_Id; 1650 1651 begin 1652 -- First construct the initializations 1653 1654 P_Start := Make_Assignment_Statement (Loc, 1655 Name => P, 1656 Expression => S_First (I)); 1657 Append_To (Stmts, P_Start); 1658 1659 -- Then build the loop 1660 1661 R_Copy := Make_Assignment_Statement (Loc, 1662 Name => Make_Indexed_Component (Loc, 1663 Prefix => R, 1664 Expressions => New_List (L)), 1665 Expression => Make_Indexed_Component (Loc, 1666 Prefix => S (I), 1667 Expressions => New_List (P))); 1668 1669 L_Inc := Make_Assignment_Statement (Loc, 1670 Name => L, 1671 Expression => L_Succ); 1672 1673 Exit_Stmt := Make_Exit_Statement (Loc, 1674 Condition => Make_Op_Eq (Loc, P, S_Last (I))); 1675 1676 P_Inc := Make_Assignment_Statement (Loc, 1677 Name => P, 1678 Expression => P_Succ); 1679 1680 if Last then 1681 Loop_Stmt := 1682 Make_Implicit_Loop_Statement (Cnode, 1683 Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc)); 1684 else 1685 Loop_Stmt := 1686 Make_Implicit_Loop_Statement (Cnode, 1687 Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc)); 1688 end if; 1689 1690 Append_To (Stmts, Loop_Stmt); 1691 1692 return Stmts; 1693 end Copy_Into_R_S; 1694 1695 ------- 1696 -- H -- 1697 ------- 1698 1699 function H return Node_Id is 1700 begin 1701 return Make_Identifier (Loc, Name_uH); 1702 end H; 1703 1704 ------------- 1705 -- Ind_Val -- 1706 ------------- 1707 1708 function Ind_Val (E : Node_Id) return Node_Id is 1709 begin 1710 return 1711 Make_Attribute_Reference (Loc, 1712 Prefix => New_Reference_To (Ind_Typ, Loc), 1713 Attribute_Name => Name_Val, 1714 Expressions => New_List (E)); 1715 end Ind_Val; 1716 1717 ------------ 1718 -- Init_L -- 1719 ------------ 1720 1721 function Init_L (I : Nat) return Node_Id is 1722 E : Node_Id; 1723 1724 begin 1725 if Is_Constrained (Arr_Typ) then 1726 E := Make_Attribute_Reference (Loc, 1727 Prefix => New_Reference_To (Arr_Typ, Loc), 1728 Attribute_Name => Name_First); 1729 1730 else 1731 E := S_First (I); 1732 end if; 1733 1734 return Make_Assignment_Statement (Loc, Name => L, Expression => E); 1735 end Init_L; 1736 1737 ------- 1738 -- L -- 1739 ------- 1740 1741 function L return Node_Id is 1742 begin 1743 return Make_Identifier (Loc, Name_uL); 1744 end L; 1745 1746 ----------- 1747 -- L_Pos -- 1748 ----------- 1749 1750 function L_Pos return Node_Id is 1751 Target_Type : Entity_Id; 1752 1753 begin 1754 -- If the index type is an enumeration type, the computation 1755 -- can be done in standard integer. Otherwise, choose a large 1756 -- enough integer type. 1757 1758 if Is_Enumeration_Type (Ind_Typ) 1759 or else Root_Type (Ind_Typ) = Standard_Integer 1760 or else Root_Type (Ind_Typ) = Standard_Short_Integer 1761 or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer 1762 then 1763 Target_Type := Standard_Integer; 1764 else 1765 Target_Type := Root_Type (Ind_Typ); 1766 end if; 1767 1768 return 1769 Make_Qualified_Expression (Loc, 1770 Subtype_Mark => New_Reference_To (Target_Type, Loc), 1771 Expression => 1772 Make_Attribute_Reference (Loc, 1773 Prefix => New_Reference_To (Ind_Typ, Loc), 1774 Attribute_Name => Name_Pos, 1775 Expressions => New_List (L))); 1776 end L_Pos; 1777 1778 ------------ 1779 -- L_Succ -- 1780 ------------ 1781 1782 function L_Succ return Node_Id is 1783 begin 1784 return 1785 Make_Attribute_Reference (Loc, 1786 Prefix => New_Reference_To (Ind_Typ, Loc), 1787 Attribute_Name => Name_Succ, 1788 Expressions => New_List (L)); 1789 end L_Succ; 1790 1791 --------- 1792 -- One -- 1793 --------- 1794 1795 function One return Node_Id is 1796 begin 1797 return Make_Integer_Literal (Loc, 1); 1798 end One; 1799 1800 ------- 1801 -- P -- 1802 ------- 1803 1804 function P return Node_Id is 1805 begin 1806 return Make_Identifier (Loc, Name_uP); 1807 end P; 1808 1809 ------------ 1810 -- P_Succ -- 1811 ------------ 1812 1813 function P_Succ return Node_Id is 1814 begin 1815 return 1816 Make_Attribute_Reference (Loc, 1817 Prefix => New_Reference_To (Ind_Typ, Loc), 1818 Attribute_Name => Name_Succ, 1819 Expressions => New_List (P)); 1820 end P_Succ; 1821 1822 ------- 1823 -- R -- 1824 ------- 1825 1826 function R return Node_Id is 1827 begin 1828 return Make_Identifier (Loc, Name_uR); 1829 end R; 1830 1831 ------- 1832 -- S -- 1833 ------- 1834 1835 function S (I : Nat) return Node_Id is 1836 begin 1837 return Make_Identifier (Loc, New_External_Name ('S', I)); 1838 end S; 1839 1840 ------------- 1841 -- S_First -- 1842 ------------- 1843 1844 function S_First (I : Nat) return Node_Id is 1845 begin 1846 return Make_Attribute_Reference (Loc, 1847 Prefix => S (I), 1848 Attribute_Name => Name_First); 1849 end S_First; 1850 1851 ------------ 1852 -- S_Last -- 1853 ------------ 1854 1855 function S_Last (I : Nat) return Node_Id is 1856 begin 1857 return Make_Attribute_Reference (Loc, 1858 Prefix => S (I), 1859 Attribute_Name => Name_Last); 1860 end S_Last; 1861 1862 -------------- 1863 -- S_Length -- 1864 -------------- 1865 1866 function S_Length (I : Nat) return Node_Id is 1867 begin 1868 return Make_Attribute_Reference (Loc, 1869 Prefix => S (I), 1870 Attribute_Name => Name_Length); 1871 end S_Length; 1872 1873 ------------------- 1874 -- S_Length_Test -- 1875 ------------------- 1876 1877 function S_Length_Test (I : Nat) return Node_Id is 1878 begin 1879 return 1880 Make_Op_Ne (Loc, 1881 Left_Opnd => S_Length (I), 1882 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1883 end S_Length_Test; 1884 1885 -- Start of processing for Expand_Concatenate_Other 1886 1887 begin 1888 -- Construct the parameter specs and the overall function spec 1889 1890 Param_Specs := New_List; 1891 for I in 1 .. Nb_Opnds loop 1892 Append_To 1893 (Param_Specs, 1894 Make_Parameter_Specification (Loc, 1895 Defining_Identifier => 1896 Make_Defining_Identifier (Loc, New_External_Name ('S', I)), 1897 Parameter_Type => New_Reference_To (Base_Typ, Loc))); 1898 end loop; 1899 1900 Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); 1901 Func_Spec := 1902 Make_Function_Specification (Loc, 1903 Defining_Unit_Name => Func_Id, 1904 Parameter_Specifications => Param_Specs, 1905 Subtype_Mark => New_Reference_To (Base_Typ, Loc)); 1906 1907 -- Construct L's object declaration 1908 1909 L_Decl := 1910 Make_Object_Declaration (Loc, 1911 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL), 1912 Object_Definition => New_Reference_To (Ind_Typ, Loc)); 1913 1914 Func_Decls := New_List (L_Decl); 1915 1916 -- Construct the if-then-elsif statements 1917 1918 Elsif_List := New_List; 1919 for I in 2 .. Nb_Opnds - 1 loop 1920 Append_To (Elsif_List, Make_Elsif_Part (Loc, 1921 Condition => S_Length_Test (I), 1922 Then_Statements => New_List (Init_L (I)))); 1923 end loop; 1924 1925 If_Stmt := 1926 Make_Implicit_If_Statement (Cnode, 1927 Condition => S_Length_Test (1), 1928 Then_Statements => New_List (Init_L (1)), 1929 Elsif_Parts => Elsif_List, 1930 Else_Statements => New_List (Make_Return_Statement (Loc, 1931 Expression => S (Nb_Opnds)))); 1932 1933 -- Construct the declaration for H 1934 1935 P_Decl := 1936 Make_Object_Declaration (Loc, 1937 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), 1938 Object_Definition => New_Reference_To (Ind_Typ, Loc)); 1939 1940 H_Init := Make_Op_Subtract (Loc, S_Length (1), One); 1941 for I in 2 .. Nb_Opnds loop 1942 H_Init := Make_Op_Add (Loc, H_Init, S_Length (I)); 1943 end loop; 1944 H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); 1945 1946 H_Decl := 1947 Make_Object_Declaration (Loc, 1948 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH), 1949 Object_Definition => New_Reference_To (Ind_Typ, Loc), 1950 Expression => H_Init); 1951 1952 -- Construct the declaration for R 1953 1954 R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H); 1955 R_Constr := 1956 Make_Index_Or_Discriminant_Constraint (Loc, 1957 Constraints => New_List (R_Range)); 1958 1959 R_Decl := 1960 Make_Object_Declaration (Loc, 1961 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR), 1962 Object_Definition => 1963 Make_Subtype_Indication (Loc, 1964 Subtype_Mark => New_Reference_To (Base_Typ, Loc), 1965 Constraint => R_Constr)); 1966 1967 -- Construct the declarations for the declare block 1968 1969 Declare_Decls := New_List (P_Decl, H_Decl, R_Decl); 1970 1971 -- Construct list of statements for the declare block 1972 1973 Declare_Stmts := New_List; 1974 for I in 1 .. Nb_Opnds loop 1975 Append_To (Declare_Stmts, 1976 Make_Implicit_If_Statement (Cnode, 1977 Condition => S_Length_Test (I), 1978 Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds))); 1979 end loop; 1980 1981 Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R)); 1982 1983 -- Construct the declare block 1984 1985 Declare_Block := Make_Block_Statement (Loc, 1986 Declarations => Declare_Decls, 1987 Handled_Statement_Sequence => 1988 Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts)); 1989 1990 -- Construct the list of function statements 1991 1992 Func_Stmts := New_List (If_Stmt, Declare_Block); 1993 1994 -- Construct the function body 1995 1996 Func_Body := 1997 Make_Subprogram_Body (Loc, 1998 Specification => Func_Spec, 1999 Declarations => Func_Decls, 2000 Handled_Statement_Sequence => 2001 Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts)); 2002 2003 -- Insert the newly generated function in the code. This is analyzed 2004 -- with all checks off, since we have completed all the checks. 2005 2006 -- Note that this does *not* fix the array concatenation bug when the 2007 -- low bound is Integer'first sibce that bug comes from the pointer 2008 -- dereferencing an unconstrained array. An there we need a constraint 2009 -- check to make sure the length of the concatenated array is ok. ??? 2010 2011 Insert_Action (Cnode, Func_Body, Suppress => All_Checks); 2012 2013 -- Construct list of arguments for the function call 2014 2015 Params := New_List; 2016 Operand := First (Opnds); 2017 for I in 1 .. Nb_Opnds loop 2018 Append_To (Params, Relocate_Node (Operand)); 2019 Next (Operand); 2020 end loop; 2021 2022 -- Insert the function call 2023 2024 Rewrite 2025 (Cnode, 2026 Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params)); 2027 2028 Analyze_And_Resolve (Cnode, Base_Typ); 2029 Set_Is_Inlined (Func_Id); 2030 end Expand_Concatenate_Other; 2031 2032 ------------------------------- 2033 -- Expand_Concatenate_String -- 2034 ------------------------------- 2035 2036 procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is 2037 Loc : constant Source_Ptr := Sloc (Cnode); 2038 Opnd1 : constant Node_Id := First (Opnds); 2039 Opnd2 : constant Node_Id := Next (Opnd1); 2040 Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1)); 2041 Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2)); 2042 2043 R : RE_Id; 2044 -- RE_Id value for function to be called 2045 2046 begin 2047 -- In all cases, we build a call to a routine giving the list of 2048 -- arguments as the parameter list to the routine. 2049 2050 case List_Length (Opnds) is 2051 when 2 => 2052 if Typ1 = Standard_Character then 2053 if Typ2 = Standard_Character then 2054 R := RE_Str_Concat_CC; 2055 2056 else 2057 pragma Assert (Typ2 = Standard_String); 2058 R := RE_Str_Concat_CS; 2059 end if; 2060 2061 elsif Typ1 = Standard_String then 2062 if Typ2 = Standard_Character then 2063 R := RE_Str_Concat_SC; 2064 2065 else 2066 pragma Assert (Typ2 = Standard_String); 2067 R := RE_Str_Concat; 2068 end if; 2069 2070 -- If we have anything other than Standard_Character or 2071 -- Standard_String, then we must have had a serious error 2072 -- earlier, so we just abandon the attempt at expansion. 2073 2074 else 2075 pragma Assert (Serious_Errors_Detected > 0); 2076 return; 2077 end if; 2078 2079 when 3 => 2080 R := RE_Str_Concat_3; 2081 2082 when 4 => 2083 R := RE_Str_Concat_4; 2084 2085 when 5 => 2086 R := RE_Str_Concat_5; 2087 2088 when others => 2089 R := RE_Null; 2090 raise Program_Error; 2091 end case; 2092 2093 -- Now generate the appropriate call 2094 2095 Rewrite (Cnode, 2096 Make_Function_Call (Sloc (Cnode), 2097 Name => New_Occurrence_Of (RTE (R), Loc), 2098 Parameter_Associations => Opnds)); 2099 2100 Analyze_And_Resolve (Cnode, Standard_String); 2101 2102 exception 2103 when RE_Not_Available => 2104 return; 2105 end Expand_Concatenate_String; 2106 2107 ------------------------ 2108 -- Expand_N_Allocator -- 2109 ------------------------ 2110 2111 procedure Expand_N_Allocator (N : Node_Id) is 2112 PtrT : constant Entity_Id := Etype (N); 2113 Desig : Entity_Id; 2114 Loc : constant Source_Ptr := Sloc (N); 2115 Temp : Entity_Id; 2116 Node : Node_Id; 2117 2118 begin 2119 -- RM E.2.3(22). We enforce that the expected type of an allocator 2120 -- shall not be a remote access-to-class-wide-limited-private type 2121 2122 -- Why is this being done at expansion time, seems clearly wrong ??? 2123 2124 Validate_Remote_Access_To_Class_Wide_Type (N); 2125 2126 -- Set the Storage Pool 2127 2128 Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT))); 2129 2130 if Present (Storage_Pool (N)) then 2131 if Is_RTE (Storage_Pool (N), RE_SS_Pool) then 2132 if not Java_VM then 2133 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); 2134 end if; 2135 2136 elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then 2137 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); 2138 2139 else 2140 Set_Procedure_To_Call (N, 2141 Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate)); 2142 end if; 2143 end if; 2144 2145 -- Under certain circumstances we can replace an allocator by an 2146 -- access to statically allocated storage. The conditions, as noted 2147 -- in AARM 3.10 (10c) are as follows: 2148 2149 -- Size and initial value is known at compile time 2150 -- Access type is access-to-constant 2151 2152 -- The allocator is not part of a constraint on a record component, 2153 -- because in that case the inserted actions are delayed until the 2154 -- record declaration is fully analyzed, which is too late for the 2155 -- analysis of the rewritten allocator. 2156 2157 if Is_Access_Constant (PtrT) 2158 and then Nkind (Expression (N)) = N_Qualified_Expression 2159 and then Compile_Time_Known_Value (Expression (Expression (N))) 2160 and then Size_Known_At_Compile_Time (Etype (Expression 2161 (Expression (N)))) 2162 and then not Is_Record_Type (Current_Scope) 2163 then 2164 -- Here we can do the optimization. For the allocator 2165 2166 -- new x'(y) 2167 2168 -- We insert an object declaration 2169 2170 -- Tnn : aliased x := y; 2171 2172 -- and replace the allocator by Tnn'Unrestricted_Access. 2173 -- Tnn is marked as requiring static allocation. 2174 2175 Temp := 2176 Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 2177 2178 Desig := Subtype_Mark (Expression (N)); 2179 2180 -- If context is constrained, use constrained subtype directly, 2181 -- so that the constant is not labelled as having a nomimally 2182 -- unconstrained subtype. 2183 2184 if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then 2185 Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc); 2186 end if; 2187 2188 Insert_Action (N, 2189 Make_Object_Declaration (Loc, 2190 Defining_Identifier => Temp, 2191 Aliased_Present => True, 2192 Constant_Present => Is_Access_Constant (PtrT), 2193 Object_Definition => Desig, 2194 Expression => Expression (Expression (N)))); 2195 2196 Rewrite (N, 2197 Make_Attribute_Reference (Loc, 2198 Prefix => New_Occurrence_Of (Temp, Loc), 2199 Attribute_Name => Name_Unrestricted_Access)); 2200 2201 Analyze_And_Resolve (N, PtrT); 2202 2203 -- We set the variable as statically allocated, since we don't 2204 -- want it going on the stack of the current procedure! 2205 2206 Set_Is_Statically_Allocated (Temp); 2207 return; 2208 end if; 2209 2210 if Nkind (Expression (N)) = N_Qualified_Expression then 2211 Expand_Allocator_Expression (N); 2212 2213 -- If the allocator is for a type which requires initialization, and 2214 -- there is no initial value (i.e. operand is a subtype indication 2215 -- rather than a qualifed expression), then we must generate a call 2216 -- to the initialization routine. This is done using an expression 2217 -- actions node: 2218 -- 2219 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] 2220 -- 2221 -- Here ptr_T is the pointer type for the allocator, and T is the 2222 -- subtype of the allocator. A special case arises if the designated 2223 -- type of the access type is a task or contains tasks. In this case 2224 -- the call to Init (Temp.all ...) is replaced by code that ensures 2225 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block 2226 -- for details). In addition, if the type T is a task T, then the 2227 -- first argument to Init must be converted to the task record type. 2228 2229 else 2230 declare 2231 T : constant Entity_Id := Entity (Expression (N)); 2232 Init : Entity_Id; 2233 Arg1 : Node_Id; 2234 Args : List_Id; 2235 Decls : List_Id; 2236 Decl : Node_Id; 2237 Discr : Elmt_Id; 2238 Flist : Node_Id; 2239 Temp_Decl : Node_Id; 2240 Temp_Type : Entity_Id; 2241 2242 begin 2243 2244 if No_Initialization (N) then 2245 null; 2246 2247 -- Case of no initialization procedure present 2248 2249 elsif not Has_Non_Null_Base_Init_Proc (T) then 2250 2251 -- Case of simple initialization required 2252 2253 if Needs_Simple_Initialization (T) then 2254 Rewrite (Expression (N), 2255 Make_Qualified_Expression (Loc, 2256 Subtype_Mark => New_Occurrence_Of (T, Loc), 2257 Expression => Get_Simple_Init_Val (T, Loc))); 2258 2259 Analyze_And_Resolve (Expression (Expression (N)), T); 2260 Analyze_And_Resolve (Expression (N), T); 2261 Set_Paren_Count (Expression (Expression (N)), 1); 2262 Expand_N_Allocator (N); 2263 2264 -- No initialization required 2265 2266 else 2267 null; 2268 end if; 2269 2270 -- Case of initialization procedure present, must be called 2271 2272 else 2273 Init := Base_Init_Proc (T); 2274 Node := N; 2275 Temp := 2276 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 2277 2278 -- Construct argument list for the initialization routine call 2279 -- The CPP constructor needs the address directly 2280 2281 if Is_CPP_Class (T) then 2282 Arg1 := New_Reference_To (Temp, Loc); 2283 Temp_Type := T; 2284 2285 else 2286 Arg1 := 2287 Make_Explicit_Dereference (Loc, 2288 Prefix => New_Reference_To (Temp, Loc)); 2289 Set_Assignment_OK (Arg1); 2290 Temp_Type := PtrT; 2291 2292 -- The initialization procedure expects a specific type. 2293 -- if the context is access to class wide, indicate that 2294 -- the object being allocated has the right specific type. 2295 2296 if Is_Class_Wide_Type (Designated_Type (PtrT)) then 2297 Arg1 := Unchecked_Convert_To (T, Arg1); 2298 end if; 2299 end if; 2300 2301 -- If designated type is a concurrent type or if it is a 2302 -- private type whose definition is a concurrent type, 2303 -- the first argument in the Init routine has to be 2304 -- unchecked conversion to the corresponding record type. 2305 -- If the designated type is a derived type, we also 2306 -- convert the argument to its root type. 2307 2308 if Is_Concurrent_Type (T) then 2309 Arg1 := 2310 Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); 2311 2312 elsif Is_Private_Type (T) 2313 and then Present (Full_View (T)) 2314 and then Is_Concurrent_Type (Full_View (T)) 2315 then 2316 Arg1 := 2317 Unchecked_Convert_To 2318 (Corresponding_Record_Type (Full_View (T)), Arg1); 2319 2320 elsif Etype (First_Formal (Init)) /= Base_Type (T) then 2321 2322 declare 2323 Ftyp : constant Entity_Id := Etype (First_Formal (Init)); 2324 2325 begin 2326 Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); 2327 Set_Etype (Arg1, Ftyp); 2328 end; 2329 end if; 2330 2331 Args := New_List (Arg1); 2332 2333 -- For the task case, pass the Master_Id of the access type 2334 -- as the value of the _Master parameter, and _Chain as the 2335 -- value of the _Chain parameter (_Chain will be defined as 2336 -- part of the generated code for the allocator). 2337 2338 if Has_Task (T) then 2339 2340 if No (Master_Id (Base_Type (PtrT))) then 2341 2342 -- The designated type was an incomplete type, and 2343 -- the access type did not get expanded. Salvage 2344 -- it now. 2345 2346 Expand_N_Full_Type_Declaration 2347 (Parent (Base_Type (PtrT))); 2348 end if; 2349 2350 -- If the context of the allocator is a declaration or 2351 -- an assignment, we can generate a meaningful image for 2352 -- it, even though subsequent assignments might remove 2353 -- the connection between task and entity. We build this 2354 -- image when the left-hand side is a simple variable, 2355 -- a simple indexed assignment or a simple selected 2356 -- component. 2357 2358 if Nkind (Parent (N)) = N_Assignment_Statement then 2359 declare 2360 Nam : constant Node_Id := Name (Parent (N)); 2361 2362 begin 2363 if Is_Entity_Name (Nam) then 2364 Decls := 2365 Build_Task_Image_Decls ( 2366 Loc, 2367 New_Occurrence_Of 2368 (Entity (Nam), Sloc (Nam)), T); 2369 2370 elsif (Nkind (Nam) = N_Indexed_Component 2371 or else Nkind (Nam) = N_Selected_Component) 2372 and then Is_Entity_Name (Prefix (Nam)) 2373 then 2374 Decls := 2375 Build_Task_Image_Decls 2376 (Loc, Nam, Etype (Prefix (Nam))); 2377 else 2378 Decls := Build_Task_Image_Decls (Loc, T, T); 2379 end if; 2380 end; 2381 2382 elsif Nkind (Parent (N)) = N_Object_Declaration then 2383 Decls := 2384 Build_Task_Image_Decls ( 2385 Loc, Defining_Identifier (Parent (N)), T); 2386 2387 else 2388 Decls := Build_Task_Image_Decls (Loc, T, T); 2389 end if; 2390 2391 Append_To (Args, 2392 New_Reference_To 2393 (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); 2394 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 2395 2396 Decl := Last (Decls); 2397 Append_To (Args, 2398 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 2399 2400 -- Has_Task is false, Decls not used 2401 2402 else 2403 Decls := No_List; 2404 end if; 2405 2406 -- Add discriminants if discriminated type 2407 2408 if Has_Discriminants (T) then 2409 Discr := First_Elmt (Discriminant_Constraint (T)); 2410 2411 while Present (Discr) loop 2412 Append (New_Copy_Tree (Elists.Node (Discr)), Args); 2413 Next_Elmt (Discr); 2414 end loop; 2415 2416 elsif Is_Private_Type (T) 2417 and then Present (Full_View (T)) 2418 and then Has_Discriminants (Full_View (T)) 2419 then 2420 Discr := 2421 First_Elmt (Discriminant_Constraint (Full_View (T))); 2422 2423 while Present (Discr) loop 2424 Append (New_Copy_Tree (Elists.Node (Discr)), Args); 2425 Next_Elmt (Discr); 2426 end loop; 2427 end if; 2428 2429 -- We set the allocator as analyzed so that when we analyze the 2430 -- expression actions node, we do not get an unwanted recursive 2431 -- expansion of the allocator expression. 2432 2433 Set_Analyzed (N, True); 2434 Node := Relocate_Node (N); 2435 2436 -- Here is the transformation: 2437 -- input: new T 2438 -- output: Temp : constant ptr_T := new T; 2439 -- Init (Temp.all, ...); 2440 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all)); 2441 -- <CTRL> Initialize (Finalizable (Temp.all)); 2442 2443 -- Here ptr_T is the pointer type for the allocator, and T 2444 -- is the subtype of the allocator. 2445 2446 Temp_Decl := 2447 Make_Object_Declaration (Loc, 2448 Defining_Identifier => Temp, 2449 Constant_Present => True, 2450 Object_Definition => New_Reference_To (Temp_Type, Loc), 2451 Expression => Node); 2452 2453 Set_Assignment_OK (Temp_Decl); 2454 2455 if Is_CPP_Class (T) then 2456 Set_Aliased_Present (Temp_Decl); 2457 end if; 2458 2459 Insert_Action (N, Temp_Decl, Suppress => All_Checks); 2460 2461 -- If the designated type is task type or contains tasks, 2462 -- Create block to activate created tasks, and insert 2463 -- declaration for Task_Image variable ahead of call. 2464 2465 if Has_Task (T) then 2466 declare 2467 L : constant List_Id := New_List; 2468 Blk : Node_Id; 2469 2470 begin 2471 Build_Task_Allocate_Block (L, Node, Args); 2472 Blk := Last (L); 2473 2474 Insert_List_Before (First (Declarations (Blk)), Decls); 2475 Insert_Actions (N, L); 2476 end; 2477 2478 else 2479 Insert_Action (N, 2480 Make_Procedure_Call_Statement (Loc, 2481 Name => New_Reference_To (Init, Loc), 2482 Parameter_Associations => Args)); 2483 end if; 2484 2485 if Controlled_Type (T) then 2486 Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); 2487 2488 Insert_Actions (N, 2489 Make_Init_Call ( 2490 Ref => New_Copy_Tree (Arg1), 2491 Typ => T, 2492 Flist_Ref => Flist, 2493 With_Attach => Make_Integer_Literal (Loc, 2))); 2494 end if; 2495 2496 if Is_CPP_Class (T) then 2497 Rewrite (N, 2498 Make_Attribute_Reference (Loc, 2499 Prefix => New_Reference_To (Temp, Loc), 2500 Attribute_Name => Name_Unchecked_Access)); 2501 else 2502 Rewrite (N, New_Reference_To (Temp, Loc)); 2503 end if; 2504 2505 Analyze_And_Resolve (N, PtrT); 2506 end if; 2507 end; 2508 end if; 2509 2510 exception 2511 when RE_Not_Available => 2512 return; 2513 end Expand_N_Allocator; 2514 2515 ----------------------- 2516 -- Expand_N_And_Then -- 2517 ----------------------- 2518 2519 -- Expand into conditional expression if Actions present, and also 2520 -- deal with optimizing case of arguments being True or False. 2521 2522 procedure Expand_N_And_Then (N : Node_Id) is 2523 Loc : constant Source_Ptr := Sloc (N); 2524 Typ : constant Entity_Id := Etype (N); 2525 Left : constant Node_Id := Left_Opnd (N); 2526 Right : constant Node_Id := Right_Opnd (N); 2527 Actlist : List_Id; 2528 2529 begin 2530 -- Deal with non-standard booleans 2531 2532 if Is_Boolean_Type (Typ) then 2533 Adjust_Condition (Left); 2534 Adjust_Condition (Right); 2535 Set_Etype (N, Standard_Boolean); 2536 end if; 2537 2538 -- Check for cases of left argument is True or False 2539 2540 if Nkind (Left) = N_Identifier then 2541 2542 -- If left argument is True, change (True and then Right) to Right. 2543 -- Any actions associated with Right will be executed unconditionally 2544 -- and can thus be inserted into the tree unconditionally. 2545 2546 if Entity (Left) = Standard_True then 2547 if Present (Actions (N)) then 2548 Insert_Actions (N, Actions (N)); 2549 end if; 2550 2551 Rewrite (N, Right); 2552 Adjust_Result_Type (N, Typ); 2553 return; 2554 2555 -- If left argument is False, change (False and then Right) to 2556 -- False. In this case we can forget the actions associated with 2557 -- Right, since they will never be executed. 2558 2559 elsif Entity (Left) = Standard_False then 2560 Kill_Dead_Code (Right); 2561 Kill_Dead_Code (Actions (N)); 2562 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 2563 Adjust_Result_Type (N, Typ); 2564 return; 2565 end if; 2566 end if; 2567 2568 -- If Actions are present, we expand 2569 2570 -- left and then right 2571 2572 -- into 2573 2574 -- if left then right else false end 2575 2576 -- with the actions becoming the Then_Actions of the conditional 2577 -- expression. This conditional expression is then further expanded 2578 -- (and will eventually disappear) 2579 2580 if Present (Actions (N)) then 2581 Actlist := Actions (N); 2582 Rewrite (N, 2583 Make_Conditional_Expression (Loc, 2584 Expressions => New_List ( 2585 Left, 2586 Right, 2587 New_Occurrence_Of (Standard_False, Loc)))); 2588 2589 Set_Then_Actions (N, Actlist); 2590 Analyze_And_Resolve (N, Standard_Boolean); 2591 Adjust_Result_Type (N, Typ); 2592 return; 2593 end if; 2594 2595 -- No actions present, check for cases of right argument True/False 2596 2597 if Nkind (Right) = N_Identifier then 2598 2599 -- Change (Left and then True) to Left. Note that we know there 2600 -- are no actions associated with the True operand, since we 2601 -- just checked for this case above. 2602 2603 if Entity (Right) = Standard_True then 2604 Rewrite (N, Left); 2605 2606 -- Change (Left and then False) to False, making sure to preserve 2607 -- any side effects associated with the Left operand. 2608 2609 elsif Entity (Right) = Standard_False then 2610 Remove_Side_Effects (Left); 2611 Rewrite 2612 (N, New_Occurrence_Of (Standard_False, Loc)); 2613 end if; 2614 end if; 2615 2616 Adjust_Result_Type (N, Typ); 2617 end Expand_N_And_Then; 2618 2619 ------------------------------------- 2620 -- Expand_N_Conditional_Expression -- 2621 ------------------------------------- 2622 2623 -- Expand into expression actions if then/else actions present 2624 2625 procedure Expand_N_Conditional_Expression (N : Node_Id) is 2626 Loc : constant Source_Ptr := Sloc (N); 2627 Cond : constant Node_Id := First (Expressions (N)); 2628 Thenx : constant Node_Id := Next (Cond); 2629 Elsex : constant Node_Id := Next (Thenx); 2630 Typ : constant Entity_Id := Etype (N); 2631 Cnn : Entity_Id; 2632 New_If : Node_Id; 2633 2634 begin 2635 -- If either then or else actions are present, then given: 2636 2637 -- if cond then then-expr else else-expr end 2638 2639 -- we insert the following sequence of actions (using Insert_Actions): 2640 2641 -- Cnn : typ; 2642 -- if cond then 2643 -- <<then actions>> 2644 -- Cnn := then-expr; 2645 -- else 2646 -- <<else actions>> 2647 -- Cnn := else-expr 2648 -- end if; 2649 2650 -- and replace the conditional expression by a reference to Cnn. 2651 2652 if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then 2653 Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); 2654 2655 New_If := 2656 Make_Implicit_If_Statement (N, 2657 Condition => Relocate_Node (Cond), 2658 2659 Then_Statements => New_List ( 2660 Make_Assignment_Statement (Sloc (Thenx), 2661 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 2662 Expression => Relocate_Node (Thenx))), 2663 2664 Else_Statements => New_List ( 2665 Make_Assignment_Statement (Sloc (Elsex), 2666 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 2667 Expression => Relocate_Node (Elsex)))); 2668 2669 Set_Assignment_OK (Name (First (Then_Statements (New_If)))); 2670 Set_Assignment_OK (Name (First (Else_Statements (New_If)))); 2671 2672 if Present (Then_Actions (N)) then 2673 Insert_List_Before 2674 (First (Then_Statements (New_If)), Then_Actions (N)); 2675 end if; 2676 2677 if Present (Else_Actions (N)) then 2678 Insert_List_Before 2679 (First (Else_Statements (New_If)), Else_Actions (N)); 2680 end if; 2681 2682 Rewrite (N, New_Occurrence_Of (Cnn, Loc)); 2683 2684 Insert_Action (N, 2685 Make_Object_Declaration (Loc, 2686 Defining_Identifier => Cnn, 2687 Object_Definition => New_Occurrence_Of (Typ, Loc))); 2688 2689 Insert_Action (N, New_If); 2690 Analyze_And_Resolve (N, Typ); 2691 end if; 2692 end Expand_N_Conditional_Expression; 2693 2694 ----------------------------------- 2695 -- Expand_N_Explicit_Dereference -- 2696 ----------------------------------- 2697 2698 procedure Expand_N_Explicit_Dereference (N : Node_Id) is 2699 begin 2700 -- The only processing required is an insertion of an explicit 2701 -- dereference call for the checked storage pool case. 2702 2703 Insert_Dereference_Action (Prefix (N)); 2704 end Expand_N_Explicit_Dereference; 2705 2706 ----------------- 2707 -- Expand_N_In -- 2708 ----------------- 2709 2710 procedure Expand_N_In (N : Node_Id) is 2711 Loc : constant Source_Ptr := Sloc (N); 2712 Rtyp : constant Entity_Id := Etype (N); 2713 Lop : constant Node_Id := Left_Opnd (N); 2714 Rop : constant Node_Id := Right_Opnd (N); 2715 2716 begin 2717 -- If we have an explicit range, do a bit of optimization based 2718 -- on range analysis (we may be able to kill one or both checks). 2719 2720 if Nkind (Rop) = N_Range then 2721 declare 2722 Lcheck : constant Compare_Result := 2723 Compile_Time_Compare (Lop, Low_Bound (Rop)); 2724 Ucheck : constant Compare_Result := 2725 Compile_Time_Compare (Lop, High_Bound (Rop)); 2726 2727 begin 2728 -- If either check is known to fail, replace result 2729 -- by False, since the other check does not matter. 2730 2731 if Lcheck = LT or else Ucheck = GT then 2732 Rewrite (N, 2733 New_Reference_To (Standard_False, Loc)); 2734 Analyze_And_Resolve (N, Rtyp); 2735 return; 2736 2737 -- If both checks are known to succeed, replace result 2738 -- by True, since we know we are in range. 2739 2740 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 2741 Rewrite (N, 2742 New_Reference_To (Standard_True, Loc)); 2743 Analyze_And_Resolve (N, Rtyp); 2744 return; 2745 2746 -- If lower bound check succeeds and upper bound check is 2747 -- not known to succeed or fail, then replace the range check 2748 -- with a comparison against the upper bound. 2749 2750 elsif Lcheck in Compare_GE then 2751 Rewrite (N, 2752 Make_Op_Le (Loc, 2753 Left_Opnd => Lop, 2754 Right_Opnd => High_Bound (Rop))); 2755 Analyze_And_Resolve (N, Rtyp); 2756 return; 2757 2758 -- If upper bound check succeeds and lower bound check is 2759 -- not known to succeed or fail, then replace the range check 2760 -- with a comparison against the lower bound. 2761 2762 elsif Ucheck in Compare_LE then 2763 Rewrite (N, 2764 Make_Op_Ge (Loc, 2765 Left_Opnd => Lop, 2766 Right_Opnd => Low_Bound (Rop))); 2767 Analyze_And_Resolve (N, Rtyp); 2768 return; 2769 end if; 2770 end; 2771 2772 -- For all other cases of an explicit range, nothing to be done 2773 2774 return; 2775 2776 -- Here right operand is a subtype mark 2777 2778 else 2779 declare 2780 Typ : Entity_Id := Etype (Rop); 2781 Is_Acc : constant Boolean := Is_Access_Type (Typ); 2782 Obj : Node_Id := Lop; 2783 Cond : Node_Id := Empty; 2784 2785 begin 2786 Remove_Side_Effects (Obj); 2787 2788 -- For tagged type, do tagged membership operation 2789 2790 if Is_Tagged_Type (Typ) then 2791 2792 -- No expansion will be performed when Java_VM, as the 2793 -- JVM back end will handle the membership tests directly 2794 -- (tags are not explicitly represented in Java objects, 2795 -- so the normal tagged membership expansion is not what 2796 -- we want). 2797 2798 if not Java_VM then 2799 Rewrite (N, Tagged_Membership (N)); 2800 Analyze_And_Resolve (N, Rtyp); 2801 end if; 2802 2803 return; 2804 2805 -- If type is scalar type, rewrite as x in t'first .. t'last 2806 -- This reason we do this is that the bounds may have the wrong 2807 -- type if they come from the original type definition. 2808 2809 elsif Is_Scalar_Type (Typ) then 2810 Rewrite (Rop, 2811 Make_Range (Loc, 2812 Low_Bound => 2813 Make_Attribute_Reference (Loc, 2814 Attribute_Name => Name_First, 2815 Prefix => New_Reference_To (Typ, Loc)), 2816 2817 High_Bound => 2818 Make_Attribute_Reference (Loc, 2819 Attribute_Name => Name_Last, 2820 Prefix => New_Reference_To (Typ, Loc)))); 2821 Analyze_And_Resolve (N, Rtyp); 2822 return; 2823 end if; 2824 2825 -- Here we have a non-scalar type 2826 2827 if Is_Acc then 2828 Typ := Designated_Type (Typ); 2829 end if; 2830 2831 if not Is_Constrained (Typ) then 2832 Rewrite (N, 2833 New_Reference_To (Standard_True, Loc)); 2834 Analyze_And_Resolve (N, Rtyp); 2835 2836 -- For the constrained array case, we have to check the 2837 -- subscripts for an exact match if the lengths are 2838 -- non-zero (the lengths must match in any case). 2839 2840 elsif Is_Array_Type (Typ) then 2841 2842 Check_Subscripts : declare 2843 function Construct_Attribute_Reference 2844 (E : Node_Id; 2845 Nam : Name_Id; 2846 Dim : Nat) 2847 return Node_Id; 2848 -- Build attribute reference E'Nam(Dim) 2849 2850 ----------------------------------- 2851 -- Construct_Attribute_Reference -- 2852 ----------------------------------- 2853 2854 function Construct_Attribute_Reference 2855 (E : Node_Id; 2856 Nam : Name_Id; 2857 Dim : Nat) 2858 return Node_Id 2859 is 2860 begin 2861 return 2862 Make_Attribute_Reference (Loc, 2863 Prefix => E, 2864 Attribute_Name => Nam, 2865 Expressions => New_List ( 2866 Make_Integer_Literal (Loc, Dim))); 2867 end Construct_Attribute_Reference; 2868 2869 -- Start processing for Check_Subscripts 2870 2871 begin 2872 for J in 1 .. Number_Dimensions (Typ) loop 2873 Evolve_And_Then (Cond, 2874 Make_Op_Eq (Loc, 2875 Left_Opnd => 2876 Construct_Attribute_Reference 2877 (Duplicate_Subexpr_No_Checks (Obj), 2878 Name_First, J), 2879 Right_Opnd => 2880 Construct_Attribute_Reference 2881 (New_Occurrence_Of (Typ, Loc), Name_First, J))); 2882 2883 Evolve_And_Then (Cond, 2884 Make_Op_Eq (Loc, 2885 Left_Opnd => 2886 Construct_Attribute_Reference 2887 (Duplicate_Subexpr_No_Checks (Obj), 2888 Name_Last, J), 2889 Right_Opnd => 2890 Construct_Attribute_Reference 2891 (New_Occurrence_Of (Typ, Loc), Name_Last, J))); 2892 end loop; 2893 2894 if Is_Acc then 2895 Cond := 2896 Make_Or_Else (Loc, 2897 Left_Opnd => 2898 Make_Op_Eq (Loc, 2899 Left_Opnd => Obj, 2900 Right_Opnd => Make_Null (Loc)), 2901 Right_Opnd => Cond); 2902 end if; 2903 2904 Rewrite (N, Cond); 2905 Analyze_And_Resolve (N, Rtyp); 2906 end Check_Subscripts; 2907 2908 -- These are the cases where constraint checks may be 2909 -- required, e.g. records with possible discriminants 2910 2911 else 2912 -- Expand the test into a series of discriminant comparisons. 2913 -- The expression that is built is the negation of the one 2914 -- that is used for checking discriminant constraints. 2915 2916 Obj := Relocate_Node (Left_Opnd (N)); 2917 2918 if Has_Discriminants (Typ) then 2919 Cond := Make_Op_Not (Loc, 2920 Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); 2921 2922 if Is_Acc then 2923 Cond := Make_Or_Else (Loc, 2924 Left_Opnd => 2925 Make_Op_Eq (Loc, 2926 Left_Opnd => Obj, 2927 Right_Opnd => Make_Null (Loc)), 2928 Right_Opnd => Cond); 2929 end if; 2930 2931 else 2932 Cond := New_Occurrence_Of (Standard_True, Loc); 2933 end if; 2934 2935 Rewrite (N, Cond); 2936 Analyze_And_Resolve (N, Rtyp); 2937 end if; 2938 end; 2939 end if; 2940 end Expand_N_In; 2941 2942 -------------------------------- 2943 -- Expand_N_Indexed_Component -- 2944 -------------------------------- 2945 2946 procedure Expand_N_Indexed_Component (N : Node_Id) is 2947 Loc : constant Source_Ptr := Sloc (N); 2948 Typ : constant Entity_Id := Etype (N); 2949 P : constant Node_Id := Prefix (N); 2950 T : constant Entity_Id := Etype (P); 2951 2952 begin 2953 -- A special optimization, if we have an indexed component that 2954 -- is selecting from a slice, then we can eliminate the slice, 2955 -- since, for example, x (i .. j)(k) is identical to x(k). The 2956 -- only difference is the range check required by the slice. The 2957 -- range check for the slice itself has already been generated. 2958 -- The range check for the subscripting operation is ensured 2959 -- by converting the subject to the subtype of the slice. 2960 2961 -- This optimization not only generates better code, avoiding 2962 -- slice messing especially in the packed case, but more importantly 2963 -- bypasses some problems in handling this peculiar case, for 2964 -- example, the issue of dealing specially with object renamings. 2965 2966 if Nkind (P) = N_Slice then 2967 Rewrite (N, 2968 Make_Indexed_Component (Loc, 2969 Prefix => Prefix (P), 2970 Expressions => New_List ( 2971 Convert_To 2972 (Etype (First_Index (Etype (P))), 2973 First (Expressions (N)))))); 2974 Analyze_And_Resolve (N, Typ); 2975 return; 2976 end if; 2977 2978 -- If the prefix is an access type, then we unconditionally rewrite 2979 -- if as an explicit deference. This simplifies processing for several 2980 -- cases, including packed array cases and certain cases in which 2981 -- checks must be generated. We used to try to do this only when it 2982 -- was necessary, but it cleans up the code to do it all the time. 2983 2984 if Is_Access_Type (T) then 2985 2986 -- Check whether the prefix comes from a debug pool, and generate 2987 -- the check before rewriting. 2988 2989 Insert_Dereference_Action (P); 2990 2991 Rewrite (P, 2992 Make_Explicit_Dereference (Sloc (N), 2993 Prefix => Relocate_Node (P))); 2994 Analyze_And_Resolve (P, Designated_Type (T)); 2995 end if; 2996 2997 -- Generate index and validity checks 2998 2999 Generate_Index_Checks (N); 3000 3001 if Validity_Checks_On and then Validity_Check_Subscripts then 3002 Apply_Subscript_Validity_Checks (N); 3003 end if; 3004 3005 -- All done for the non-packed case 3006 3007 if not Is_Packed (Etype (Prefix (N))) then 3008 return; 3009 end if; 3010 3011 -- For packed arrays that are not bit-packed (i.e. the case of an array 3012 -- with one or more index types with a non-coniguous enumeration type), 3013 -- we can always use the normal packed element get circuit. 3014 3015 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then 3016 Expand_Packed_Element_Reference (N); 3017 return; 3018 end if; 3019 3020 -- For a reference to a component of a bit packed array, we have to 3021 -- convert it to a reference to the corresponding Packed_Array_Type. 3022 -- We only want to do this for simple references, and not for: 3023 3024 -- Left side of assignment, or prefix of left side of assignment, 3025 -- or prefix of the prefix, to handle packed arrays of packed arrays, 3026 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement 3027 3028 -- Renaming objects in renaming associations 3029 -- This case is handled when a use of the renamed variable occurs 3030 3031 -- Actual parameters for a procedure call 3032 -- This case is handled in Exp_Ch6.Expand_Actuals 3033 3034 -- The second expression in a 'Read attribute reference 3035 3036 -- The prefix of an address or size attribute reference 3037 3038 -- The following circuit detects these exceptions 3039 3040 declare 3041 Child : Node_Id := N; 3042 Parnt : Node_Id := Parent (N); 3043 3044 begin 3045 loop 3046 if Nkind (Parnt) = N_Unchecked_Expression then 3047 null; 3048 3049 elsif Nkind (Parnt) = N_Object_Renaming_Declaration 3050 or else Nkind (Parnt) = N_Procedure_Call_Statement 3051 or else (Nkind (Parnt) = N_Parameter_Association 3052 and then 3053 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) 3054 then 3055 return; 3056 3057 elsif Nkind (Parnt) = N_Attribute_Reference 3058 and then (Attribute_Name (Parnt) = Name_Address 3059 or else 3060 Attribute_Name (Parnt) = Name_Size) 3061 and then Prefix (Parnt) = Child 3062 then 3063 return; 3064 3065 elsif Nkind (Parnt) = N_Assignment_Statement 3066 and then Name (Parnt) = Child 3067 then 3068 return; 3069 3070 -- If the expression is an index of an indexed component, 3071 -- it must be expanded regardless of context. 3072 3073 elsif Nkind (Parnt) = N_Indexed_Component 3074 and then Child /= Prefix (Parnt) 3075 then 3076 Expand_Packed_Element_Reference (N); 3077 return; 3078 3079 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement 3080 and then Name (Parent (Parnt)) = Parnt 3081 then 3082 return; 3083 3084 elsif Nkind (Parnt) = N_Attribute_Reference 3085 and then Attribute_Name (Parnt) = Name_Read 3086 and then Next (First (Expressions (Parnt))) = Child 3087 then 3088 return; 3089 3090 elsif (Nkind (Parnt) = N_Indexed_Component 3091 or else Nkind (Parnt) = N_Selected_Component) 3092 and then Prefix (Parnt) = Child 3093 then 3094 null; 3095 3096 else 3097 Expand_Packed_Element_Reference (N); 3098 return; 3099 end if; 3100 3101 -- Keep looking up tree for unchecked expression, or if we are 3102 -- the prefix of a possible assignment left side. 3103 3104 Child := Parnt; 3105 Parnt := Parent (Child); 3106 end loop; 3107 end; 3108 3109 end Expand_N_Indexed_Component; 3110 3111 --------------------- 3112 -- Expand_N_Not_In -- 3113 --------------------- 3114 3115 -- Replace a not in b by not (a in b) so that the expansions for (a in b) 3116 -- can be done. This avoids needing to duplicate this expansion code. 3117 3118 procedure Expand_N_Not_In (N : Node_Id) is 3119 Loc : constant Source_Ptr := Sloc (N); 3120 Typ : constant Entity_Id := Etype (N); 3121 3122 begin 3123 Rewrite (N, 3124 Make_Op_Not (Loc, 3125 Right_Opnd => 3126 Make_In (Loc, 3127 Left_Opnd => Left_Opnd (N), 3128 Right_Opnd => Right_Opnd (N)))); 3129 Analyze_And_Resolve (N, Typ); 3130 end Expand_N_Not_In; 3131 3132 ------------------- 3133 -- Expand_N_Null -- 3134 ------------------- 3135 3136 -- The only replacement required is for the case of a null of type 3137 -- that is an access to protected subprogram. We represent such 3138 -- access values as a record, and so we must replace the occurrence 3139 -- of null by the equivalent record (with a null address and a null 3140 -- pointer in it), so that the backend creates the proper value. 3141 3142 procedure Expand_N_Null (N : Node_Id) is 3143 Loc : constant Source_Ptr := Sloc (N); 3144 Typ : constant Entity_Id := Etype (N); 3145 Agg : Node_Id; 3146 3147 begin 3148 if Ekind (Typ) = E_Access_Protected_Subprogram_Type then 3149 Agg := 3150 Make_Aggregate (Loc, 3151 Expressions => New_List ( 3152 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 3153 Make_Null (Loc))); 3154 3155 Rewrite (N, Agg); 3156 Analyze_And_Resolve (N, Equivalent_Type (Typ)); 3157 3158 -- For subsequent semantic analysis, the node must retain its 3159 -- type. Gigi in any case replaces this type by the corresponding 3160 -- record type before processing the node. 3161 3162 Set_Etype (N, Typ); 3163 end if; 3164 3165 exception 3166 when RE_Not_Available => 3167 return; 3168 end Expand_N_Null; 3169 3170 --------------------- 3171 -- Expand_N_Op_Abs -- 3172 --------------------- 3173 3174 procedure Expand_N_Op_Abs (N : Node_Id) is 3175 Loc : constant Source_Ptr := Sloc (N); 3176 Expr : constant Node_Id := Right_Opnd (N); 3177 3178 begin 3179 Unary_Op_Validity_Checks (N); 3180 3181 -- Deal with software overflow checking 3182 3183 if not Backend_Overflow_Checks_On_Target 3184 and then Is_Signed_Integer_Type (Etype (N)) 3185 and then Do_Overflow_Check (N) 3186 then 3187 -- The only case to worry about is when the argument is 3188 -- equal to the largest negative number, so what we do is 3189 -- to insert the check: 3190 3191 -- [constraint_error when Expr = typ'Base'First] 3192 3193 -- with the usual Duplicate_Subexpr use coding for expr 3194 3195 Insert_Action (N, 3196 Make_Raise_Constraint_Error (Loc, 3197 Condition => 3198 Make_Op_Eq (Loc, 3199 Left_Opnd => Duplicate_Subexpr (Expr), 3200 Right_Opnd => 3201 Make_Attribute_Reference (Loc, 3202 Prefix => 3203 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), 3204 Attribute_Name => Name_First)), 3205 Reason => CE_Overflow_Check_Failed)); 3206 end if; 3207 3208 -- Vax floating-point types case 3209 3210 if Vax_Float (Etype (N)) then 3211 Expand_Vax_Arith (N); 3212 end if; 3213 end Expand_N_Op_Abs; 3214 3215 --------------------- 3216 -- Expand_N_Op_Add -- 3217 --------------------- 3218 3219 procedure Expand_N_Op_Add (N : Node_Id) is 3220 Typ : constant Entity_Id := Etype (N); 3221 3222 begin 3223 Binary_Op_Validity_Checks (N); 3224 3225 -- N + 0 = 0 + N = N for integer types 3226 3227 if Is_Integer_Type (Typ) then 3228 if Compile_Time_Known_Value (Right_Opnd (N)) 3229 and then Expr_Value (Right_Opnd (N)) = Uint_0 3230 then 3231 Rewrite (N, Left_Opnd (N)); 3232 return; 3233 3234 elsif Compile_Time_Known_Value (Left_Opnd (N)) 3235 and then Expr_Value (Left_Opnd (N)) = Uint_0 3236 then 3237 Rewrite (N, Right_Opnd (N)); 3238 return; 3239 end if; 3240 end if; 3241 3242 -- Arithmetic overflow checks for signed integer/fixed point types 3243 3244 if Is_Signed_Integer_Type (Typ) 3245 or else Is_Fixed_Point_Type (Typ) 3246 then 3247 Apply_Arithmetic_Overflow_Check (N); 3248 return; 3249 3250 -- Vax floating-point types case 3251 3252 elsif Vax_Float (Typ) then 3253 Expand_Vax_Arith (N); 3254 end if; 3255 end Expand_N_Op_Add; 3256 3257 --------------------- 3258 -- Expand_N_Op_And -- 3259 --------------------- 3260 3261 procedure Expand_N_Op_And (N : Node_Id) is 3262 Typ : constant Entity_Id := Etype (N); 3263 3264 begin 3265 Binary_Op_Validity_Checks (N); 3266 3267 if Is_Array_Type (Etype (N)) then 3268 Expand_Boolean_Operator (N); 3269 3270 elsif Is_Boolean_Type (Etype (N)) then 3271 Adjust_Condition (Left_Opnd (N)); 3272 Adjust_Condition (Right_Opnd (N)); 3273 Set_Etype (N, Standard_Boolean); 3274 Adjust_Result_Type (N, Typ); 3275 end if; 3276 end Expand_N_Op_And; 3277 3278 ------------------------ 3279 -- Expand_N_Op_Concat -- 3280 ------------------------ 3281 3282 Max_Available_String_Operands : Int := -1; 3283 -- This is initialized the first time this routine is called. It records 3284 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are 3285 -- available in the run-time: 3286 -- 3287 -- 0 None available 3288 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available 3289 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available 3290 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available 3291 -- 5 All routines including RE_Str_Concat_5 available 3292 3293 Char_Concat_Available : Boolean; 3294 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if 3295 -- all three are available, False if any one of these is unavailable. 3296 3297 procedure Expand_N_Op_Concat (N : Node_Id) is 3298 3299 Opnds : List_Id; 3300 -- List of operands to be concatenated 3301 3302 Opnd : Node_Id; 3303 -- Single operand for concatenation 3304 3305 Cnode : Node_Id; 3306 -- Node which is to be replaced by the result of concatenating 3307 -- the nodes in the list Opnds. 3308 3309 Atyp : Entity_Id; 3310 -- Array type of concatenation result type 3311 3312 Ctyp : Entity_Id; 3313 -- Component type of concatenation represented by Cnode 3314 3315 begin 3316 -- Initialize global variables showing run-time status 3317 3318 if Max_Available_String_Operands < 1 then 3319 if not RTE_Available (RE_Str_Concat) then 3320 Max_Available_String_Operands := 0; 3321 elsif not RTE_Available (RE_Str_Concat_3) then 3322 Max_Available_String_Operands := 2; 3323 elsif not RTE_Available (RE_Str_Concat_4) then 3324 Max_Available_String_Operands := 3; 3325 elsif not RTE_Available (RE_Str_Concat_5) then 3326 Max_Available_String_Operands := 4; 3327 else 3328 Max_Available_String_Operands := 5; 3329 end if; 3330 3331 Char_Concat_Available := 3332 RTE_Available (RE_Str_Concat_CC) 3333 and then 3334 RTE_Available (RE_Str_Concat_CS) 3335 and then 3336 RTE_Available (RE_Str_Concat_SC); 3337 end if; 3338 3339 -- Ensure validity of both operands 3340 3341 Binary_Op_Validity_Checks (N); 3342 3343 -- If we are the left operand of a concatenation higher up the 3344 -- tree, then do nothing for now, since we want to deal with a 3345 -- series of concatenations as a unit. 3346 3347 if Nkind (Parent (N)) = N_Op_Concat 3348 and then N = Left_Opnd (Parent (N)) 3349 then 3350 return; 3351 end if; 3352 3353 -- We get here with a concatenation whose left operand may be a 3354 -- concatenation itself with a consistent type. We need to process 3355 -- these concatenation operands from left to right, which means 3356 -- from the deepest node in the tree to the highest node. 3357 3358 Cnode := N; 3359 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop 3360 Cnode := Left_Opnd (Cnode); 3361 end loop; 3362 3363 -- Now Opnd is the deepest Opnd, and its parents are the concatenation 3364 -- nodes above, so now we process bottom up, doing the operations. We 3365 -- gather a string that is as long as possible up to five operands 3366 3367 -- The outer loop runs more than once if there are more than five 3368 -- concatenations of type Standard.String, the most we handle for 3369 -- this case, or if more than one concatenation type is involved. 3370 3371 Outer : loop 3372 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); 3373 Set_Parent (Opnds, N); 3374 3375 -- The inner loop gathers concatenation operands. We gather any 3376 -- number of these in the non-string case, or if no concatenation 3377 -- routines are available for string (since in that case we will 3378 -- treat string like any other non-string case). Otherwise we only 3379 -- gather as many operands as can be handled by the available 3380 -- procedures in the run-time library (normally 5, but may be 3381 -- less for the configurable run-time case). 3382 3383 Inner : while Cnode /= N 3384 and then (Base_Type (Etype (Cnode)) /= Standard_String 3385 or else 3386 Max_Available_String_Operands = 0 3387 or else 3388 List_Length (Opnds) < 3389 Max_Available_String_Operands) 3390 and then Base_Type (Etype (Cnode)) = 3391 Base_Type (Etype (Parent (Cnode))) 3392 loop 3393 Cnode := Parent (Cnode); 3394 Append (Right_Opnd (Cnode), Opnds); 3395 end loop Inner; 3396 3397 -- Here we process the collected operands. First we convert 3398 -- singleton operands to singleton aggregates. This is skipped 3399 -- however for the case of two operands of type String, since 3400 -- we have special routines for these cases. 3401 3402 Atyp := Base_Type (Etype (Cnode)); 3403 Ctyp := Base_Type (Component_Type (Etype (Cnode))); 3404 3405 if (List_Length (Opnds) > 2 or else Atyp /= Standard_String) 3406 or else not Char_Concat_Available 3407 then 3408 Opnd := First (Opnds); 3409 loop 3410 if Base_Type (Etype (Opnd)) = Ctyp then 3411 Rewrite (Opnd, 3412 Make_Aggregate (Sloc (Cnode), 3413 Expressions => New_List (Relocate_Node (Opnd)))); 3414 Analyze_And_Resolve (Opnd, Atyp); 3415 end if; 3416 3417 Next (Opnd); 3418 exit when No (Opnd); 3419 end loop; 3420 end if; 3421 3422 -- Now call appropriate continuation routine 3423 3424 if Atyp = Standard_String 3425 and then Max_Available_String_Operands > 0 3426 then 3427 Expand_Concatenate_String (Cnode, Opnds); 3428 else 3429 Expand_Concatenate_Other (Cnode, Opnds); 3430 end if; 3431 3432 exit Outer when Cnode = N; 3433 Cnode := Parent (Cnode); 3434 end loop Outer; 3435 end Expand_N_Op_Concat; 3436 3437 ------------------------ 3438 -- Expand_N_Op_Divide -- 3439 ------------------------ 3440 3441 procedure Expand_N_Op_Divide (N : Node_Id) is 3442 Loc : constant Source_Ptr := Sloc (N); 3443 Ltyp : constant Entity_Id := Etype (Left_Opnd (N)); 3444 Rtyp : constant Entity_Id := Etype (Right_Opnd (N)); 3445 Typ : Entity_Id := Etype (N); 3446 3447 begin 3448 Binary_Op_Validity_Checks (N); 3449 3450 -- Vax_Float is a special case 3451 3452 if Vax_Float (Typ) then 3453 Expand_Vax_Arith (N); 3454 return; 3455 end if; 3456 3457 -- N / 1 = N for integer types 3458 3459 if Is_Integer_Type (Typ) 3460 and then Compile_Time_Known_Value (Right_Opnd (N)) 3461 and then Expr_Value (Right_Opnd (N)) = Uint_1 3462 then 3463 Rewrite (N, Left_Opnd (N)); 3464 return; 3465 end if; 3466 3467 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that 3468 -- Is_Power_Of_2_For_Shift is set means that we know that our left 3469 -- operand is an unsigned integer, as required for this to work. 3470 3471 if Nkind (Right_Opnd (N)) = N_Op_Expon 3472 and then Is_Power_Of_2_For_Shift (Right_Opnd (N)) 3473 3474 -- We cannot do this transformation in configurable run time mode if we 3475 -- have 64-bit -- integers and long shifts are not available. 3476 3477 and then 3478 (Esize (Ltyp) <= 32 3479 or else Support_Long_Shifts_On_Target) 3480 then 3481 Rewrite (N, 3482 Make_Op_Shift_Right (Loc, 3483 Left_Opnd => Left_Opnd (N), 3484 Right_Opnd => 3485 Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N))))); 3486 Analyze_And_Resolve (N, Typ); 3487 return; 3488 end if; 3489 3490 -- Do required fixup of universal fixed operation 3491 3492 if Typ = Universal_Fixed then 3493 Fixup_Universal_Fixed_Operation (N); 3494 Typ := Etype (N); 3495 end if; 3496 3497 -- Divisions with fixed-point results 3498 3499 if Is_Fixed_Point_Type (Typ) then 3500 3501 -- No special processing if Treat_Fixed_As_Integer is set, 3502 -- since from a semantic point of view such operations are 3503 -- simply integer operations and will be treated that way. 3504 3505 if not Treat_Fixed_As_Integer (N) then 3506 if Is_Integer_Type (Rtyp) then 3507 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); 3508 else 3509 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); 3510 end if; 3511 end if; 3512 3513 -- Other cases of division of fixed-point operands. Again we 3514 -- exclude the case where Treat_Fixed_As_Integer is set. 3515 3516 elsif (Is_Fixed_Point_Type (Ltyp) or else 3517 Is_Fixed_Point_Type (Rtyp)) 3518 and then not Treat_Fixed_As_Integer (N) 3519 then 3520 if Is_Integer_Type (Typ) then 3521 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); 3522 else 3523 pragma Assert (Is_Floating_Point_Type (Typ)); 3524 Expand_Divide_Fixed_By_Fixed_Giving_Float (N); 3525 end if; 3526 3527 -- Mixed-mode operations can appear in a non-static universal 3528 -- context, in which case the integer argument must be converted 3529 -- explicitly. 3530 3531 elsif Typ = Universal_Real 3532 and then Is_Integer_Type (Rtyp) 3533 then 3534 Rewrite (Right_Opnd (N), 3535 Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N)))); 3536 3537 Analyze_And_Resolve (Right_Opnd (N), Universal_Real); 3538 3539 elsif Typ = Universal_Real 3540 and then Is_Integer_Type (Ltyp) 3541 then 3542 Rewrite (Left_Opnd (N), 3543 Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N)))); 3544 3545 Analyze_And_Resolve (Left_Opnd (N), Universal_Real); 3546 3547 -- Non-fixed point cases, do zero divide and overflow checks 3548 3549 elsif Is_Integer_Type (Typ) then 3550 Apply_Divide_Check (N); 3551 3552 -- Check for 64-bit division available 3553 3554 if Esize (Ltyp) > 32 3555 and then not Support_64_Bit_Divides_On_Target 3556 then 3557 Error_Msg_CRT ("64-bit division", N); 3558 end if; 3559 end if; 3560 end Expand_N_Op_Divide; 3561 3562 -------------------- 3563 -- Expand_N_Op_Eq -- 3564 -------------------- 3565 3566 procedure Expand_N_Op_Eq (N : Node_Id) is 3567 Loc : constant Source_Ptr := Sloc (N); 3568 Typ : constant Entity_Id := Etype (N); 3569 Lhs : constant Node_Id := Left_Opnd (N); 3570 Rhs : constant Node_Id := Right_Opnd (N); 3571 Bodies : constant List_Id := New_List; 3572 A_Typ : constant Entity_Id := Etype (Lhs); 3573 3574 Typl : Entity_Id := A_Typ; 3575 Op_Name : Entity_Id; 3576 Prim : Elmt_Id; 3577 3578 procedure Build_Equality_Call (Eq : Entity_Id); 3579 -- If a constructed equality exists for the type or for its parent, 3580 -- build and analyze call, adding conversions if the operation is 3581 -- inherited. 3582 3583 ------------------------- 3584 -- Build_Equality_Call -- 3585 ------------------------- 3586 3587 procedure Build_Equality_Call (Eq : Entity_Id) is 3588 Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); 3589 L_Exp : Node_Id := Relocate_Node (Lhs); 3590 R_Exp : Node_Id := Relocate_Node (Rhs); 3591 3592 begin 3593 if Base_Type (Op_Type) /= Base_Type (A_Typ) 3594 and then not Is_Class_Wide_Type (A_Typ) 3595 then 3596 L_Exp := OK_Convert_To (Op_Type, L_Exp); 3597 R_Exp := OK_Convert_To (Op_Type, R_Exp); 3598 end if; 3599 3600 Rewrite (N, 3601 Make_Function_Call (Loc, 3602 Name => New_Reference_To (Eq, Loc), 3603 Parameter_Associations => New_List (L_Exp, R_Exp))); 3604 3605 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 3606 end Build_Equality_Call; 3607 3608 -- Start of processing for Expand_N_Op_Eq 3609 3610 begin 3611 Binary_Op_Validity_Checks (N); 3612 3613 if Ekind (Typl) = E_Private_Type then 3614 Typl := Underlying_Type (Typl); 3615 3616 elsif Ekind (Typl) = E_Private_Subtype then 3617 Typl := Underlying_Type (Base_Type (Typl)); 3618 end if; 3619 3620 -- It may happen in error situations that the underlying type is not 3621 -- set. The error will be detected later, here we just defend the 3622 -- expander code. 3623 3624 if No (Typl) then 3625 return; 3626 end if; 3627 3628 Typl := Base_Type (Typl); 3629 3630 -- Vax float types 3631 3632 if Vax_Float (Typl) then 3633 Expand_Vax_Comparison (N); 3634 return; 3635 3636 -- Boolean types (requiring handling of non-standard case) 3637 3638 elsif Is_Boolean_Type (Typl) then 3639 Adjust_Condition (Left_Opnd (N)); 3640 Adjust_Condition (Right_Opnd (N)); 3641 Set_Etype (N, Standard_Boolean); 3642 Adjust_Result_Type (N, Typ); 3643 3644 -- Array types 3645 3646 elsif Is_Array_Type (Typl) then 3647 3648 -- If we are doing full validity checking, then expand out array 3649 -- comparisons to make sure that we check the array elements. 3650 3651 if Validity_Check_Operands then 3652 declare 3653 Save_Force_Validity_Checks : constant Boolean := 3654 Force_Validity_Checks; 3655 begin 3656 Force_Validity_Checks := True; 3657 Rewrite (N, 3658 Expand_Array_Equality (N, Typl, A_Typ, 3659 Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies)); 3660 3661 Insert_Actions (N, Bodies); 3662 Analyze_And_Resolve (N, Standard_Boolean); 3663 Force_Validity_Checks := Save_Force_Validity_Checks; 3664 end; 3665 3666 -- Packed case 3667 3668 elsif Is_Bit_Packed_Array (Typl) then 3669 Expand_Packed_Eq (N); 3670 3671 -- For non-floating-point elementary types, the primitive equality 3672 -- always applies, and block-bit comparison is fine. Floating-point 3673 -- is an exception because of negative zeroes. 3674 3675 elsif Is_Elementary_Type (Component_Type (Typl)) 3676 and then not Is_Floating_Point_Type (Component_Type (Typl)) 3677 and then Support_Composite_Compare_On_Target 3678 then 3679 null; 3680 3681 -- For composite and floating-point cases, expand equality loop 3682 -- to make sure of using proper comparisons for tagged types, 3683 -- and correctly handling the floating-point case. 3684 3685 else 3686 Rewrite (N, 3687 Expand_Array_Equality (N, Typl, A_Typ, 3688 Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies)); 3689 3690 Insert_Actions (N, Bodies, Suppress => All_Checks); 3691 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 3692 end if; 3693 3694 -- Record Types 3695 3696 elsif Is_Record_Type (Typl) then 3697 3698 -- For tagged types, use the primitive "=" 3699 3700 if Is_Tagged_Type (Typl) then 3701 3702 -- If this is derived from an untagged private type completed 3703 -- with a tagged type, it does not have a full view, so we 3704 -- use the primitive operations of the private type. 3705 -- This check should no longer be necessary when these 3706 -- types receive their full views ??? 3707 3708 if Is_Private_Type (A_Typ) 3709 and then not Is_Tagged_Type (A_Typ) 3710 and then Is_Derived_Type (A_Typ) 3711 and then No (Full_View (A_Typ)) 3712 then 3713 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); 3714 3715 while Chars (Node (Prim)) /= Name_Op_Eq loop 3716 Next_Elmt (Prim); 3717 pragma Assert (Present (Prim)); 3718 end loop; 3719 3720 Op_Name := Node (Prim); 3721 3722 -- Find the type's predefined equality or an overriding 3723 -- user-defined equality. The reason for not simply calling 3724 -- Find_Prim_Op here is that there may be a user-defined 3725 -- overloaded equality op that precedes the equality that 3726 -- we want, so we have to explicitly search (e.g., there 3727 -- could be an equality with two different parameter types). 3728 3729 else 3730 if Is_Class_Wide_Type (Typl) then 3731 Typl := Root_Type (Typl); 3732 end if; 3733 3734 Prim := First_Elmt (Primitive_Operations (Typl)); 3735 3736 while Present (Prim) loop 3737 exit when Chars (Node (Prim)) = Name_Op_Eq 3738 and then Etype (First_Formal (Node (Prim))) = 3739 Etype (Next_Formal (First_Formal (Node (Prim)))) 3740 and then 3741 Base_Type (Etype (Node (Prim))) = Standard_Boolean; 3742 3743 Next_Elmt (Prim); 3744 pragma Assert (Present (Prim)); 3745 end loop; 3746 3747 Op_Name := Node (Prim); 3748 end if; 3749 3750 Build_Equality_Call (Op_Name); 3751 3752 -- If a type support function is present (for complex cases), use it 3753 3754 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then 3755 Build_Equality_Call 3756 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 3757 3758 -- Otherwise expand the component by component equality. Note that 3759 -- we never use block-bit coparisons for records, because of the 3760 -- problems with gaps. The backend will often be able to recombine 3761 -- the separate comparisons that we generate here. 3762 3763 else 3764 Remove_Side_Effects (Lhs); 3765 Remove_Side_Effects (Rhs); 3766 Rewrite (N, 3767 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); 3768 3769 Insert_Actions (N, Bodies, Suppress => All_Checks); 3770 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 3771 end if; 3772 end if; 3773 3774 -- If we still have an equality comparison (i.e. it was not rewritten 3775 -- in some way), then we can test if result is needed at compile time). 3776 3777 if Nkind (N) = N_Op_Eq then 3778 Rewrite_Comparison (N); 3779 end if; 3780 end Expand_N_Op_Eq; 3781 3782 ----------------------- 3783 -- Expand_N_Op_Expon -- 3784 ----------------------- 3785 3786 procedure Expand_N_Op_Expon (N : Node_Id) is 3787 Loc : constant Source_Ptr := Sloc (N); 3788 Typ : constant Entity_Id := Etype (N); 3789 Rtyp : constant Entity_Id := Root_Type (Typ); 3790 Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); 3791 Bastyp : constant Node_Id := Etype (Base); 3792 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); 3793 Exptyp : constant Entity_Id := Etype (Exp); 3794 Ovflo : constant Boolean := Do_Overflow_Check (N); 3795 Expv : Uint; 3796 Xnode : Node_Id; 3797 Temp : Node_Id; 3798 Rent : RE_Id; 3799 Ent : Entity_Id; 3800 Etyp : Entity_Id; 3801 3802 begin 3803 Binary_Op_Validity_Checks (N); 3804 3805 -- If either operand is of a private type, then we have the use of 3806 -- an intrinsic operator, and we get rid of the privateness, by using 3807 -- root types of underlying types for the actual operation. Otherwise 3808 -- the private types will cause trouble if we expand multiplications 3809 -- or shifts etc. We also do this transformation if the result type 3810 -- is different from the base type. 3811 3812 if Is_Private_Type (Etype (Base)) 3813 or else 3814 Is_Private_Type (Typ) 3815 or else 3816 Is_Private_Type (Exptyp) 3817 or else 3818 Rtyp /= Root_Type (Bastyp) 3819 then 3820 declare 3821 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); 3822 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); 3823 3824 begin 3825 Rewrite (N, 3826 Unchecked_Convert_To (Typ, 3827 Make_Op_Expon (Loc, 3828 Left_Opnd => Unchecked_Convert_To (Bt, Base), 3829 Right_Opnd => Unchecked_Convert_To (Et, Exp)))); 3830 Analyze_And_Resolve (N, Typ); 3831 return; 3832 end; 3833 end if; 3834 3835 -- Test for case of known right argument 3836 3837 if Compile_Time_Known_Value (Exp) then 3838 Expv := Expr_Value (Exp); 3839 3840 -- We only fold small non-negative exponents. You might think we 3841 -- could fold small negative exponents for the real case, but we 3842 -- can't because we are required to raise Constraint_Error for 3843 -- the case of 0.0 ** (negative) even if Machine_Overflows = False. 3844 -- See ACVC test C4A012B. 3845 3846 if Expv >= 0 and then Expv <= 4 then 3847 3848 -- X ** 0 = 1 (or 1.0) 3849 3850 if Expv = 0 then 3851 if Ekind (Typ) in Integer_Kind then 3852 Xnode := Make_Integer_Literal (Loc, Intval => 1); 3853 else 3854 Xnode := Make_Real_Literal (Loc, Ureal_1); 3855 end if; 3856 3857 -- X ** 1 = X 3858 3859 elsif Expv = 1 then 3860 Xnode := Base; 3861 3862 -- X ** 2 = X * X 3863 3864 elsif Expv = 2 then 3865 Xnode := 3866 Make_Op_Multiply (Loc, 3867 Left_Opnd => Duplicate_Subexpr (Base), 3868 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)); 3869 3870 -- X ** 3 = X * X * X 3871 3872 elsif Expv = 3 then 3873 Xnode := 3874 Make_Op_Multiply (Loc, 3875 Left_Opnd => 3876 Make_Op_Multiply (Loc, 3877 Left_Opnd => Duplicate_Subexpr (Base), 3878 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)), 3879 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)); 3880 3881 -- X ** 4 -> 3882 -- En : constant base'type := base * base; 3883 -- ... 3884 -- En * En 3885 3886 else -- Expv = 4 3887 Temp := 3888 Make_Defining_Identifier (Loc, New_Internal_Name ('E')); 3889 3890 Insert_Actions (N, New_List ( 3891 Make_Object_Declaration (Loc, 3892 Defining_Identifier => Temp, 3893 Constant_Present => True, 3894 Object_Definition => New_Reference_To (Typ, Loc), 3895 Expression => 3896 Make_Op_Multiply (Loc, 3897 Left_Opnd => Duplicate_Subexpr (Base), 3898 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))))); 3899 3900 Xnode := 3901 Make_Op_Multiply (Loc, 3902 Left_Opnd => New_Reference_To (Temp, Loc), 3903 Right_Opnd => New_Reference_To (Temp, Loc)); 3904 end if; 3905 3906 Rewrite (N, Xnode); 3907 Analyze_And_Resolve (N, Typ); 3908 return; 3909 end if; 3910 end if; 3911 3912 -- Case of (2 ** expression) appearing as an argument of an integer 3913 -- multiplication, or as the right argument of a division of a non- 3914 -- negative integer. In such cases we leave the node untouched, setting 3915 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion 3916 -- of the higher level node converts it into a shift. 3917 3918 if Nkind (Base) = N_Integer_Literal 3919 and then Intval (Base) = 2 3920 and then Is_Integer_Type (Root_Type (Exptyp)) 3921 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) 3922 and then Is_Unsigned_Type (Exptyp) 3923 and then not Ovflo 3924 and then Nkind (Parent (N)) in N_Binary_Op 3925 then 3926 declare 3927 P : constant Node_Id := Parent (N); 3928 L : constant Node_Id := Left_Opnd (P); 3929 R : constant Node_Id := Right_Opnd (P); 3930 3931 begin 3932 if (Nkind (P) = N_Op_Multiply 3933 and then 3934 ((Is_Integer_Type (Etype (L)) and then R = N) 3935 or else 3936 (Is_Integer_Type (Etype (R)) and then L = N)) 3937 and then not Do_Overflow_Check (P)) 3938 3939 or else 3940 (Nkind (P) = N_Op_Divide 3941 and then Is_Integer_Type (Etype (L)) 3942 and then Is_Unsigned_Type (Etype (L)) 3943 and then R = N 3944 and then not Do_Overflow_Check (P)) 3945 then 3946 Set_Is_Power_Of_2_For_Shift (N); 3947 return; 3948 end if; 3949 end; 3950 end if; 3951 3952 -- Fall through if exponentiation must be done using a runtime routine 3953 3954 -- First deal with modular case 3955 3956 if Is_Modular_Integer_Type (Rtyp) then 3957 3958 -- Non-binary case, we call the special exponentiation routine for 3959 -- the non-binary case, converting the argument to Long_Long_Integer 3960 -- and passing the modulus value. Then the result is converted back 3961 -- to the base type. 3962 3963 if Non_Binary_Modulus (Rtyp) then 3964 Rewrite (N, 3965 Convert_To (Typ, 3966 Make_Function_Call (Loc, 3967 Name => New_Reference_To (RTE (RE_Exp_Modular), Loc), 3968 Parameter_Associations => New_List ( 3969 Convert_To (Standard_Integer, Base), 3970 Make_Integer_Literal (Loc, Modulus (Rtyp)), 3971 Exp)))); 3972 3973 -- Binary case, in this case, we call one of two routines, either 3974 -- the unsigned integer case, or the unsigned long long integer 3975 -- case, with a final "and" operation to do the required mod. 3976 3977 else 3978 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 3979 Ent := RTE (RE_Exp_Unsigned); 3980 else 3981 Ent := RTE (RE_Exp_Long_Long_Unsigned); 3982 end if; 3983 3984 Rewrite (N, 3985 Convert_To (Typ, 3986 Make_Op_And (Loc, 3987 Left_Opnd => 3988 Make_Function_Call (Loc, 3989 Name => New_Reference_To (Ent, Loc), 3990 Parameter_Associations => New_List ( 3991 Convert_To (Etype (First_Formal (Ent)), Base), 3992 Exp)), 3993 Right_Opnd => 3994 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); 3995 3996 end if; 3997 3998 -- Common exit point for modular type case 3999 4000 Analyze_And_Resolve (N, Typ); 4001 return; 4002 4003 -- Signed integer cases, done using either Integer or Long_Long_Integer. 4004 -- It is not worth having routines for Short_[Short_]Integer, since for 4005 -- most machines it would not help, and it would generate more code that 4006 -- might need certification in the HI-E case. 4007 4008 -- In the integer cases, we have two routines, one for when overflow 4009 -- checks are required, and one when they are not required, since 4010 -- there is a real gain in ommitting checks on many machines. 4011 4012 elsif Rtyp = Base_Type (Standard_Long_Long_Integer) 4013 or else (Rtyp = Base_Type (Standard_Long_Integer) 4014 and then 4015 Esize (Standard_Long_Integer) > Esize (Standard_Integer)) 4016 or else (Rtyp = Universal_Integer) 4017 then 4018 Etyp := Standard_Long_Long_Integer; 4019 4020 if Ovflo then 4021 Rent := RE_Exp_Long_Long_Integer; 4022 else 4023 Rent := RE_Exn_Long_Long_Integer; 4024 end if; 4025 4026 elsif Is_Signed_Integer_Type (Rtyp) then 4027 Etyp := Standard_Integer; 4028 4029 if Ovflo then 4030 Rent := RE_Exp_Integer; 4031 else 4032 Rent := RE_Exn_Integer; 4033 end if; 4034 4035 -- Floating-point cases, always done using Long_Long_Float. We do not 4036 -- need separate routines for the overflow case here, since in the case 4037 -- of floating-point, we generate infinities anyway as a rule (either 4038 -- that or we automatically trap overflow), and if there is an infinity 4039 -- generated and a range check is required, the check will fail anyway. 4040 4041 else 4042 pragma Assert (Is_Floating_Point_Type (Rtyp)); 4043 Etyp := Standard_Long_Long_Float; 4044 Rent := RE_Exn_Long_Long_Float; 4045 end if; 4046 4047 -- Common processing for integer cases and floating-point cases. 4048 -- If we are in the right type, we can call runtime routine directly 4049 4050 if Typ = Etyp 4051 and then Rtyp /= Universal_Integer 4052 and then Rtyp /= Universal_Real 4053 then 4054 Rewrite (N, 4055 Make_Function_Call (Loc, 4056 Name => New_Reference_To (RTE (Rent), Loc), 4057 Parameter_Associations => New_List (Base, Exp))); 4058 4059 -- Otherwise we have to introduce conversions (conversions are also 4060 -- required in the universal cases, since the runtime routine is 4061 -- typed using one of the standard types. 4062 4063 else 4064 Rewrite (N, 4065 Convert_To (Typ, 4066 Make_Function_Call (Loc, 4067 Name => New_Reference_To (RTE (Rent), Loc), 4068 Parameter_Associations => New_List ( 4069 Convert_To (Etyp, Base), 4070 Exp)))); 4071 end if; 4072 4073 Analyze_And_Resolve (N, Typ); 4074 return; 4075 4076 exception 4077 when RE_Not_Available => 4078 return; 4079 end Expand_N_Op_Expon; 4080 4081 -------------------- 4082 -- Expand_N_Op_Ge -- 4083 -------------------- 4084 4085 procedure Expand_N_Op_Ge (N : Node_Id) is 4086 Typ : constant Entity_Id := Etype (N); 4087 Op1 : constant Node_Id := Left_Opnd (N); 4088 Op2 : constant Node_Id := Right_Opnd (N); 4089 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 4090 4091 begin 4092 Binary_Op_Validity_Checks (N); 4093 4094 if Vax_Float (Typ1) then 4095 Expand_Vax_Comparison (N); 4096 return; 4097 4098 elsif Is_Array_Type (Typ1) then 4099 Expand_Array_Comparison (N); 4100 return; 4101 end if; 4102 4103 if Is_Boolean_Type (Typ1) then 4104 Adjust_Condition (Op1); 4105 Adjust_Condition (Op2); 4106 Set_Etype (N, Standard_Boolean); 4107 Adjust_Result_Type (N, Typ); 4108 end if; 4109 4110 Rewrite_Comparison (N); 4111 end Expand_N_Op_Ge; 4112 4113 -------------------- 4114 -- Expand_N_Op_Gt -- 4115 -------------------- 4116 4117 procedure Expand_N_Op_Gt (N : Node_Id) is 4118 Typ : constant Entity_Id := Etype (N); 4119 Op1 : constant Node_Id := Left_Opnd (N); 4120 Op2 : constant Node_Id := Right_Opnd (N); 4121 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 4122 4123 begin 4124 Binary_Op_Validity_Checks (N); 4125 4126 if Vax_Float (Typ1) then 4127 Expand_Vax_Comparison (N); 4128 return; 4129 4130 elsif Is_Array_Type (Typ1) then 4131 Expand_Array_Comparison (N); 4132 return; 4133 end if; 4134 4135 if Is_Boolean_Type (Typ1) then 4136 Adjust_Condition (Op1); 4137 Adjust_Condition (Op2); 4138 Set_Etype (N, Standard_Boolean); 4139 Adjust_Result_Type (N, Typ); 4140 end if; 4141 4142 Rewrite_Comparison (N); 4143 end Expand_N_Op_Gt; 4144 4145 -------------------- 4146 -- Expand_N_Op_Le -- 4147 -------------------- 4148 4149 procedure Expand_N_Op_Le (N : Node_Id) is 4150 Typ : constant Entity_Id := Etype (N); 4151 Op1 : constant Node_Id := Left_Opnd (N); 4152 Op2 : constant Node_Id := Right_Opnd (N); 4153 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 4154 4155 begin 4156 Binary_Op_Validity_Checks (N); 4157 4158 if Vax_Float (Typ1) then 4159 Expand_Vax_Comparison (N); 4160 return; 4161 4162 elsif Is_Array_Type (Typ1) then 4163 Expand_Array_Comparison (N); 4164 return; 4165 end if; 4166 4167 if Is_Boolean_Type (Typ1) then 4168 Adjust_Condition (Op1); 4169 Adjust_Condition (Op2); 4170 Set_Etype (N, Standard_Boolean); 4171 Adjust_Result_Type (N, Typ); 4172 end if; 4173 4174 Rewrite_Comparison (N); 4175 end Expand_N_Op_Le; 4176 4177 -------------------- 4178 -- Expand_N_Op_Lt -- 4179 -------------------- 4180 4181 procedure Expand_N_Op_Lt (N : Node_Id) is 4182 Typ : constant Entity_Id := Etype (N); 4183 Op1 : constant Node_Id := Left_Opnd (N); 4184 Op2 : constant Node_Id := Right_Opnd (N); 4185 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 4186 4187 begin 4188 Binary_Op_Validity_Checks (N); 4189 4190 if Vax_Float (Typ1) then 4191 Expand_Vax_Comparison (N); 4192 return; 4193 4194 elsif Is_Array_Type (Typ1) then 4195 Expand_Array_Comparison (N); 4196 return; 4197 end if; 4198 4199 if Is_Boolean_Type (Typ1) then 4200 Adjust_Condition (Op1); 4201 Adjust_Condition (Op2); 4202 Set_Etype (N, Standard_Boolean); 4203 Adjust_Result_Type (N, Typ); 4204 end if; 4205 4206 Rewrite_Comparison (N); 4207 end Expand_N_Op_Lt; 4208 4209 ----------------------- 4210 -- Expand_N_Op_Minus -- 4211 ----------------------- 4212 4213 procedure Expand_N_Op_Minus (N : Node_Id) is 4214 Loc : constant Source_Ptr := Sloc (N); 4215 Typ : constant Entity_Id := Etype (N); 4216 4217 begin 4218 Unary_Op_Validity_Checks (N); 4219 4220 if not Backend_Overflow_Checks_On_Target 4221 and then Is_Signed_Integer_Type (Etype (N)) 4222 and then Do_Overflow_Check (N) 4223 then 4224 -- Software overflow checking expands -expr into (0 - expr) 4225 4226 Rewrite (N, 4227 Make_Op_Subtract (Loc, 4228 Left_Opnd => Make_Integer_Literal (Loc, 0), 4229 Right_Opnd => Right_Opnd (N))); 4230 4231 Analyze_And_Resolve (N, Typ); 4232 4233 -- Vax floating-point types case 4234 4235 elsif Vax_Float (Etype (N)) then 4236 Expand_Vax_Arith (N); 4237 end if; 4238 end Expand_N_Op_Minus; 4239 4240 --------------------- 4241 -- Expand_N_Op_Mod -- 4242 --------------------- 4243 4244 procedure Expand_N_Op_Mod (N : Node_Id) is 4245 Loc : constant Source_Ptr := Sloc (N); 4246 Typ : constant Entity_Id := Etype (N); 4247 Left : constant Node_Id := Left_Opnd (N); 4248 Right : constant Node_Id := Right_Opnd (N); 4249 DOC : constant Boolean := Do_Overflow_Check (N); 4250 DDC : constant Boolean := Do_Division_Check (N); 4251 4252 LLB : Uint; 4253 Llo : Uint; 4254 Lhi : Uint; 4255 LOK : Boolean; 4256 Rlo : Uint; 4257 Rhi : Uint; 4258 ROK : Boolean; 4259 4260 begin 4261 Binary_Op_Validity_Checks (N); 4262 4263 Determine_Range (Right, ROK, Rlo, Rhi); 4264 Determine_Range (Left, LOK, Llo, Lhi); 4265 4266 -- Convert mod to rem if operands are known non-negative. We do this 4267 -- since it is quite likely that this will improve the quality of code, 4268 -- (the operation now corresponds to the hardware remainder), and it 4269 -- does not seem likely that it could be harmful. 4270 4271 if LOK and then Llo >= 0 4272 and then 4273 ROK and then Rlo >= 0 4274 then 4275 Rewrite (N, 4276 Make_Op_Rem (Sloc (N), 4277 Left_Opnd => Left_Opnd (N), 4278 Right_Opnd => Right_Opnd (N))); 4279 4280 -- Instead of reanalyzing the node we do the analysis manually. 4281 -- This avoids anomalies when the replacement is done in an 4282 -- instance and is epsilon more efficient. 4283 4284 Set_Entity (N, Standard_Entity (S_Op_Rem)); 4285 Set_Etype (N, Typ); 4286 Set_Do_Overflow_Check (N, DOC); 4287 Set_Do_Division_Check (N, DDC); 4288 Expand_N_Op_Rem (N); 4289 Set_Analyzed (N); 4290 4291 -- Otherwise, normal mod processing 4292 4293 else 4294 if Is_Integer_Type (Etype (N)) then 4295 Apply_Divide_Check (N); 4296 end if; 4297 4298 -- Apply optimization x mod 1 = 0. We don't really need that with 4299 -- gcc, but it is useful with other back ends (e.g. AAMP), and is 4300 -- certainly harmless. 4301 4302 if Is_Integer_Type (Etype (N)) 4303 and then Compile_Time_Known_Value (Right) 4304 and then Expr_Value (Right) = Uint_1 4305 then 4306 Rewrite (N, Make_Integer_Literal (Loc, 0)); 4307 Analyze_And_Resolve (N, Typ); 4308 return; 4309 end if; 4310 4311 -- Deal with annoying case of largest negative number remainder 4312 -- minus one. Gigi does not handle this case correctly, because 4313 -- it generates a divide instruction which may trap in this case. 4314 4315 -- In fact the check is quite easy, if the right operand is -1, 4316 -- then the mod value is always 0, and we can just ignore the 4317 -- left operand completely in this case. 4318 4319 -- The operand type may be private (e.g. in the expansion of an 4320 -- an intrinsic operation) so we must use the underlying type to 4321 -- get the bounds, and convert the literals explicitly. 4322 4323 LLB := 4324 Expr_Value 4325 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); 4326 4327 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 4328 and then 4329 ((not LOK) or else (Llo = LLB)) 4330 then 4331 Rewrite (N, 4332 Make_Conditional_Expression (Loc, 4333 Expressions => New_List ( 4334 Make_Op_Eq (Loc, 4335 Left_Opnd => Duplicate_Subexpr (Right), 4336 Right_Opnd => 4337 Unchecked_Convert_To (Typ, 4338 Make_Integer_Literal (Loc, -1))), 4339 Unchecked_Convert_To (Typ, 4340 Make_Integer_Literal (Loc, Uint_0)), 4341 Relocate_Node (N)))); 4342 4343 Set_Analyzed (Next (Next (First (Expressions (N))))); 4344 Analyze_And_Resolve (N, Typ); 4345 end if; 4346 end if; 4347 end Expand_N_Op_Mod; 4348 4349 -------------------------- 4350 -- Expand_N_Op_Multiply -- 4351 -------------------------- 4352 4353 procedure Expand_N_Op_Multiply (N : Node_Id) is 4354 Loc : constant Source_Ptr := Sloc (N); 4355 Lop : constant Node_Id := Left_Opnd (N); 4356 Rop : constant Node_Id := Right_Opnd (N); 4357 4358 Lp2 : constant Boolean := 4359 Nkind (Lop) = N_Op_Expon 4360 and then Is_Power_Of_2_For_Shift (Lop); 4361 4362 Rp2 : constant Boolean := 4363 Nkind (Rop) = N_Op_Expon 4364 and then Is_Power_Of_2_For_Shift (Rop); 4365 4366 Ltyp : constant Entity_Id := Etype (Lop); 4367 Rtyp : constant Entity_Id := Etype (Rop); 4368 Typ : Entity_Id := Etype (N); 4369 4370 begin 4371 Binary_Op_Validity_Checks (N); 4372 4373 -- Special optimizations for integer types 4374 4375 if Is_Integer_Type (Typ) then 4376 4377 -- N * 0 = 0 * N = 0 for integer types 4378 4379 if (Compile_Time_Known_Value (Rop) 4380 and then Expr_Value (Rop) = Uint_0) 4381 or else 4382 (Compile_Time_Known_Value (Lop) 4383 and then Expr_Value (Lop) = Uint_0) 4384 then 4385 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 4386 Analyze_And_Resolve (N, Typ); 4387 return; 4388 end if; 4389 4390 -- N * 1 = 1 * N = N for integer types 4391 4392 -- This optimisation is not done if we are going to 4393 -- rewrite the product 1 * 2 ** N to a shift. 4394 4395 if Compile_Time_Known_Value (Rop) 4396 and then Expr_Value (Rop) = Uint_1 4397 and then not Lp2 4398 then 4399 Rewrite (N, Lop); 4400 return; 4401 4402 elsif Compile_Time_Known_Value (Lop) 4403 and then Expr_Value (Lop) = Uint_1 4404 and then not Rp2 4405 then 4406 Rewrite (N, Rop); 4407 return; 4408 end if; 4409 end if; 4410 4411 -- Deal with VAX float case 4412 4413 if Vax_Float (Typ) then 4414 Expand_Vax_Arith (N); 4415 return; 4416 end if; 4417 4418 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that 4419 -- Is_Power_Of_2_For_Shift is set means that we know that our left 4420 -- operand is an integer, as required for this to work. 4421 4422 if Rp2 then 4423 if Lp2 then 4424 4425 -- Convert 2 ** A * 2 ** B into 2 ** (A + B) 4426 4427 Rewrite (N, 4428 Make_Op_Expon (Loc, 4429 Left_Opnd => Make_Integer_Literal (Loc, 2), 4430 Right_Opnd => 4431 Make_Op_Add (Loc, 4432 Left_Opnd => Right_Opnd (Lop), 4433 Right_Opnd => Right_Opnd (Rop)))); 4434 Analyze_And_Resolve (N, Typ); 4435 return; 4436 4437 else 4438 Rewrite (N, 4439 Make_Op_Shift_Left (Loc, 4440 Left_Opnd => Lop, 4441 Right_Opnd => 4442 Convert_To (Standard_Natural, Right_Opnd (Rop)))); 4443 Analyze_And_Resolve (N, Typ); 4444 return; 4445 end if; 4446 4447 -- Same processing for the operands the other way round 4448 4449 elsif Lp2 then 4450 Rewrite (N, 4451 Make_Op_Shift_Left (Loc, 4452 Left_Opnd => Rop, 4453 Right_Opnd => 4454 Convert_To (Standard_Natural, Right_Opnd (Lop)))); 4455 Analyze_And_Resolve (N, Typ); 4456 return; 4457 end if; 4458 4459 -- Do required fixup of universal fixed operation 4460 4461 if Typ = Universal_Fixed then 4462 Fixup_Universal_Fixed_Operation (N); 4463 Typ := Etype (N); 4464 end if; 4465 4466 -- Multiplications with fixed-point results 4467 4468 if Is_Fixed_Point_Type (Typ) then 4469 4470 -- No special processing if Treat_Fixed_As_Integer is set, 4471 -- since from a semantic point of view such operations are 4472 -- simply integer operations and will be treated that way. 4473 4474 if not Treat_Fixed_As_Integer (N) then 4475 4476 -- Case of fixed * integer => fixed 4477 4478 if Is_Integer_Type (Rtyp) then 4479 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); 4480 4481 -- Case of integer * fixed => fixed 4482 4483 elsif Is_Integer_Type (Ltyp) then 4484 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); 4485 4486 -- Case of fixed * fixed => fixed 4487 4488 else 4489 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); 4490 end if; 4491 end if; 4492 4493 -- Other cases of multiplication of fixed-point operands. Again 4494 -- we exclude the cases where Treat_Fixed_As_Integer flag is set. 4495 4496 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) 4497 and then not Treat_Fixed_As_Integer (N) 4498 then 4499 if Is_Integer_Type (Typ) then 4500 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); 4501 else 4502 pragma Assert (Is_Floating_Point_Type (Typ)); 4503 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); 4504 end if; 4505 4506 -- Mixed-mode operations can appear in a non-static universal 4507 -- context, in which case the integer argument must be converted 4508 -- explicitly. 4509 4510 elsif Typ = Universal_Real 4511 and then Is_Integer_Type (Rtyp) 4512 then 4513 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); 4514 4515 Analyze_And_Resolve (Rop, Universal_Real); 4516 4517 elsif Typ = Universal_Real 4518 and then Is_Integer_Type (Ltyp) 4519 then 4520 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); 4521 4522 Analyze_And_Resolve (Lop, Universal_Real); 4523 4524 -- Non-fixed point cases, check software overflow checking required 4525 4526 elsif Is_Signed_Integer_Type (Etype (N)) then 4527 Apply_Arithmetic_Overflow_Check (N); 4528 end if; 4529 end Expand_N_Op_Multiply; 4530 4531 -------------------- 4532 -- Expand_N_Op_Ne -- 4533 -------------------- 4534 4535 -- Rewrite node as the negation of an equality operation, and reanalyze. 4536 -- The equality to be used is defined in the same scope and has the same 4537 -- signature. It must be set explicitly because in an instance it may not 4538 -- have the same visibility as in the generic unit. 4539 4540 procedure Expand_N_Op_Ne (N : Node_Id) is 4541 Loc : constant Source_Ptr := Sloc (N); 4542 Neg : Node_Id; 4543 Ne : constant Entity_Id := Entity (N); 4544 4545 begin 4546 Binary_Op_Validity_Checks (N); 4547 4548 Neg := 4549 Make_Op_Not (Loc, 4550 Right_Opnd => 4551 Make_Op_Eq (Loc, 4552 Left_Opnd => Left_Opnd (N), 4553 Right_Opnd => Right_Opnd (N))); 4554 Set_Paren_Count (Right_Opnd (Neg), 1); 4555 4556 if Scope (Ne) /= Standard_Standard then 4557 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); 4558 end if; 4559 4560 -- For navigation purposes, the inequality is treated as an implicit 4561 -- reference to the corresponding equality. Preserve the Comes_From_ 4562 -- source flag so that the proper Xref entry is generated. 4563 4564 Preserve_Comes_From_Source (Neg, N); 4565 Preserve_Comes_From_Source (Right_Opnd (Neg), N); 4566 Rewrite (N, Neg); 4567 Analyze_And_Resolve (N, Standard_Boolean); 4568 end Expand_N_Op_Ne; 4569 4570 --------------------- 4571 -- Expand_N_Op_Not -- 4572 --------------------- 4573 4574 -- If the argument is other than a Boolean array type, there is no 4575 -- special expansion required. 4576 4577 -- For the packed case, we call the special routine in Exp_Pakd, except 4578 -- that if the component size is greater than one, we use the standard 4579 -- routine generating a gruesome loop (it is so peculiar to have packed 4580 -- arrays with non-standard Boolean representations anyway, so it does 4581 -- not matter that we do not handle this case efficiently). 4582 4583 -- For the unpacked case (and for the special packed case where we have 4584 -- non standard Booleans, as discussed above), we generate and insert 4585 -- into the tree the following function definition: 4586 4587 -- function Nnnn (A : arr) is 4588 -- B : arr; 4589 -- begin 4590 -- for J in a'range loop 4591 -- B (J) := not A (J); 4592 -- end loop; 4593 -- return B; 4594 -- end Nnnn; 4595 4596 -- Here arr is the actual subtype of the parameter (and hence always 4597 -- constrained). Then we replace the not with a call to this function. 4598 4599 procedure Expand_N_Op_Not (N : Node_Id) is 4600 Loc : constant Source_Ptr := Sloc (N); 4601 Typ : constant Entity_Id := Etype (N); 4602 Opnd : Node_Id; 4603 Arr : Entity_Id; 4604 A : Entity_Id; 4605 B : Entity_Id; 4606 J : Entity_Id; 4607 A_J : Node_Id; 4608 B_J : Node_Id; 4609 4610 Func_Name : Entity_Id; 4611 Loop_Statement : Node_Id; 4612 4613 begin 4614 Unary_Op_Validity_Checks (N); 4615 4616 -- For boolean operand, deal with non-standard booleans 4617 4618 if Is_Boolean_Type (Typ) then 4619 Adjust_Condition (Right_Opnd (N)); 4620 Set_Etype (N, Standard_Boolean); 4621 Adjust_Result_Type (N, Typ); 4622 return; 4623 end if; 4624 4625 -- Only array types need any other processing 4626 4627 if not Is_Array_Type (Typ) then 4628 return; 4629 end if; 4630 4631 -- Case of array operand. If bit packed, handle it in Exp_Pakd 4632 4633 if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then 4634 Expand_Packed_Not (N); 4635 return; 4636 end if; 4637 4638 -- Case of array operand which is not bit-packed. If the context is 4639 -- a safe assignment, call in-place operation, If context is a larger 4640 -- boolean expression in the context of a safe assignment, expansion is 4641 -- done by enclosing operation. 4642 4643 Opnd := Relocate_Node (Right_Opnd (N)); 4644 Convert_To_Actual_Subtype (Opnd); 4645 Arr := Etype (Opnd); 4646 Ensure_Defined (Arr, N); 4647 4648 if Nkind (Parent (N)) = N_Assignment_Statement then 4649 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then 4650 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 4651 return; 4652 4653 -- Special case the negation of a binary operation. 4654 4655 elsif (Nkind (Opnd) = N_Op_And 4656 or else Nkind (Opnd) = N_Op_Or 4657 or else Nkind (Opnd) = N_Op_Xor) 4658 and then Safe_In_Place_Array_Op 4659 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) 4660 then 4661 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 4662 return; 4663 end if; 4664 4665 elsif Nkind (Parent (N)) in N_Binary_Op 4666 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 4667 then 4668 declare 4669 Op1 : constant Node_Id := Left_Opnd (Parent (N)); 4670 Op2 : constant Node_Id := Right_Opnd (Parent (N)); 4671 Lhs : constant Node_Id := Name (Parent (Parent (N))); 4672 4673 begin 4674 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then 4675 if N = Op1 4676 and then Nkind (Op2) = N_Op_Not 4677 then 4678 -- (not A) op (not B) can be reduced to a single call. 4679 4680 return; 4681 4682 elsif N = Op2 4683 and then Nkind (Parent (N)) = N_Op_Xor 4684 then 4685 -- A xor (not B) can also be special-cased. 4686 4687 return; 4688 end if; 4689 end if; 4690 end; 4691 end if; 4692 4693 A := Make_Defining_Identifier (Loc, Name_uA); 4694 B := Make_Defining_Identifier (Loc, Name_uB); 4695 J := Make_Defining_Identifier (Loc, Name_uJ); 4696 4697 A_J := 4698 Make_Indexed_Component (Loc, 4699 Prefix => New_Reference_To (A, Loc), 4700 Expressions => New_List (New_Reference_To (J, Loc))); 4701 4702 B_J := 4703 Make_Indexed_Component (Loc, 4704 Prefix => New_Reference_To (B, Loc), 4705 Expressions => New_List (New_Reference_To (J, Loc))); 4706 4707 Loop_Statement := 4708 Make_Implicit_Loop_Statement (N, 4709 Identifier => Empty, 4710 4711 Iteration_Scheme => 4712 Make_Iteration_Scheme (Loc, 4713 Loop_Parameter_Specification => 4714 Make_Loop_Parameter_Specification (Loc, 4715 Defining_Identifier => J, 4716 Discrete_Subtype_Definition => 4717 Make_Attribute_Reference (Loc, 4718 Prefix => Make_Identifier (Loc, Chars (A)), 4719 Attribute_Name => Name_Range))), 4720 4721 Statements => New_List ( 4722 Make_Assignment_Statement (Loc, 4723 Name => B_J, 4724 Expression => Make_Op_Not (Loc, A_J)))); 4725 4726 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); 4727 Set_Is_Inlined (Func_Name); 4728 4729 Insert_Action (N, 4730 Make_Subprogram_Body (Loc, 4731 Specification => 4732 Make_Function_Specification (Loc, 4733 Defining_Unit_Name => Func_Name, 4734 Parameter_Specifications => New_List ( 4735 Make_Parameter_Specification (Loc, 4736 Defining_Identifier => A, 4737 Parameter_Type => New_Reference_To (Typ, Loc))), 4738 Subtype_Mark => New_Reference_To (Typ, Loc)), 4739 4740 Declarations => New_List ( 4741 Make_Object_Declaration (Loc, 4742 Defining_Identifier => B, 4743 Object_Definition => New_Reference_To (Arr, Loc))), 4744 4745 Handled_Statement_Sequence => 4746 Make_Handled_Sequence_Of_Statements (Loc, 4747 Statements => New_List ( 4748 Loop_Statement, 4749 Make_Return_Statement (Loc, 4750 Expression => 4751 Make_Identifier (Loc, Chars (B))))))); 4752 4753 Rewrite (N, 4754 Make_Function_Call (Loc, 4755 Name => New_Reference_To (Func_Name, Loc), 4756 Parameter_Associations => New_List (Opnd))); 4757 4758 Analyze_And_Resolve (N, Typ); 4759 end Expand_N_Op_Not; 4760 4761 -------------------- 4762 -- Expand_N_Op_Or -- 4763 -------------------- 4764 4765 procedure Expand_N_Op_Or (N : Node_Id) is 4766 Typ : constant Entity_Id := Etype (N); 4767 4768 begin 4769 Binary_Op_Validity_Checks (N); 4770 4771 if Is_Array_Type (Etype (N)) then 4772 Expand_Boolean_Operator (N); 4773 4774 elsif Is_Boolean_Type (Etype (N)) then 4775 Adjust_Condition (Left_Opnd (N)); 4776 Adjust_Condition (Right_Opnd (N)); 4777 Set_Etype (N, Standard_Boolean); 4778 Adjust_Result_Type (N, Typ); 4779 end if; 4780 end Expand_N_Op_Or; 4781 4782 ---------------------- 4783 -- Expand_N_Op_Plus -- 4784 ---------------------- 4785 4786 procedure Expand_N_Op_Plus (N : Node_Id) is 4787 begin 4788 Unary_Op_Validity_Checks (N); 4789 end Expand_N_Op_Plus; 4790 4791 --------------------- 4792 -- Expand_N_Op_Rem -- 4793 --------------------- 4794 4795 procedure Expand_N_Op_Rem (N : Node_Id) is 4796 Loc : constant Source_Ptr := Sloc (N); 4797 Typ : constant Entity_Id := Etype (N); 4798 4799 Left : constant Node_Id := Left_Opnd (N); 4800 Right : constant Node_Id := Right_Opnd (N); 4801 4802 LLB : Uint; 4803 Llo : Uint; 4804 Lhi : Uint; 4805 LOK : Boolean; 4806 Rlo : Uint; 4807 Rhi : Uint; 4808 ROK : Boolean; 4809 4810 begin 4811 Binary_Op_Validity_Checks (N); 4812 4813 if Is_Integer_Type (Etype (N)) then 4814 Apply_Divide_Check (N); 4815 end if; 4816 4817 -- Apply optimization x rem 1 = 0. We don't really need that with 4818 -- gcc, but it is useful with other back ends (e.g. AAMP), and is 4819 -- certainly harmless. 4820 4821 if Is_Integer_Type (Etype (N)) 4822 and then Compile_Time_Known_Value (Right) 4823 and then Expr_Value (Right) = Uint_1 4824 then 4825 Rewrite (N, Make_Integer_Literal (Loc, 0)); 4826 Analyze_And_Resolve (N, Typ); 4827 return; 4828 end if; 4829 4830 -- Deal with annoying case of largest negative number remainder 4831 -- minus one. Gigi does not handle this case correctly, because 4832 -- it generates a divide instruction which may trap in this case. 4833 4834 -- In fact the check is quite easy, if the right operand is -1, 4835 -- then the remainder is always 0, and we can just ignore the 4836 -- left operand completely in this case. 4837 4838 Determine_Range (Right, ROK, Rlo, Rhi); 4839 Determine_Range (Left, LOK, Llo, Lhi); 4840 4841 -- The operand type may be private (e.g. in the expansion of an 4842 -- an intrinsic operation) so we must use the underlying type to 4843 -- get the bounds, and convert the literals explicitly. 4844 4845 LLB := 4846 Expr_Value 4847 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); 4848 4849 -- Now perform the test, generating code only if needed 4850 4851 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 4852 and then 4853 ((not LOK) or else (Llo = LLB)) 4854 then 4855 Rewrite (N, 4856 Make_Conditional_Expression (Loc, 4857 Expressions => New_List ( 4858 Make_Op_Eq (Loc, 4859 Left_Opnd => Duplicate_Subexpr (Right), 4860 Right_Opnd => 4861 Unchecked_Convert_To (Typ, 4862 Make_Integer_Literal (Loc, -1))), 4863 4864 Unchecked_Convert_To (Typ, 4865 Make_Integer_Literal (Loc, Uint_0)), 4866 4867 Relocate_Node (N)))); 4868 4869 Set_Analyzed (Next (Next (First (Expressions (N))))); 4870 Analyze_And_Resolve (N, Typ); 4871 end if; 4872 end Expand_N_Op_Rem; 4873 4874 ----------------------------- 4875 -- Expand_N_Op_Rotate_Left -- 4876 ----------------------------- 4877 4878 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is 4879 begin 4880 Binary_Op_Validity_Checks (N); 4881 end Expand_N_Op_Rotate_Left; 4882 4883 ------------------------------ 4884 -- Expand_N_Op_Rotate_Right -- 4885 ------------------------------ 4886 4887 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is 4888 begin 4889 Binary_Op_Validity_Checks (N); 4890 end Expand_N_Op_Rotate_Right; 4891 4892 ---------------------------- 4893 -- Expand_N_Op_Shift_Left -- 4894 ---------------------------- 4895 4896 procedure Expand_N_Op_Shift_Left (N : Node_Id) is 4897 begin 4898 Binary_Op_Validity_Checks (N); 4899 end Expand_N_Op_Shift_Left; 4900 4901 ----------------------------- 4902 -- Expand_N_Op_Shift_Right -- 4903 ----------------------------- 4904 4905 procedure Expand_N_Op_Shift_Right (N : Node_Id) is 4906 begin 4907 Binary_Op_Validity_Checks (N); 4908 end Expand_N_Op_Shift_Right; 4909 4910 ---------------------------------------- 4911 -- Expand_N_Op_Shift_Right_Arithmetic -- 4912 ---------------------------------------- 4913 4914 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is 4915 begin 4916 Binary_Op_Validity_Checks (N); 4917 end Expand_N_Op_Shift_Right_Arithmetic; 4918 4919 -------------------------- 4920 -- Expand_N_Op_Subtract -- 4921 -------------------------- 4922 4923 procedure Expand_N_Op_Subtract (N : Node_Id) is 4924 Typ : constant Entity_Id := Etype (N); 4925 4926 begin 4927 Binary_Op_Validity_Checks (N); 4928 4929 -- N - 0 = N for integer types 4930 4931 if Is_Integer_Type (Typ) 4932 and then Compile_Time_Known_Value (Right_Opnd (N)) 4933 and then Expr_Value (Right_Opnd (N)) = 0 4934 then 4935 Rewrite (N, Left_Opnd (N)); 4936 return; 4937 end if; 4938 4939 -- Arithemtic overflow checks for signed integer/fixed point types 4940 4941 if Is_Signed_Integer_Type (Typ) 4942 or else Is_Fixed_Point_Type (Typ) 4943 then 4944 Apply_Arithmetic_Overflow_Check (N); 4945 4946 -- Vax floating-point types case 4947 4948 elsif Vax_Float (Typ) then 4949 Expand_Vax_Arith (N); 4950 end if; 4951 end Expand_N_Op_Subtract; 4952 4953 --------------------- 4954 -- Expand_N_Op_Xor -- 4955 --------------------- 4956 4957 procedure Expand_N_Op_Xor (N : Node_Id) is 4958 Typ : constant Entity_Id := Etype (N); 4959 4960 begin 4961 Binary_Op_Validity_Checks (N); 4962 4963 if Is_Array_Type (Etype (N)) then 4964 Expand_Boolean_Operator (N); 4965 4966 elsif Is_Boolean_Type (Etype (N)) then 4967 Adjust_Condition (Left_Opnd (N)); 4968 Adjust_Condition (Right_Opnd (N)); 4969 Set_Etype (N, Standard_Boolean); 4970 Adjust_Result_Type (N, Typ); 4971 end if; 4972 end Expand_N_Op_Xor; 4973 4974 ---------------------- 4975 -- Expand_N_Or_Else -- 4976 ---------------------- 4977 4978 -- Expand into conditional expression if Actions present, and also 4979 -- deal with optimizing case of arguments being True or False. 4980 4981 procedure Expand_N_Or_Else (N : Node_Id) is 4982 Loc : constant Source_Ptr := Sloc (N); 4983 Typ : constant Entity_Id := Etype (N); 4984 Left : constant Node_Id := Left_Opnd (N); 4985 Right : constant Node_Id := Right_Opnd (N); 4986 Actlist : List_Id; 4987 4988 begin 4989 -- Deal with non-standard booleans 4990 4991 if Is_Boolean_Type (Typ) then 4992 Adjust_Condition (Left); 4993 Adjust_Condition (Right); 4994 Set_Etype (N, Standard_Boolean); 4995 end if; 4996 4997 -- Check for cases of left argument is True or False 4998 4999 if Nkind (Left) = N_Identifier then 5000 5001 -- If left argument is False, change (False or else Right) to Right. 5002 -- Any actions associated with Right will be executed unconditionally 5003 -- and can thus be inserted into the tree unconditionally. 5004 5005 if Entity (Left) = Standard_False then 5006 if Present (Actions (N)) then 5007 Insert_Actions (N, Actions (N)); 5008 end if; 5009 5010 Rewrite (N, Right); 5011 Adjust_Result_Type (N, Typ); 5012 return; 5013 5014 -- If left argument is True, change (True and then Right) to 5015 -- True. In this case we can forget the actions associated with 5016 -- Right, since they will never be executed. 5017 5018 elsif Entity (Left) = Standard_True then 5019 Kill_Dead_Code (Right); 5020 Kill_Dead_Code (Actions (N)); 5021 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 5022 Adjust_Result_Type (N, Typ); 5023 return; 5024 end if; 5025 end if; 5026 5027 -- If Actions are present, we expand 5028 5029 -- left or else right 5030 5031 -- into 5032 5033 -- if left then True else right end 5034 5035 -- with the actions becoming the Else_Actions of the conditional 5036 -- expression. This conditional expression is then further expanded 5037 -- (and will eventually disappear) 5038 5039 if Present (Actions (N)) then 5040 Actlist := Actions (N); 5041 Rewrite (N, 5042 Make_Conditional_Expression (Loc, 5043 Expressions => New_List ( 5044 Left, 5045 New_Occurrence_Of (Standard_True, Loc), 5046 Right))); 5047 5048 Set_Else_Actions (N, Actlist); 5049 Analyze_And_Resolve (N, Standard_Boolean); 5050 Adjust_Result_Type (N, Typ); 5051 return; 5052 end if; 5053 5054 -- No actions present, check for cases of right argument True/False 5055 5056 if Nkind (Right) = N_Identifier then 5057 5058 -- Change (Left or else False) to Left. Note that we know there 5059 -- are no actions associated with the True operand, since we 5060 -- just checked for this case above. 5061 5062 if Entity (Right) = Standard_False then 5063 Rewrite (N, Left); 5064 5065 -- Change (Left or else True) to True, making sure to preserve 5066 -- any side effects associated with the Left operand. 5067 5068 elsif Entity (Right) = Standard_True then 5069 Remove_Side_Effects (Left); 5070 Rewrite 5071 (N, New_Occurrence_Of (Standard_True, Loc)); 5072 end if; 5073 end if; 5074 5075 Adjust_Result_Type (N, Typ); 5076 end Expand_N_Or_Else; 5077 5078 ----------------------------------- 5079 -- Expand_N_Qualified_Expression -- 5080 ----------------------------------- 5081 5082 procedure Expand_N_Qualified_Expression (N : Node_Id) is 5083 Operand : constant Node_Id := Expression (N); 5084 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 5085 5086 begin 5087 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); 5088 end Expand_N_Qualified_Expression; 5089 5090 --------------------------------- 5091 -- Expand_N_Selected_Component -- 5092 --------------------------------- 5093 5094 -- If the selector is a discriminant of a concurrent object, rewrite the 5095 -- prefix to denote the corresponding record type. 5096 5097 procedure Expand_N_Selected_Component (N : Node_Id) is 5098 Loc : constant Source_Ptr := Sloc (N); 5099 Par : constant Node_Id := Parent (N); 5100 P : constant Node_Id := Prefix (N); 5101 Ptyp : Entity_Id := Underlying_Type (Etype (P)); 5102 Disc : Entity_Id; 5103 New_N : Node_Id; 5104 Dcon : Elmt_Id; 5105 5106 function In_Left_Hand_Side (Comp : Node_Id) return Boolean; 5107 -- Gigi needs a temporary for prefixes that depend on a discriminant, 5108 -- unless the context of an assignment can provide size information. 5109 -- Don't we have a general routine that does this??? 5110 5111 ----------------------- 5112 -- In_Left_Hand_Side -- 5113 ----------------------- 5114 5115 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is 5116 begin 5117 return (Nkind (Parent (Comp)) = N_Assignment_Statement 5118 and then Comp = Name (Parent (Comp))) 5119 or else (Present (Parent (Comp)) 5120 and then Nkind (Parent (Comp)) in N_Subexpr 5121 and then In_Left_Hand_Side (Parent (Comp))); 5122 end In_Left_Hand_Side; 5123 5124 -- Start of processing for Expand_N_Selected_Component 5125 5126 begin 5127 -- Insert explicit dereference if required 5128 5129 if Is_Access_Type (Ptyp) then 5130 Insert_Explicit_Dereference (P); 5131 5132 if Ekind (Etype (P)) = E_Private_Subtype 5133 and then Is_For_Access_Subtype (Etype (P)) 5134 then 5135 Set_Etype (P, Base_Type (Etype (P))); 5136 end if; 5137 5138 Ptyp := Etype (P); 5139 end if; 5140 5141 -- Deal with discriminant check required 5142 5143 if Do_Discriminant_Check (N) then 5144 5145 -- Present the discrminant checking function to the backend, 5146 -- so that it can inline the call to the function. 5147 5148 Add_Inlined_Body 5149 (Discriminant_Checking_Func 5150 (Original_Record_Component (Entity (Selector_Name (N))))); 5151 5152 -- Now reset the flag and generate the call 5153 5154 Set_Do_Discriminant_Check (N, False); 5155 Generate_Discriminant_Check (N); 5156 end if; 5157 5158 -- Gigi cannot handle unchecked conversions that are the prefix of a 5159 -- selected component with discriminants. This must be checked during 5160 -- expansion, because during analysis the type of the selector is not 5161 -- known at the point the prefix is analyzed. If the conversion is the 5162 -- target of an assignment, then we cannot force the evaluation. 5163 5164 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion 5165 and then Has_Discriminants (Etype (N)) 5166 and then not In_Left_Hand_Side (N) 5167 then 5168 Force_Evaluation (Prefix (N)); 5169 end if; 5170 5171 -- Remaining processing applies only if selector is a discriminant 5172 5173 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then 5174 5175 -- If the selector is a discriminant of a constrained record type, 5176 -- we may be able to rewrite the expression with the actual value 5177 -- of the discriminant, a useful optimization in some cases. 5178 5179 if Is_Record_Type (Ptyp) 5180 and then Has_Discriminants (Ptyp) 5181 and then Is_Constrained (Ptyp) 5182 then 5183 -- Do this optimization for discrete types only, and not for 5184 -- access types (access discriminants get us into trouble!) 5185 5186 if not Is_Discrete_Type (Etype (N)) then 5187 null; 5188 5189 -- Don't do this on the left hand of an assignment statement. 5190 -- Normally one would think that references like this would 5191 -- not occur, but they do in generated code, and mean that 5192 -- we really do want to assign the discriminant! 5193 5194 elsif Nkind (Par) = N_Assignment_Statement 5195 and then Name (Par) = N 5196 then 5197 null; 5198 5199 -- Don't do this optimization for the prefix of an attribute 5200 -- or the operand of an object renaming declaration since these 5201 -- are contexts where we do not want the value anyway. 5202 5203 elsif (Nkind (Par) = N_Attribute_Reference 5204 and then Prefix (Par) = N) 5205 or else Is_Renamed_Object (N) 5206 then 5207 null; 5208 5209 -- Don't do this optimization if we are within the code for a 5210 -- discriminant check, since the whole point of such a check may 5211 -- be to verify the condition on which the code below depends! 5212 5213 elsif Is_In_Discriminant_Check (N) then 5214 null; 5215 5216 -- Green light to see if we can do the optimization. There is 5217 -- still one condition that inhibits the optimization below 5218 -- but now is the time to check the particular discriminant. 5219 5220 else 5221 -- Loop through discriminants to find the matching 5222 -- discriminant constraint to see if we can copy it. 5223 5224 Disc := First_Discriminant (Ptyp); 5225 Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); 5226 Discr_Loop : while Present (Dcon) loop 5227 5228 -- Check if this is the matching discriminant 5229 5230 if Disc = Entity (Selector_Name (N)) then 5231 5232 -- Here we have the matching discriminant. Check for 5233 -- the case of a discriminant of a component that is 5234 -- constrained by an outer discriminant, which cannot 5235 -- be optimized away. 5236 5237 if 5238 Denotes_Discriminant 5239 (Node (Dcon), Check_Protected => True) 5240 then 5241 exit Discr_Loop; 5242 5243 -- In the context of a case statement, the expression 5244 -- may have the base type of the discriminant, and we 5245 -- need to preserve the constraint to avoid spurious 5246 -- errors on missing cases. 5247 5248 elsif Nkind (Parent (N)) = N_Case_Statement 5249 and then Etype (Node (Dcon)) /= Etype (Disc) 5250 then 5251 -- RBKD is suspicious of the following code. The 5252 -- call to New_Copy instead of New_Copy_Tree is 5253 -- suspicious, and the call to Analyze instead 5254 -- of Analyze_And_Resolve is also suspicious ??? 5255 5256 -- Wouldn't it be good enough to do a perfectly 5257 -- normal Analyze_And_Resolve call using the 5258 -- subtype of the discriminant here??? 5259 5260 Rewrite (N, 5261 Make_Qualified_Expression (Loc, 5262 Subtype_Mark => 5263 New_Occurrence_Of (Etype (Disc), Loc), 5264 Expression => 5265 New_Copy (Node (Dcon)))); 5266 Analyze (N); 5267 5268 -- In case that comes out as a static expression, 5269 -- reset it (a selected component is never static). 5270 5271 Set_Is_Static_Expression (N, False); 5272 return; 5273 5274 -- Otherwise we can just copy the constraint, but the 5275 -- result is certainly not static! 5276 5277 -- Again the New_Copy here and the failure to even 5278 -- to an analyze call is uneasy ??? 5279 5280 else 5281 Rewrite (N, New_Copy (Node (Dcon))); 5282 Set_Is_Static_Expression (N, False); 5283 return; 5284 end if; 5285 end if; 5286 5287 Next_Elmt (Dcon); 5288 Next_Discriminant (Disc); 5289 end loop Discr_Loop; 5290 5291 -- Note: the above loop should always find a matching 5292 -- discriminant, but if it does not, we just missed an 5293 -- optimization due to some glitch (perhaps a previous 5294 -- error), so ignore. 5295 5296 end if; 5297 end if; 5298 5299 -- The only remaining processing is in the case of a discriminant of 5300 -- a concurrent object, where we rewrite the prefix to denote the 5301 -- corresponding record type. If the type is derived and has renamed 5302 -- discriminants, use corresponding discriminant, which is the one 5303 -- that appears in the corresponding record. 5304 5305 if not Is_Concurrent_Type (Ptyp) then 5306 return; 5307 end if; 5308 5309 Disc := Entity (Selector_Name (N)); 5310 5311 if Is_Derived_Type (Ptyp) 5312 and then Present (Corresponding_Discriminant (Disc)) 5313 then 5314 Disc := Corresponding_Discriminant (Disc); 5315 end if; 5316 5317 New_N := 5318 Make_Selected_Component (Loc, 5319 Prefix => 5320 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), 5321 New_Copy_Tree (P)), 5322 Selector_Name => Make_Identifier (Loc, Chars (Disc))); 5323 5324 Rewrite (N, New_N); 5325 Analyze (N); 5326 end if; 5327 end Expand_N_Selected_Component; 5328 5329 -------------------- 5330 -- Expand_N_Slice -- 5331 -------------------- 5332 5333 procedure Expand_N_Slice (N : Node_Id) is 5334 Loc : constant Source_Ptr := Sloc (N); 5335 Typ : constant Entity_Id := Etype (N); 5336 Pfx : constant Node_Id := Prefix (N); 5337 Ptp : Entity_Id := Etype (Pfx); 5338 5339 function Is_Procedure_Actual (N : Node_Id) return Boolean; 5340 -- Check whether context is a procedure call, in which case 5341 -- expansion of a bit-packed slice is deferred until the call 5342 -- itself is expanded. 5343 5344 procedure Make_Temporary; 5345 -- Create a named variable for the value of the slice, in 5346 -- cases where the back-end cannot handle it properly, e.g. 5347 -- when packed types or unaligned slices are involved. 5348 5349 ------------------------- 5350 -- Is_Procedure_Actual -- 5351 ------------------------- 5352 5353 function Is_Procedure_Actual (N : Node_Id) return Boolean is 5354 Par : Node_Id := Parent (N); 5355 5356 begin 5357 while Present (Par) 5358 and then Nkind (Par) not in N_Statement_Other_Than_Procedure_Call 5359 loop 5360 if Nkind (Par) = N_Procedure_Call_Statement then 5361 return True; 5362 else 5363 Par := Parent (Par); 5364 end if; 5365 end loop; 5366 5367 return False; 5368 end Is_Procedure_Actual; 5369 5370 -------------------- 5371 -- Make_Temporary -- 5372 -------------------- 5373 5374 procedure Make_Temporary is 5375 Decl : Node_Id; 5376 Ent : constant Entity_Id := 5377 Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 5378 begin 5379 Decl := 5380 Make_Object_Declaration (Loc, 5381 Defining_Identifier => Ent, 5382 Object_Definition => New_Occurrence_Of (Typ, Loc)); 5383 5384 Set_No_Initialization (Decl); 5385 5386 Insert_Actions (N, New_List ( 5387 Decl, 5388 Make_Assignment_Statement (Loc, 5389 Name => New_Occurrence_Of (Ent, Loc), 5390 Expression => Relocate_Node (N)))); 5391 5392 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 5393 Analyze_And_Resolve (N, Typ); 5394 end Make_Temporary; 5395 5396 -- Start of processing for Expand_N_Slice 5397 5398 begin 5399 -- Special handling for access types 5400 5401 if Is_Access_Type (Ptp) then 5402 5403 -- Check for explicit dereference required for checked pool 5404 5405 Insert_Dereference_Action (Pfx); 5406 5407 -- If we have an access to a packed array type, then put in an 5408 -- explicit dereference. We do this in case the slice must be 5409 -- expanded, and we want to make sure we get an access check. 5410 5411 Ptp := Designated_Type (Ptp); 5412 5413 if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then 5414 Rewrite (Pfx, 5415 Make_Explicit_Dereference (Sloc (N), 5416 Prefix => Relocate_Node (Pfx))); 5417 5418 Analyze_And_Resolve (Pfx, Ptp); 5419 end if; 5420 end if; 5421 5422 -- Range checks are potentially also needed for cases involving 5423 -- a slice indexed by a subtype indication, but Do_Range_Check 5424 -- can currently only be set for expressions ??? 5425 5426 if not Index_Checks_Suppressed (Ptp) 5427 and then (not Is_Entity_Name (Pfx) 5428 or else not Index_Checks_Suppressed (Entity (Pfx))) 5429 and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication 5430 then 5431 Enable_Range_Check (Discrete_Range (N)); 5432 end if; 5433 5434 -- The remaining case to be handled is packed slices. We can leave 5435 -- packed slices as they are in the following situations: 5436 5437 -- 1. Right or left side of an assignment (we can handle this 5438 -- situation correctly in the assignment statement expansion). 5439 5440 -- 2. Prefix of indexed component (the slide is optimized away 5441 -- in this case, see the start of Expand_N_Slice. 5442 5443 -- 3. Object renaming declaration, since we want the name of 5444 -- the slice, not the value. 5445 5446 -- 4. Argument to procedure call, since copy-in/copy-out handling 5447 -- may be required, and this is handled in the expansion of 5448 -- call itself. 5449 5450 -- 5. Prefix of an address attribute (this is an error which 5451 -- is caught elsewhere, and the expansion would intefere 5452 -- with generating the error message). 5453 5454 if not Is_Packed (Typ) then 5455 5456 -- Apply transformation for actuals of a function call, 5457 -- where Expand_Actuals is not used. 5458 5459 if Nkind (Parent (N)) = N_Function_Call 5460 and then Is_Possibly_Unaligned_Slice (N) 5461 then 5462 Make_Temporary; 5463 end if; 5464 5465 elsif Nkind (Parent (N)) = N_Assignment_Statement 5466 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement 5467 and then Parent (N) = Name (Parent (Parent (N)))) 5468 then 5469 return; 5470 5471 elsif Nkind (Parent (N)) = N_Indexed_Component 5472 or else Is_Renamed_Object (N) 5473 or else Is_Procedure_Actual (N) 5474 then 5475 return; 5476 5477 elsif Nkind (Parent (N)) = N_Attribute_Reference 5478 and then Attribute_Name (Parent (N)) = Name_Address 5479 then 5480 return; 5481 5482 else 5483 Make_Temporary; 5484 end if; 5485 end Expand_N_Slice; 5486 5487 ------------------------------ 5488 -- Expand_N_Type_Conversion -- 5489 ------------------------------ 5490 5491 procedure Expand_N_Type_Conversion (N : Node_Id) is 5492 Loc : constant Source_Ptr := Sloc (N); 5493 Operand : constant Node_Id := Expression (N); 5494 Target_Type : constant Entity_Id := Etype (N); 5495 Operand_Type : Entity_Id := Etype (Operand); 5496 5497 procedure Handle_Changed_Representation; 5498 -- This is called in the case of record and array type conversions 5499 -- to see if there is a change of representation to be handled. 5500 -- Change of representation is actually handled at the assignment 5501 -- statement level, and what this procedure does is rewrite node N 5502 -- conversion as an assignment to temporary. If there is no change 5503 -- of representation, then the conversion node is unchanged. 5504 5505 procedure Real_Range_Check; 5506 -- Handles generation of range check for real target value 5507 5508 ----------------------------------- 5509 -- Handle_Changed_Representation -- 5510 ----------------------------------- 5511 5512 procedure Handle_Changed_Representation is 5513 Temp : Entity_Id; 5514 Decl : Node_Id; 5515 Odef : Node_Id; 5516 Disc : Node_Id; 5517 N_Ix : Node_Id; 5518 Cons : List_Id; 5519 5520 begin 5521 -- Nothing to do if no change of representation 5522 5523 if Same_Representation (Operand_Type, Target_Type) then 5524 return; 5525 5526 -- The real change of representation work is done by the assignment 5527 -- statement processing. So if this type conversion is appearing as 5528 -- the expression of an assignment statement, nothing needs to be 5529 -- done to the conversion. 5530 5531 elsif Nkind (Parent (N)) = N_Assignment_Statement then 5532 return; 5533 5534 -- Otherwise we need to generate a temporary variable, and do the 5535 -- change of representation assignment into that temporary variable. 5536 -- The conversion is then replaced by a reference to this variable. 5537 5538 else 5539 Cons := No_List; 5540 5541 -- If type is unconstrained we have to add a constraint, 5542 -- copied from the actual value of the left hand side. 5543 5544 if not Is_Constrained (Target_Type) then 5545 if Has_Discriminants (Operand_Type) then 5546 Disc := First_Discriminant (Operand_Type); 5547 5548 if Disc /= First_Stored_Discriminant (Operand_Type) then 5549 Disc := First_Stored_Discriminant (Operand_Type); 5550 end if; 5551 5552 Cons := New_List; 5553 while Present (Disc) loop 5554 Append_To (Cons, 5555 Make_Selected_Component (Loc, 5556 Prefix => Duplicate_Subexpr_Move_Checks (Operand), 5557 Selector_Name => 5558 Make_Identifier (Loc, Chars (Disc)))); 5559 Next_Discriminant (Disc); 5560 end loop; 5561 5562 elsif Is_Array_Type (Operand_Type) then 5563 N_Ix := First_Index (Target_Type); 5564 Cons := New_List; 5565 5566 for J in 1 .. Number_Dimensions (Operand_Type) loop 5567 5568 -- We convert the bounds explicitly. We use an unchecked 5569 -- conversion because bounds checks are done elsewhere. 5570 5571 Append_To (Cons, 5572 Make_Range (Loc, 5573 Low_Bound => 5574 Unchecked_Convert_To (Etype (N_Ix), 5575 Make_Attribute_Reference (Loc, 5576 Prefix => 5577 Duplicate_Subexpr_No_Checks 5578 (Operand, Name_Req => True), 5579 Attribute_Name => Name_First, 5580 Expressions => New_List ( 5581 Make_Integer_Literal (Loc, J)))), 5582 5583 High_Bound => 5584 Unchecked_Convert_To (Etype (N_Ix), 5585 Make_Attribute_Reference (Loc, 5586 Prefix => 5587 Duplicate_Subexpr_No_Checks 5588 (Operand, Name_Req => True), 5589 Attribute_Name => Name_Last, 5590 Expressions => New_List ( 5591 Make_Integer_Literal (Loc, J)))))); 5592 5593 Next_Index (N_Ix); 5594 end loop; 5595 end if; 5596 end if; 5597 5598 Odef := New_Occurrence_Of (Target_Type, Loc); 5599 5600 if Present (Cons) then 5601 Odef := 5602 Make_Subtype_Indication (Loc, 5603 Subtype_Mark => Odef, 5604 Constraint => 5605 Make_Index_Or_Discriminant_Constraint (Loc, 5606 Constraints => Cons)); 5607 end if; 5608 5609 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); 5610 Decl := 5611 Make_Object_Declaration (Loc, 5612 Defining_Identifier => Temp, 5613 Object_Definition => Odef); 5614 5615 Set_No_Initialization (Decl, True); 5616 5617 -- Insert required actions. It is essential to suppress checks 5618 -- since we have suppressed default initialization, which means 5619 -- that the variable we create may have no discriminants. 5620 5621 Insert_Actions (N, 5622 New_List ( 5623 Decl, 5624 Make_Assignment_Statement (Loc, 5625 Name => New_Occurrence_Of (Temp, Loc), 5626 Expression => Relocate_Node (N))), 5627 Suppress => All_Checks); 5628 5629 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 5630 return; 5631 end if; 5632 end Handle_Changed_Representation; 5633 5634 ---------------------- 5635 -- Real_Range_Check -- 5636 ---------------------- 5637 5638 -- Case of conversions to floating-point or fixed-point. If range 5639 -- checks are enabled and the target type has a range constraint, 5640 -- we convert: 5641 5642 -- typ (x) 5643 5644 -- to 5645 5646 -- Tnn : typ'Base := typ'Base (x); 5647 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] 5648 -- Tnn 5649 5650 -- This is necessary when there is a conversion of integer to float 5651 -- or to fixed-point to ensure that the correct checks are made. It 5652 -- is not necessary for float to float where it is enough to simply 5653 -- set the Do_Range_Check flag. 5654 5655 procedure Real_Range_Check is 5656 Btyp : constant Entity_Id := Base_Type (Target_Type); 5657 Lo : constant Node_Id := Type_Low_Bound (Target_Type); 5658 Hi : constant Node_Id := Type_High_Bound (Target_Type); 5659 Xtyp : constant Entity_Id := Etype (Operand); 5660 Conv : Node_Id; 5661 Tnn : Entity_Id; 5662 5663 begin 5664 -- Nothing to do if conversion was rewritten 5665 5666 if Nkind (N) /= N_Type_Conversion then 5667 return; 5668 end if; 5669 5670 -- Nothing to do if range checks suppressed, or target has the 5671 -- same range as the base type (or is the base type). 5672 5673 if Range_Checks_Suppressed (Target_Type) 5674 or else (Lo = Type_Low_Bound (Btyp) 5675 and then 5676 Hi = Type_High_Bound (Btyp)) 5677 then 5678 return; 5679 end if; 5680 5681 -- Nothing to do if expression is an entity on which checks 5682 -- have been suppressed. 5683 5684 if Is_Entity_Name (Operand) 5685 and then Range_Checks_Suppressed (Entity (Operand)) 5686 then 5687 return; 5688 end if; 5689 5690 -- Nothing to do if bounds are all static and we can tell that 5691 -- the expression is within the bounds of the target. Note that 5692 -- if the operand is of an unconstrained floating-point type, 5693 -- then we do not trust it to be in range (might be infinite) 5694 5695 declare 5696 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); 5697 S_Hi : constant Node_Id := Type_High_Bound (Xtyp); 5698 5699 begin 5700 if (not Is_Floating_Point_Type (Xtyp) 5701 or else Is_Constrained (Xtyp)) 5702 and then Compile_Time_Known_Value (S_Lo) 5703 and then Compile_Time_Known_Value (S_Hi) 5704 and then Compile_Time_Known_Value (Hi) 5705 and then Compile_Time_Known_Value (Lo) 5706 then 5707 declare 5708 D_Lov : constant Ureal := Expr_Value_R (Lo); 5709 D_Hiv : constant Ureal := Expr_Value_R (Hi); 5710 S_Lov : Ureal; 5711 S_Hiv : Ureal; 5712 5713 begin 5714 if Is_Real_Type (Xtyp) then 5715 S_Lov := Expr_Value_R (S_Lo); 5716 S_Hiv := Expr_Value_R (S_Hi); 5717 else 5718 S_Lov := UR_From_Uint (Expr_Value (S_Lo)); 5719 S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); 5720 end if; 5721 5722 if D_Hiv > D_Lov 5723 and then S_Lov >= D_Lov 5724 and then S_Hiv <= D_Hiv 5725 then 5726 Set_Do_Range_Check (Operand, False); 5727 return; 5728 end if; 5729 end; 5730 end if; 5731 end; 5732 5733 -- For float to float conversions, we are done 5734 5735 if Is_Floating_Point_Type (Xtyp) 5736 and then 5737 Is_Floating_Point_Type (Btyp) 5738 then 5739 return; 5740 end if; 5741 5742 -- Otherwise rewrite the conversion as described above 5743 5744 Conv := Relocate_Node (N); 5745 Rewrite 5746 (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); 5747 Set_Etype (Conv, Btyp); 5748 5749 -- Enable overflow except in the case of integer to float 5750 -- conversions, where it is never required, since we can 5751 -- never have overflow in this case. 5752 5753 if not Is_Integer_Type (Etype (Operand)) then 5754 Enable_Overflow_Check (Conv); 5755 end if; 5756 5757 Tnn := 5758 Make_Defining_Identifier (Loc, 5759 Chars => New_Internal_Name ('T')); 5760 5761 Insert_Actions (N, New_List ( 5762 Make_Object_Declaration (Loc, 5763 Defining_Identifier => Tnn, 5764 Object_Definition => New_Occurrence_Of (Btyp, Loc), 5765 Expression => Conv), 5766 5767 Make_Raise_Constraint_Error (Loc, 5768 Condition => 5769 Make_Or_Else (Loc, 5770 Left_Opnd => 5771 Make_Op_Lt (Loc, 5772 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 5773 Right_Opnd => 5774 Make_Attribute_Reference (Loc, 5775 Attribute_Name => Name_First, 5776 Prefix => 5777 New_Occurrence_Of (Target_Type, Loc))), 5778 5779 Right_Opnd => 5780 Make_Op_Gt (Loc, 5781 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 5782 Right_Opnd => 5783 Make_Attribute_Reference (Loc, 5784 Attribute_Name => Name_Last, 5785 Prefix => 5786 New_Occurrence_Of (Target_Type, Loc)))), 5787 Reason => CE_Range_Check_Failed))); 5788 5789 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 5790 Analyze_And_Resolve (N, Btyp); 5791 end Real_Range_Check; 5792 5793 -- Start of processing for Expand_N_Type_Conversion 5794 5795 begin 5796 -- Nothing at all to do if conversion is to the identical type 5797 -- so remove the conversion completely, it is useless. 5798 5799 if Operand_Type = Target_Type then 5800 Rewrite (N, Relocate_Node (Operand)); 5801 return; 5802 end if; 5803 5804 -- Deal with Vax floating-point cases 5805 5806 if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then 5807 Expand_Vax_Conversion (N); 5808 return; 5809 end if; 5810 5811 -- Nothing to do if this is the second argument of read. This 5812 -- is a "backwards" conversion that will be handled by the 5813 -- specialized code in attribute processing. 5814 5815 if Nkind (Parent (N)) = N_Attribute_Reference 5816 and then Attribute_Name (Parent (N)) = Name_Read 5817 and then Next (First (Expressions (Parent (N)))) = N 5818 then 5819 return; 5820 end if; 5821 5822 -- Here if we may need to expand conversion 5823 5824 -- Special case of converting from non-standard boolean type 5825 5826 if Is_Boolean_Type (Operand_Type) 5827 and then (Nonzero_Is_True (Operand_Type)) 5828 then 5829 Adjust_Condition (Operand); 5830 Set_Etype (Operand, Standard_Boolean); 5831 Operand_Type := Standard_Boolean; 5832 end if; 5833 5834 -- Case of converting to an access type 5835 5836 if Is_Access_Type (Target_Type) then 5837 5838 -- Apply an accessibility check if the operand is an 5839 -- access parameter. Note that other checks may still 5840 -- need to be applied below (such as tagged type checks). 5841 5842 if Is_Entity_Name (Operand) 5843 and then Ekind (Entity (Operand)) in Formal_Kind 5844 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type 5845 then 5846 Apply_Accessibility_Check (Operand, Target_Type); 5847 5848 -- If the level of the operand type is statically deeper 5849 -- then the level of the target type, then force Program_Error. 5850 -- Note that this can only occur for cases where the attribute 5851 -- is within the body of an instantiation (otherwise the 5852 -- conversion will already have been rejected as illegal). 5853 -- Note: warnings are issued by the analyzer for the instance 5854 -- cases. 5855 5856 elsif In_Instance_Body 5857 and then Type_Access_Level (Operand_Type) > 5858 Type_Access_Level (Target_Type) 5859 then 5860 Rewrite (N, 5861 Make_Raise_Program_Error (Sloc (N), 5862 Reason => PE_Accessibility_Check_Failed)); 5863 Set_Etype (N, Target_Type); 5864 5865 -- When the operand is a selected access discriminant 5866 -- the check needs to be made against the level of the 5867 -- object denoted by the prefix of the selected name. 5868 -- Force Program_Error for this case as well (this 5869 -- accessibility violation can only happen if within 5870 -- the body of an instantiation). 5871 5872 elsif In_Instance_Body 5873 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 5874 and then Nkind (Operand) = N_Selected_Component 5875 and then Object_Access_Level (Operand) > 5876 Type_Access_Level (Target_Type) 5877 then 5878 Rewrite (N, 5879 Make_Raise_Program_Error (Sloc (N), 5880 Reason => PE_Accessibility_Check_Failed)); 5881 Set_Etype (N, Target_Type); 5882 end if; 5883 end if; 5884 5885 -- Case of conversions of tagged types and access to tagged types 5886 5887 -- When needed, that is to say when the expression is class-wide, 5888 -- Add runtime a tag check for (strict) downward conversion by using 5889 -- the membership test, generating: 5890 5891 -- [constraint_error when Operand not in Target_Type'Class] 5892 5893 -- or in the access type case 5894 5895 -- [constraint_error 5896 -- when Operand /= null 5897 -- and then Operand.all not in 5898 -- Designated_Type (Target_Type)'Class] 5899 5900 if (Is_Access_Type (Target_Type) 5901 and then Is_Tagged_Type (Designated_Type (Target_Type))) 5902 or else Is_Tagged_Type (Target_Type) 5903 then 5904 -- Do not do any expansion in the access type case if the 5905 -- parent is a renaming, since this is an error situation 5906 -- which will be caught by Sem_Ch8, and the expansion can 5907 -- intefere with this error check. 5908 5909 if Is_Access_Type (Target_Type) 5910 and then Is_Renamed_Object (N) 5911 then 5912 return; 5913 end if; 5914 5915 -- Oherwise, proceed with processing tagged conversion 5916 5917 declare 5918 Actual_Operand_Type : Entity_Id; 5919 Actual_Target_Type : Entity_Id; 5920 5921 Cond : Node_Id; 5922 5923 begin 5924 if Is_Access_Type (Target_Type) then 5925 Actual_Operand_Type := Designated_Type (Operand_Type); 5926 Actual_Target_Type := Designated_Type (Target_Type); 5927 5928 else 5929 Actual_Operand_Type := Operand_Type; 5930 Actual_Target_Type := Target_Type; 5931 end if; 5932 5933 if Is_Class_Wide_Type (Actual_Operand_Type) 5934 and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type 5935 and then Is_Ancestor 5936 (Root_Type (Actual_Operand_Type), 5937 Actual_Target_Type) 5938 and then not Tag_Checks_Suppressed (Actual_Target_Type) 5939 then 5940 -- The conversion is valid for any descendant of the 5941 -- target type 5942 5943 Actual_Target_Type := Class_Wide_Type (Actual_Target_Type); 5944 5945 if Is_Access_Type (Target_Type) then 5946 Cond := 5947 Make_And_Then (Loc, 5948 Left_Opnd => 5949 Make_Op_Ne (Loc, 5950 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 5951 Right_Opnd => Make_Null (Loc)), 5952 5953 Right_Opnd => 5954 Make_Not_In (Loc, 5955 Left_Opnd => 5956 Make_Explicit_Dereference (Loc, 5957 Prefix => 5958 Duplicate_Subexpr_No_Checks (Operand)), 5959 Right_Opnd => 5960 New_Reference_To (Actual_Target_Type, Loc))); 5961 5962 else 5963 Cond := 5964 Make_Not_In (Loc, 5965 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 5966 Right_Opnd => 5967 New_Reference_To (Actual_Target_Type, Loc)); 5968 end if; 5969 5970 Insert_Action (N, 5971 Make_Raise_Constraint_Error (Loc, 5972 Condition => Cond, 5973 Reason => CE_Tag_Check_Failed)); 5974 5975 Change_Conversion_To_Unchecked (N); 5976 Analyze_And_Resolve (N, Target_Type); 5977 end if; 5978 end; 5979 5980 -- Case of other access type conversions 5981 5982 elsif Is_Access_Type (Target_Type) then 5983 Apply_Constraint_Check (Operand, Target_Type); 5984 5985 -- Case of conversions from a fixed-point type 5986 5987 -- These conversions require special expansion and processing, found 5988 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is 5989 -- set, since from a semantic point of view, these are simple integer 5990 -- conversions, which do not need further processing. 5991 5992 elsif Is_Fixed_Point_Type (Operand_Type) 5993 and then not Conversion_OK (N) 5994 then 5995 -- We should never see universal fixed at this case, since the 5996 -- expansion of the constituent divide or multiply should have 5997 -- eliminated the explicit mention of universal fixed. 5998 5999 pragma Assert (Operand_Type /= Universal_Fixed); 6000 6001 -- Check for special case of the conversion to universal real 6002 -- that occurs as a result of the use of a round attribute. 6003 -- In this case, the real type for the conversion is taken 6004 -- from the target type of the Round attribute and the 6005 -- result must be marked as rounded. 6006 6007 if Target_Type = Universal_Real 6008 and then Nkind (Parent (N)) = N_Attribute_Reference 6009 and then Attribute_Name (Parent (N)) = Name_Round 6010 then 6011 Set_Rounded_Result (N); 6012 Set_Etype (N, Etype (Parent (N))); 6013 end if; 6014 6015 -- Otherwise do correct fixed-conversion, but skip these if the 6016 -- Conversion_OK flag is set, because from a semantic point of 6017 -- view these are simple integer conversions needing no further 6018 -- processing (the backend will simply treat them as integers) 6019 6020 if not Conversion_OK (N) then 6021 if Is_Fixed_Point_Type (Etype (N)) then 6022 Expand_Convert_Fixed_To_Fixed (N); 6023 Real_Range_Check; 6024 6025 elsif Is_Integer_Type (Etype (N)) then 6026 Expand_Convert_Fixed_To_Integer (N); 6027 6028 else 6029 pragma Assert (Is_Floating_Point_Type (Etype (N))); 6030 Expand_Convert_Fixed_To_Float (N); 6031 Real_Range_Check; 6032 end if; 6033 end if; 6034 6035 -- Case of conversions to a fixed-point type 6036 6037 -- These conversions require special expansion and processing, found 6038 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK 6039 -- is set, since from a semantic point of view, these are simple 6040 -- integer conversions, which do not need further processing. 6041 6042 elsif Is_Fixed_Point_Type (Target_Type) 6043 and then not Conversion_OK (N) 6044 then 6045 if Is_Integer_Type (Operand_Type) then 6046 Expand_Convert_Integer_To_Fixed (N); 6047 Real_Range_Check; 6048 else 6049 pragma Assert (Is_Floating_Point_Type (Operand_Type)); 6050 Expand_Convert_Float_To_Fixed (N); 6051 Real_Range_Check; 6052 end if; 6053 6054 -- Case of float-to-integer conversions 6055 6056 -- We also handle float-to-fixed conversions with Conversion_OK set 6057 -- since semantically the fixed-point target is treated as though it 6058 -- were an integer in such cases. 6059 6060 elsif Is_Floating_Point_Type (Operand_Type) 6061 and then 6062 (Is_Integer_Type (Target_Type) 6063 or else 6064 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N))) 6065 then 6066 -- Special processing required if the conversion is the expression 6067 -- of a Truncation attribute reference. In this case we replace: 6068 6069 -- ityp (ftyp'Truncation (x)) 6070 6071 -- by 6072 6073 -- ityp (x) 6074 6075 -- with the Float_Truncate flag set. This is clearly more efficient. 6076 6077 if Nkind (Operand) = N_Attribute_Reference 6078 and then Attribute_Name (Operand) = Name_Truncation 6079 then 6080 Rewrite (Operand, 6081 Relocate_Node (First (Expressions (Operand)))); 6082 Set_Float_Truncate (N, True); 6083 end if; 6084 6085 -- One more check here, gcc is still not able to do conversions of 6086 -- this type with proper overflow checking, and so gigi is doing an 6087 -- approximation of what is required by doing floating-point compares 6088 -- with the end-point. But that can lose precision in some cases, and 6089 -- give a wrong result. Converting the operand to Long_Long_Float is 6090 -- helpful, but still does not catch all cases with 64-bit integers 6091 -- on targets with only 64-bit floats ??? 6092 6093 if Do_Range_Check (Operand) then 6094 Rewrite (Operand, 6095 Make_Type_Conversion (Loc, 6096 Subtype_Mark => 6097 New_Occurrence_Of (Standard_Long_Long_Float, Loc), 6098 Expression => 6099 Relocate_Node (Operand))); 6100 6101 Set_Etype (Operand, Standard_Long_Long_Float); 6102 Enable_Range_Check (Operand); 6103 Set_Do_Range_Check (Expression (Operand), False); 6104 end if; 6105 6106 -- Case of array conversions 6107 6108 -- Expansion of array conversions, add required length/range checks 6109 -- but only do this if there is no change of representation. For 6110 -- handling of this case, see Handle_Changed_Representation. 6111 6112 elsif Is_Array_Type (Target_Type) then 6113 6114 if Is_Constrained (Target_Type) then 6115 Apply_Length_Check (Operand, Target_Type); 6116 else 6117 Apply_Range_Check (Operand, Target_Type); 6118 end if; 6119 6120 Handle_Changed_Representation; 6121 6122 -- Case of conversions of discriminated types 6123 6124 -- Add required discriminant checks if target is constrained. Again 6125 -- this change is skipped if we have a change of representation. 6126 6127 elsif Has_Discriminants (Target_Type) 6128 and then Is_Constrained (Target_Type) 6129 then 6130 Apply_Discriminant_Check (Operand, Target_Type); 6131 Handle_Changed_Representation; 6132 6133 -- Case of all other record conversions. The only processing required 6134 -- is to check for a change of representation requiring the special 6135 -- assignment processing. 6136 6137 elsif Is_Record_Type (Target_Type) then 6138 Handle_Changed_Representation; 6139 6140 -- Case of conversions of enumeration types 6141 6142 elsif Is_Enumeration_Type (Target_Type) then 6143 6144 -- Special processing is required if there is a change of 6145 -- representation (from enumeration representation clauses) 6146 6147 if not Same_Representation (Target_Type, Operand_Type) then 6148 6149 -- Convert: x(y) to x'val (ytyp'val (y)) 6150 6151 Rewrite (N, 6152 Make_Attribute_Reference (Loc, 6153 Prefix => New_Occurrence_Of (Target_Type, Loc), 6154 Attribute_Name => Name_Val, 6155 Expressions => New_List ( 6156 Make_Attribute_Reference (Loc, 6157 Prefix => New_Occurrence_Of (Operand_Type, Loc), 6158 Attribute_Name => Name_Pos, 6159 Expressions => New_List (Operand))))); 6160 6161 Analyze_And_Resolve (N, Target_Type); 6162 end if; 6163 6164 -- Case of conversions to floating-point 6165 6166 elsif Is_Floating_Point_Type (Target_Type) then 6167 Real_Range_Check; 6168 6169 -- The remaining cases require no front end processing 6170 6171 else 6172 null; 6173 end if; 6174 6175 -- At this stage, either the conversion node has been transformed 6176 -- into some other equivalent expression, or left as a conversion 6177 -- that can be handled by Gigi. The conversions that Gigi can handle 6178 -- are the following: 6179 6180 -- Conversions with no change of representation or type 6181 6182 -- Numeric conversions involving integer values, floating-point 6183 -- values, and fixed-point values. Fixed-point values are allowed 6184 -- only if Conversion_OK is set, i.e. if the fixed-point values 6185 -- are to be treated as integers. 6186 6187 -- No other conversions should be passed to Gigi. 6188 6189 -- The only remaining step is to generate a range check if we still 6190 -- have a type conversion at this stage and Do_Range_Check is set. 6191 -- For now we do this only for conversions of discrete types. 6192 6193 if Nkind (N) = N_Type_Conversion 6194 and then Is_Discrete_Type (Etype (N)) 6195 then 6196 declare 6197 Expr : constant Node_Id := Expression (N); 6198 Ftyp : Entity_Id; 6199 Ityp : Entity_Id; 6200 6201 begin 6202 if Do_Range_Check (Expr) 6203 and then Is_Discrete_Type (Etype (Expr)) 6204 then 6205 Set_Do_Range_Check (Expr, False); 6206 6207 -- Before we do a range check, we have to deal with treating 6208 -- a fixed-point operand as an integer. The way we do this 6209 -- is simply to do an unchecked conversion to an appropriate 6210 -- integer type large enough to hold the result. 6211 6212 -- This code is not active yet, because we are only dealing 6213 -- with discrete types so far ??? 6214 6215 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer 6216 and then Treat_Fixed_As_Integer (Expr) 6217 then 6218 Ftyp := Base_Type (Etype (Expr)); 6219 6220 if Esize (Ftyp) >= Esize (Standard_Integer) then 6221 Ityp := Standard_Long_Long_Integer; 6222 else 6223 Ityp := Standard_Integer; 6224 end if; 6225 6226 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); 6227 end if; 6228 6229 -- Reset overflow flag, since the range check will include 6230 -- dealing with possible overflow, and generate the check 6231 6232 Set_Do_Overflow_Check (N, False); 6233 Generate_Range_Check 6234 (Expr, Target_Type, CE_Range_Check_Failed); 6235 end if; 6236 end; 6237 end if; 6238 end Expand_N_Type_Conversion; 6239 6240 ----------------------------------- 6241 -- Expand_N_Unchecked_Expression -- 6242 ----------------------------------- 6243 6244 -- Remove the unchecked expression node from the tree. It's job was simply 6245 -- to make sure that its constituent expression was handled with checks 6246 -- off, and now that that is done, we can remove it from the tree, and 6247 -- indeed must, since gigi does not expect to see these nodes. 6248 6249 procedure Expand_N_Unchecked_Expression (N : Node_Id) is 6250 Exp : constant Node_Id := Expression (N); 6251 6252 begin 6253 Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp)); 6254 Rewrite (N, Exp); 6255 end Expand_N_Unchecked_Expression; 6256 6257 ---------------------------------------- 6258 -- Expand_N_Unchecked_Type_Conversion -- 6259 ---------------------------------------- 6260 6261 -- If this cannot be handled by Gigi and we haven't already made 6262 -- a temporary for it, do it now. 6263 6264 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is 6265 Target_Type : constant Entity_Id := Etype (N); 6266 Operand : constant Node_Id := Expression (N); 6267 Operand_Type : constant Entity_Id := Etype (Operand); 6268 6269 begin 6270 -- If we have a conversion of a compile time known value to a target 6271 -- type and the value is in range of the target type, then we can simply 6272 -- replace the construct by an integer literal of the correct type. We 6273 -- only apply this to integer types being converted. Possibly it may 6274 -- apply in other cases, but it is too much trouble to worry about. 6275 6276 -- Note that we do not do this transformation if the Kill_Range_Check 6277 -- flag is set, since then the value may be outside the expected range. 6278 -- This happens in the Normalize_Scalars case. 6279 6280 if Is_Integer_Type (Target_Type) 6281 and then Is_Integer_Type (Operand_Type) 6282 and then Compile_Time_Known_Value (Operand) 6283 and then not Kill_Range_Check (N) 6284 then 6285 declare 6286 Val : constant Uint := Expr_Value (Operand); 6287 6288 begin 6289 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) 6290 and then 6291 Compile_Time_Known_Value (Type_High_Bound (Target_Type)) 6292 and then 6293 Val >= Expr_Value (Type_Low_Bound (Target_Type)) 6294 and then 6295 Val <= Expr_Value (Type_High_Bound (Target_Type)) 6296 then 6297 Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); 6298 Analyze_And_Resolve (N, Target_Type); 6299 return; 6300 end if; 6301 end; 6302 end if; 6303 6304 -- Nothing to do if conversion is safe 6305 6306 if Safe_Unchecked_Type_Conversion (N) then 6307 return; 6308 end if; 6309 6310 -- Otherwise force evaluation unless Assignment_OK flag is set (this 6311 -- flag indicates ??? -- more comments needed here) 6312 6313 if Assignment_OK (N) then 6314 null; 6315 else 6316 Force_Evaluation (N); 6317 end if; 6318 end Expand_N_Unchecked_Type_Conversion; 6319 6320 ---------------------------- 6321 -- Expand_Record_Equality -- 6322 ---------------------------- 6323 6324 -- For non-variant records, Equality is expanded when needed into: 6325 6326 -- and then Lhs.Discr1 = Rhs.Discr1 6327 -- and then ... 6328 -- and then Lhs.Discrn = Rhs.Discrn 6329 -- and then Lhs.Cmp1 = Rhs.Cmp1 6330 -- and then ... 6331 -- and then Lhs.Cmpn = Rhs.Cmpn 6332 6333 -- The expression is folded by the back-end for adjacent fields. This 6334 -- function is called for tagged record in only one occasion: for imple- 6335 -- menting predefined primitive equality (see Predefined_Primitives_Bodies) 6336 -- otherwise the primitive "=" is used directly. 6337 6338 function Expand_Record_Equality 6339 (Nod : Node_Id; 6340 Typ : Entity_Id; 6341 Lhs : Node_Id; 6342 Rhs : Node_Id; 6343 Bodies : List_Id) 6344 return Node_Id 6345 is 6346 Loc : constant Source_Ptr := Sloc (Nod); 6347 6348 function Suitable_Element (C : Entity_Id) return Entity_Id; 6349 -- Return the first field to compare beginning with C, skipping the 6350 -- inherited components 6351 6352 function Suitable_Element (C : Entity_Id) return Entity_Id is 6353 begin 6354 if No (C) then 6355 return Empty; 6356 6357 elsif Ekind (C) /= E_Discriminant 6358 and then Ekind (C) /= E_Component 6359 then 6360 return Suitable_Element (Next_Entity (C)); 6361 6362 elsif Is_Tagged_Type (Typ) 6363 and then C /= Original_Record_Component (C) 6364 then 6365 return Suitable_Element (Next_Entity (C)); 6366 6367 elsif Chars (C) = Name_uController 6368 or else Chars (C) = Name_uTag 6369 then 6370 return Suitable_Element (Next_Entity (C)); 6371 6372 else 6373 return C; 6374 end if; 6375 end Suitable_Element; 6376 6377 Result : Node_Id; 6378 C : Entity_Id; 6379 6380 First_Time : Boolean := True; 6381 6382 -- Start of processing for Expand_Record_Equality 6383 6384 begin 6385 -- Special processing for the unchecked union case, which will occur 6386 -- only in the context of tagged types and dynamic dispatching, since 6387 -- other cases are handled statically. We return True, but insert a 6388 -- raise Program_Error statement. 6389 6390 if Is_Unchecked_Union (Typ) then 6391 6392 -- If this is a component of an enclosing record, return the Raise 6393 -- statement directly. 6394 6395 if No (Parent (Lhs)) then 6396 Result := 6397 Make_Raise_Program_Error (Loc, 6398 Reason => PE_Unchecked_Union_Restriction); 6399 Set_Etype (Result, Standard_Boolean); 6400 return Result; 6401 6402 else 6403 Insert_Action (Lhs, 6404 Make_Raise_Program_Error (Loc, 6405 Reason => PE_Unchecked_Union_Restriction)); 6406 return New_Occurrence_Of (Standard_True, Loc); 6407 end if; 6408 end if; 6409 6410 -- Generates the following code: (assuming that Typ has one Discr and 6411 -- component C2 is also a record) 6412 6413 -- True 6414 -- and then Lhs.Discr1 = Rhs.Discr1 6415 -- and then Lhs.C1 = Rhs.C1 6416 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn 6417 -- and then ... 6418 -- and then Lhs.Cmpn = Rhs.Cmpn 6419 6420 Result := New_Reference_To (Standard_True, Loc); 6421 C := Suitable_Element (First_Entity (Typ)); 6422 6423 while Present (C) loop 6424 6425 declare 6426 New_Lhs : Node_Id; 6427 New_Rhs : Node_Id; 6428 6429 begin 6430 if First_Time then 6431 First_Time := False; 6432 New_Lhs := Lhs; 6433 New_Rhs := Rhs; 6434 6435 else 6436 New_Lhs := New_Copy_Tree (Lhs); 6437 New_Rhs := New_Copy_Tree (Rhs); 6438 end if; 6439 6440 Result := 6441 Make_And_Then (Loc, 6442 Left_Opnd => Result, 6443 Right_Opnd => 6444 Expand_Composite_Equality (Nod, Etype (C), 6445 Lhs => 6446 Make_Selected_Component (Loc, 6447 Prefix => New_Lhs, 6448 Selector_Name => New_Reference_To (C, Loc)), 6449 Rhs => 6450 Make_Selected_Component (Loc, 6451 Prefix => New_Rhs, 6452 Selector_Name => New_Reference_To (C, Loc)), 6453 Bodies => Bodies)); 6454 end; 6455 6456 C := Suitable_Element (Next_Entity (C)); 6457 end loop; 6458 6459 return Result; 6460 end Expand_Record_Equality; 6461 6462 ------------------------------------- 6463 -- Fixup_Universal_Fixed_Operation -- 6464 ------------------------------------- 6465 6466 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is 6467 Conv : constant Node_Id := Parent (N); 6468 6469 begin 6470 -- We must have a type conversion immediately above us 6471 6472 pragma Assert (Nkind (Conv) = N_Type_Conversion); 6473 6474 -- Normally the type conversion gives our target type. The exception 6475 -- occurs in the case of the Round attribute, where the conversion 6476 -- will be to universal real, and our real type comes from the Round 6477 -- attribute (as well as an indication that we must round the result) 6478 6479 if Nkind (Parent (Conv)) = N_Attribute_Reference 6480 and then Attribute_Name (Parent (Conv)) = Name_Round 6481 then 6482 Set_Etype (N, Etype (Parent (Conv))); 6483 Set_Rounded_Result (N); 6484 6485 -- Normal case where type comes from conversion above us 6486 6487 else 6488 Set_Etype (N, Etype (Conv)); 6489 end if; 6490 end Fixup_Universal_Fixed_Operation; 6491 6492 ------------------------------ 6493 -- Get_Allocator_Final_List -- 6494 ------------------------------ 6495 6496 function Get_Allocator_Final_List 6497 (N : Node_Id; 6498 T : Entity_Id; 6499 PtrT : Entity_Id) 6500 return Entity_Id 6501 is 6502 Loc : constant Source_Ptr := Sloc (N); 6503 Acc : Entity_Id; 6504 6505 begin 6506 -- If the context is an access parameter, we need to create 6507 -- a non-anonymous access type in order to have a usable 6508 -- final list, because there is otherwise no pool to which 6509 -- the allocated object can belong. We create both the type 6510 -- and the finalization chain here, because freezing an 6511 -- internal type does not create such a chain. The Final_Chain 6512 -- that is thus created is shared by the access parameter. 6513 6514 if Ekind (PtrT) = E_Anonymous_Access_Type then 6515 Acc := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); 6516 Insert_Action (N, 6517 Make_Full_Type_Declaration (Loc, 6518 Defining_Identifier => Acc, 6519 Type_Definition => 6520 Make_Access_To_Object_Definition (Loc, 6521 Subtype_Indication => 6522 New_Occurrence_Of (T, Loc)))); 6523 6524 Build_Final_List (N, Acc); 6525 Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc)); 6526 return Find_Final_List (Acc); 6527 6528 else 6529 return Find_Final_List (PtrT); 6530 end if; 6531 end Get_Allocator_Final_List; 6532 6533 ------------------------------- 6534 -- Insert_Dereference_Action -- 6535 ------------------------------- 6536 6537 procedure Insert_Dereference_Action (N : Node_Id) is 6538 Loc : constant Source_Ptr := Sloc (N); 6539 Typ : constant Entity_Id := Etype (N); 6540 Pool : constant Entity_Id := Associated_Storage_Pool (Typ); 6541 6542 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; 6543 -- return true if type of P is derived from Checked_Pool; 6544 6545 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is 6546 T : Entity_Id; 6547 6548 begin 6549 if No (P) then 6550 return False; 6551 end if; 6552 6553 T := Etype (P); 6554 while T /= Etype (T) loop 6555 if Is_RTE (T, RE_Checked_Pool) then 6556 return True; 6557 else 6558 T := Etype (T); 6559 end if; 6560 end loop; 6561 6562 return False; 6563 end Is_Checked_Storage_Pool; 6564 6565 -- Start of processing for Insert_Dereference_Action 6566 6567 begin 6568 if not Comes_From_Source (Parent (N)) then 6569 return; 6570 6571 elsif not Is_Checked_Storage_Pool (Pool) then 6572 return; 6573 end if; 6574 6575 Insert_Action (N, 6576 Make_Procedure_Call_Statement (Loc, 6577 Name => New_Reference_To ( 6578 Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), 6579 6580 Parameter_Associations => New_List ( 6581 6582 -- Pool 6583 6584 New_Reference_To (Pool, Loc), 6585 6586 -- Storage_Address. We use the attribute Pool_Address, 6587 -- which uses the pointer itself to find the address of 6588 -- the object, and which handles unconstrained arrays 6589 -- properly by computing the address of the template. 6590 -- i.e. the correct address of the corresponding allocation. 6591 6592 Make_Attribute_Reference (Loc, 6593 Prefix => Duplicate_Subexpr_Move_Checks (N), 6594 Attribute_Name => Name_Pool_Address), 6595 6596 -- Size_In_Storage_Elements 6597 6598 Make_Op_Divide (Loc, 6599 Left_Opnd => 6600 Make_Attribute_Reference (Loc, 6601 Prefix => 6602 Make_Explicit_Dereference (Loc, 6603 Duplicate_Subexpr_Move_Checks (N)), 6604 Attribute_Name => Name_Size), 6605 Right_Opnd => 6606 Make_Integer_Literal (Loc, System_Storage_Unit)), 6607 6608 -- Alignment 6609 6610 Make_Attribute_Reference (Loc, 6611 Prefix => 6612 Make_Explicit_Dereference (Loc, 6613 Duplicate_Subexpr_Move_Checks (N)), 6614 Attribute_Name => Name_Alignment)))); 6615 6616 exception 6617 when RE_Not_Available => 6618 return; 6619 end Insert_Dereference_Action; 6620 6621 ------------------------------ 6622 -- Make_Array_Comparison_Op -- 6623 ------------------------------ 6624 6625 -- This is a hand-coded expansion of the following generic function: 6626 6627 -- generic 6628 -- type elem is (<>); 6629 -- type index is (<>); 6630 -- type a is array (index range <>) of elem; 6631 -- 6632 -- function Gnnn (X : a; Y: a) return boolean is 6633 -- J : index := Y'first; 6634 -- 6635 -- begin 6636 -- if X'length = 0 then 6637 -- return false; 6638 -- 6639 -- elsif Y'length = 0 then 6640 -- return true; 6641 -- 6642 -- else 6643 -- for I in X'range loop 6644 -- if X (I) = Y (J) then 6645 -- if J = Y'last then 6646 -- exit; 6647 -- else 6648 -- J := index'succ (J); 6649 -- end if; 6650 -- 6651 -- else 6652 -- return X (I) > Y (J); 6653 -- end if; 6654 -- end loop; 6655 -- 6656 -- return X'length > Y'length; 6657 -- end if; 6658 -- end Gnnn; 6659 6660 -- Note that since we are essentially doing this expansion by hand, we 6661 -- do not need to generate an actual or formal generic part, just the 6662 -- instantiated function itself. 6663 6664 function Make_Array_Comparison_Op 6665 (Typ : Entity_Id; 6666 Nod : Node_Id) 6667 return Node_Id 6668 is 6669 Loc : constant Source_Ptr := Sloc (Nod); 6670 6671 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); 6672 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); 6673 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); 6674 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 6675 6676 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); 6677 6678 Loop_Statement : Node_Id; 6679 Loop_Body : Node_Id; 6680 If_Stat : Node_Id; 6681 Inner_If : Node_Id; 6682 Final_Expr : Node_Id; 6683 Func_Body : Node_Id; 6684 Func_Name : Entity_Id; 6685 Formals : List_Id; 6686 Length1 : Node_Id; 6687 Length2 : Node_Id; 6688 6689 begin 6690 -- if J = Y'last then 6691 -- exit; 6692 -- else 6693 -- J := index'succ (J); 6694 -- end if; 6695 6696 Inner_If := 6697 Make_Implicit_If_Statement (Nod, 6698 Condition => 6699 Make_Op_Eq (Loc, 6700 Left_Opnd => New_Reference_To (J, Loc), 6701 Right_Opnd => 6702 Make_Attribute_Reference (Loc, 6703 Prefix => New_Reference_To (Y, Loc), 6704 Attribute_Name => Name_Last)), 6705 6706 Then_Statements => New_List ( 6707 Make_Exit_Statement (Loc)), 6708 6709 Else_Statements => 6710 New_List ( 6711 Make_Assignment_Statement (Loc, 6712 Name => New_Reference_To (J, Loc), 6713 Expression => 6714 Make_Attribute_Reference (Loc, 6715 Prefix => New_Reference_To (Index, Loc), 6716 Attribute_Name => Name_Succ, 6717 Expressions => New_List (New_Reference_To (J, Loc)))))); 6718 6719 -- if X (I) = Y (J) then 6720 -- if ... end if; 6721 -- else 6722 -- return X (I) > Y (J); 6723 -- end if; 6724 6725 Loop_Body := 6726 Make_Implicit_If_Statement (Nod, 6727 Condition => 6728 Make_Op_Eq (Loc, 6729 Left_Opnd => 6730 Make_Indexed_Component (Loc, 6731 Prefix => New_Reference_To (X, Loc), 6732 Expressions => New_List (New_Reference_To (I, Loc))), 6733 6734 Right_Opnd => 6735 Make_Indexed_Component (Loc, 6736 Prefix => New_Reference_To (Y, Loc), 6737 Expressions => New_List (New_Reference_To (J, Loc)))), 6738 6739 Then_Statements => New_List (Inner_If), 6740 6741 Else_Statements => New_List ( 6742 Make_Return_Statement (Loc, 6743 Expression => 6744 Make_Op_Gt (Loc, 6745 Left_Opnd => 6746 Make_Indexed_Component (Loc, 6747 Prefix => New_Reference_To (X, Loc), 6748 Expressions => New_List (New_Reference_To (I, Loc))), 6749 6750 Right_Opnd => 6751 Make_Indexed_Component (Loc, 6752 Prefix => New_Reference_To (Y, Loc), 6753 Expressions => New_List ( 6754 New_Reference_To (J, Loc))))))); 6755 6756 -- for I in X'range loop 6757 -- if ... end if; 6758 -- end loop; 6759 6760 Loop_Statement := 6761 Make_Implicit_Loop_Statement (Nod, 6762 Identifier => Empty, 6763 6764 Iteration_Scheme => 6765 Make_Iteration_Scheme (Loc, 6766 Loop_Parameter_Specification => 6767 Make_Loop_Parameter_Specification (Loc, 6768 Defining_Identifier => I, 6769 Discrete_Subtype_Definition => 6770 Make_Attribute_Reference (Loc, 6771 Prefix => New_Reference_To (X, Loc), 6772 Attribute_Name => Name_Range))), 6773 6774 Statements => New_List (Loop_Body)); 6775 6776 -- if X'length = 0 then 6777 -- return false; 6778 -- elsif Y'length = 0 then 6779 -- return true; 6780 -- else 6781 -- for ... loop ... end loop; 6782 -- return X'length > Y'length; 6783 -- end if; 6784 6785 Length1 := 6786 Make_Attribute_Reference (Loc, 6787 Prefix => New_Reference_To (X, Loc), 6788 Attribute_Name => Name_Length); 6789 6790 Length2 := 6791 Make_Attribute_Reference (Loc, 6792 Prefix => New_Reference_To (Y, Loc), 6793 Attribute_Name => Name_Length); 6794 6795 Final_Expr := 6796 Make_Op_Gt (Loc, 6797 Left_Opnd => Length1, 6798 Right_Opnd => Length2); 6799 6800 If_Stat := 6801 Make_Implicit_If_Statement (Nod, 6802 Condition => 6803 Make_Op_Eq (Loc, 6804 Left_Opnd => 6805 Make_Attribute_Reference (Loc, 6806 Prefix => New_Reference_To (X, Loc), 6807 Attribute_Name => Name_Length), 6808 Right_Opnd => 6809 Make_Integer_Literal (Loc, 0)), 6810 6811 Then_Statements => 6812 New_List ( 6813 Make_Return_Statement (Loc, 6814 Expression => New_Reference_To (Standard_False, Loc))), 6815 6816 Elsif_Parts => New_List ( 6817 Make_Elsif_Part (Loc, 6818 Condition => 6819 Make_Op_Eq (Loc, 6820 Left_Opnd => 6821 Make_Attribute_Reference (Loc, 6822 Prefix => New_Reference_To (Y, Loc), 6823 Attribute_Name => Name_Length), 6824 Right_Opnd => 6825 Make_Integer_Literal (Loc, 0)), 6826 6827 Then_Statements => 6828 New_List ( 6829 Make_Return_Statement (Loc, 6830 Expression => New_Reference_To (Standard_True, Loc))))), 6831 6832 Else_Statements => New_List ( 6833 Loop_Statement, 6834 Make_Return_Statement (Loc, 6835 Expression => Final_Expr))); 6836 6837 -- (X : a; Y: a) 6838 6839 Formals := New_List ( 6840 Make_Parameter_Specification (Loc, 6841 Defining_Identifier => X, 6842 Parameter_Type => New_Reference_To (Typ, Loc)), 6843 6844 Make_Parameter_Specification (Loc, 6845 Defining_Identifier => Y, 6846 Parameter_Type => New_Reference_To (Typ, Loc))); 6847 6848 -- function Gnnn (...) return boolean is 6849 -- J : index := Y'first; 6850 -- begin 6851 -- if ... end if; 6852 -- end Gnnn; 6853 6854 Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); 6855 6856 Func_Body := 6857 Make_Subprogram_Body (Loc, 6858 Specification => 6859 Make_Function_Specification (Loc, 6860 Defining_Unit_Name => Func_Name, 6861 Parameter_Specifications => Formals, 6862 Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), 6863 6864 Declarations => New_List ( 6865 Make_Object_Declaration (Loc, 6866 Defining_Identifier => J, 6867 Object_Definition => New_Reference_To (Index, Loc), 6868 Expression => 6869 Make_Attribute_Reference (Loc, 6870 Prefix => New_Reference_To (Y, Loc), 6871 Attribute_Name => Name_First))), 6872 6873 Handled_Statement_Sequence => 6874 Make_Handled_Sequence_Of_Statements (Loc, 6875 Statements => New_List (If_Stat))); 6876 6877 return Func_Body; 6878 6879 end Make_Array_Comparison_Op; 6880 6881 --------------------------- 6882 -- Make_Boolean_Array_Op -- 6883 --------------------------- 6884 6885 -- For logical operations on boolean arrays, expand in line the 6886 -- following, replacing 'and' with 'or' or 'xor' where needed: 6887 6888 -- function Annn (A : typ; B: typ) return typ is 6889 -- C : typ; 6890 -- begin 6891 -- for J in A'range loop 6892 -- C (J) := A (J) op B (J); 6893 -- end loop; 6894 -- return C; 6895 -- end Annn; 6896 6897 -- Here typ is the boolean array type 6898 6899 function Make_Boolean_Array_Op 6900 (Typ : Entity_Id; 6901 N : Node_Id) 6902 return Node_Id 6903 is 6904 Loc : constant Source_Ptr := Sloc (N); 6905 6906 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 6907 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 6908 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); 6909 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 6910 6911 A_J : Node_Id; 6912 B_J : Node_Id; 6913 C_J : Node_Id; 6914 Op : Node_Id; 6915 6916 Formals : List_Id; 6917 Func_Name : Entity_Id; 6918 Func_Body : Node_Id; 6919 Loop_Statement : Node_Id; 6920 6921 begin 6922 A_J := 6923 Make_Indexed_Component (Loc, 6924 Prefix => New_Reference_To (A, Loc), 6925 Expressions => New_List (New_Reference_To (J, Loc))); 6926 6927 B_J := 6928 Make_Indexed_Component (Loc, 6929 Prefix => New_Reference_To (B, Loc), 6930 Expressions => New_List (New_Reference_To (J, Loc))); 6931 6932 C_J := 6933 Make_Indexed_Component (Loc, 6934 Prefix => New_Reference_To (C, Loc), 6935 Expressions => New_List (New_Reference_To (J, Loc))); 6936 6937 if Nkind (N) = N_Op_And then 6938 Op := 6939 Make_Op_And (Loc, 6940 Left_Opnd => A_J, 6941 Right_Opnd => B_J); 6942 6943 elsif Nkind (N) = N_Op_Or then 6944 Op := 6945 Make_Op_Or (Loc, 6946 Left_Opnd => A_J, 6947 Right_Opnd => B_J); 6948 6949 else 6950 Op := 6951 Make_Op_Xor (Loc, 6952 Left_Opnd => A_J, 6953 Right_Opnd => B_J); 6954 end if; 6955 6956 Loop_Statement := 6957 Make_Implicit_Loop_Statement (N, 6958 Identifier => Empty, 6959 6960 Iteration_Scheme => 6961 Make_Iteration_Scheme (Loc, 6962 Loop_Parameter_Specification => 6963 Make_Loop_Parameter_Specification (Loc, 6964 Defining_Identifier => J, 6965 Discrete_Subtype_Definition => 6966 Make_Attribute_Reference (Loc, 6967 Prefix => New_Reference_To (A, Loc), 6968 Attribute_Name => Name_Range))), 6969 6970 Statements => New_List ( 6971 Make_Assignment_Statement (Loc, 6972 Name => C_J, 6973 Expression => Op))); 6974 6975 Formals := New_List ( 6976 Make_Parameter_Specification (Loc, 6977 Defining_Identifier => A, 6978 Parameter_Type => New_Reference_To (Typ, Loc)), 6979 6980 Make_Parameter_Specification (Loc, 6981 Defining_Identifier => B, 6982 Parameter_Type => New_Reference_To (Typ, Loc))); 6983 6984 Func_Name := 6985 Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 6986 Set_Is_Inlined (Func_Name); 6987 6988 Func_Body := 6989 Make_Subprogram_Body (Loc, 6990 Specification => 6991 Make_Function_Specification (Loc, 6992 Defining_Unit_Name => Func_Name, 6993 Parameter_Specifications => Formals, 6994 Subtype_Mark => New_Reference_To (Typ, Loc)), 6995 6996 Declarations => New_List ( 6997 Make_Object_Declaration (Loc, 6998 Defining_Identifier => C, 6999 Object_Definition => New_Reference_To (Typ, Loc))), 7000 7001 Handled_Statement_Sequence => 7002 Make_Handled_Sequence_Of_Statements (Loc, 7003 Statements => New_List ( 7004 Loop_Statement, 7005 Make_Return_Statement (Loc, 7006 Expression => New_Reference_To (C, Loc))))); 7007 7008 return Func_Body; 7009 end Make_Boolean_Array_Op; 7010 7011 ------------------------ 7012 -- Rewrite_Comparison -- 7013 ------------------------ 7014 7015 procedure Rewrite_Comparison (N : Node_Id) is 7016 Typ : constant Entity_Id := Etype (N); 7017 Op1 : constant Node_Id := Left_Opnd (N); 7018 Op2 : constant Node_Id := Right_Opnd (N); 7019 7020 Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2); 7021 -- Res indicates if compare outcome can be determined at compile time 7022 7023 True_Result : Boolean; 7024 False_Result : Boolean; 7025 7026 begin 7027 case N_Op_Compare (Nkind (N)) is 7028 when N_Op_Eq => 7029 True_Result := Res = EQ; 7030 False_Result := Res = LT or else Res = GT or else Res = NE; 7031 7032 when N_Op_Ge => 7033 True_Result := Res in Compare_GE; 7034 False_Result := Res = LT; 7035 7036 when N_Op_Gt => 7037 True_Result := Res = GT; 7038 False_Result := Res in Compare_LE; 7039 7040 when N_Op_Lt => 7041 True_Result := Res = LT; 7042 False_Result := Res in Compare_GE; 7043 7044 when N_Op_Le => 7045 True_Result := Res in Compare_LE; 7046 False_Result := Res = GT; 7047 7048 when N_Op_Ne => 7049 True_Result := Res = NE; 7050 False_Result := Res = LT or else Res = GT or else Res = EQ; 7051 end case; 7052 7053 if True_Result then 7054 Rewrite (N, 7055 Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)))); 7056 Analyze_And_Resolve (N, Typ); 7057 Warn_On_Known_Condition (N); 7058 7059 elsif False_Result then 7060 Rewrite (N, 7061 Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N)))); 7062 Analyze_And_Resolve (N, Typ); 7063 Warn_On_Known_Condition (N); 7064 end if; 7065 end Rewrite_Comparison; 7066 7067 ---------------------------- 7068 -- Safe_In_Place_Array_Op -- 7069 ---------------------------- 7070 7071 function Safe_In_Place_Array_Op 7072 (Lhs : Node_Id; 7073 Op1 : Node_Id; 7074 Op2 : Node_Id) 7075 return Boolean 7076 is 7077 Target : Entity_Id; 7078 7079 function Is_Safe_Operand (Op : Node_Id) return Boolean; 7080 -- Operand is safe if it cannot overlap part of the target of the 7081 -- operation. If the operand and the target are identical, the operand 7082 -- is safe. The operand can be empty in the case of negation. 7083 7084 function Is_Unaliased (N : Node_Id) return Boolean; 7085 -- Check that N is a stand-alone entity. 7086 7087 ------------------ 7088 -- Is_Unaliased -- 7089 ------------------ 7090 7091 function Is_Unaliased (N : Node_Id) return Boolean is 7092 begin 7093 return 7094 Is_Entity_Name (N) 7095 and then No (Address_Clause (Entity (N))) 7096 and then No (Renamed_Object (Entity (N))); 7097 end Is_Unaliased; 7098 7099 --------------------- 7100 -- Is_Safe_Operand -- 7101 --------------------- 7102 7103 function Is_Safe_Operand (Op : Node_Id) return Boolean is 7104 begin 7105 if No (Op) then 7106 return True; 7107 7108 elsif Is_Entity_Name (Op) then 7109 return Is_Unaliased (Op); 7110 7111 elsif Nkind (Op) = N_Indexed_Component 7112 or else Nkind (Op) = N_Selected_Component 7113 then 7114 return Is_Unaliased (Prefix (Op)); 7115 7116 elsif Nkind (Op) = N_Slice then 7117 return 7118 Is_Unaliased (Prefix (Op)) 7119 and then Entity (Prefix (Op)) /= Target; 7120 7121 elsif Nkind (Op) = N_Op_Not then 7122 return Is_Safe_Operand (Right_Opnd (Op)); 7123 7124 else 7125 return False; 7126 end if; 7127 end Is_Safe_Operand; 7128 7129 -- Start of processing for Is_Safe_In_Place_Array_Op 7130 7131 begin 7132 -- We skip this processing if the component size is not the 7133 -- same as a system storage unit (since at least for NOT 7134 -- this would cause problems). 7135 7136 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then 7137 return False; 7138 7139 -- Cannot do in place stuff on Java_VM since cannot pass addresses 7140 7141 elsif Java_VM then 7142 return False; 7143 7144 -- Cannot do in place stuff if non-standard Boolean representation 7145 7146 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then 7147 return False; 7148 7149 elsif not Is_Unaliased (Lhs) then 7150 return False; 7151 else 7152 Target := Entity (Lhs); 7153 7154 return 7155 Is_Safe_Operand (Op1) 7156 and then Is_Safe_Operand (Op2); 7157 end if; 7158 end Safe_In_Place_Array_Op; 7159 7160 ----------------------- 7161 -- Tagged_Membership -- 7162 ----------------------- 7163 7164 -- There are two different cases to consider depending on whether 7165 -- the right operand is a class-wide type or not. If not we just 7166 -- compare the actual tag of the left expr to the target type tag: 7167 -- 7168 -- Left_Expr.Tag = Right_Type'Tag; 7169 -- 7170 -- If it is a class-wide type we use the RT function CW_Membership which 7171 -- is usually implemented by looking in the ancestor tables contained in 7172 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag 7173 7174 function Tagged_Membership (N : Node_Id) return Node_Id is 7175 Left : constant Node_Id := Left_Opnd (N); 7176 Right : constant Node_Id := Right_Opnd (N); 7177 Loc : constant Source_Ptr := Sloc (N); 7178 7179 Left_Type : Entity_Id; 7180 Right_Type : Entity_Id; 7181 Obj_Tag : Node_Id; 7182 7183 begin 7184 Left_Type := Etype (Left); 7185 Right_Type := Etype (Right); 7186 7187 if Is_Class_Wide_Type (Left_Type) then 7188 Left_Type := Root_Type (Left_Type); 7189 end if; 7190 7191 Obj_Tag := 7192 Make_Selected_Component (Loc, 7193 Prefix => Relocate_Node (Left), 7194 Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc)); 7195 7196 if Is_Class_Wide_Type (Right_Type) then 7197 return 7198 Make_DT_Access_Action (Left_Type, 7199 Action => CW_Membership, 7200 Args => New_List ( 7201 Obj_Tag, 7202 New_Reference_To ( 7203 Access_Disp_Table (Root_Type (Right_Type)), Loc))); 7204 else 7205 return 7206 Make_Op_Eq (Loc, 7207 Left_Opnd => Obj_Tag, 7208 Right_Opnd => 7209 New_Reference_To (Access_Disp_Table (Right_Type), Loc)); 7210 end if; 7211 7212 end Tagged_Membership; 7213 7214 ------------------------------ 7215 -- Unary_Op_Validity_Checks -- 7216 ------------------------------ 7217 7218 procedure Unary_Op_Validity_Checks (N : Node_Id) is 7219 begin 7220 if Validity_Checks_On and Validity_Check_Operands then 7221 Ensure_Valid (Right_Opnd (N)); 7222 end if; 7223 end Unary_Op_Validity_Checks; 7224 7225end Exp_Ch4; 7226