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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Aggr; use Exp_Aggr; 33with Exp_Atag; use Exp_Atag; 34with Exp_Ch2; use Exp_Ch2; 35with Exp_Ch3; use Exp_Ch3; 36with Exp_Ch6; use Exp_Ch6; 37with Exp_Ch7; use Exp_Ch7; 38with Exp_Ch9; use Exp_Ch9; 39with Exp_Disp; use Exp_Disp; 40with Exp_Fixd; use Exp_Fixd; 41with Exp_Intr; use Exp_Intr; 42with Exp_Pakd; use Exp_Pakd; 43with Exp_Tss; use Exp_Tss; 44with Exp_Util; use Exp_Util; 45with Exp_VFpt; use Exp_VFpt; 46with Freeze; use Freeze; 47with Inline; use Inline; 48with Lib; use Lib; 49with Namet; use Namet; 50with Nlists; use Nlists; 51with Nmake; use Nmake; 52with Opt; use Opt; 53with Par_SCO; use Par_SCO; 54with Restrict; use Restrict; 55with Rident; use Rident; 56with Rtsfind; use Rtsfind; 57with Sem; use Sem; 58with Sem_Aux; use Sem_Aux; 59with Sem_Cat; use Sem_Cat; 60with Sem_Ch3; use Sem_Ch3; 61with Sem_Ch8; use Sem_Ch8; 62with Sem_Ch13; use Sem_Ch13; 63with Sem_Eval; use Sem_Eval; 64with Sem_Res; use Sem_Res; 65with Sem_Type; use Sem_Type; 66with Sem_Util; use Sem_Util; 67with Sem_Warn; use Sem_Warn; 68with Sinfo; use Sinfo; 69with Snames; use Snames; 70with Stand; use Stand; 71with SCIL_LL; use SCIL_LL; 72with Targparm; use Targparm; 73with Tbuild; use Tbuild; 74with Ttypes; use Ttypes; 75with Uintp; use Uintp; 76with Urealp; use Urealp; 77with Validsw; use Validsw; 78 79package body Exp_Ch4 is 80 81 ----------------------- 82 -- Local Subprograms -- 83 ----------------------- 84 85 procedure Binary_Op_Validity_Checks (N : Node_Id); 86 pragma Inline (Binary_Op_Validity_Checks); 87 -- Performs validity checks for a binary operator 88 89 procedure Build_Boolean_Array_Proc_Call 90 (N : Node_Id; 91 Op1 : Node_Id; 92 Op2 : Node_Id); 93 -- If a boolean array assignment can be done in place, build call to 94 -- corresponding library procedure. 95 96 function Current_Anonymous_Master return Entity_Id; 97 -- Return the entity of the heterogeneous finalization master belonging to 98 -- the current unit (either function, package or procedure). This master 99 -- services all anonymous access-to-controlled types. If the current unit 100 -- does not have such master, create one. 101 102 procedure Displace_Allocator_Pointer (N : Node_Id); 103 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and 104 -- Expand_Allocator_Expression. Allocating class-wide interface objects 105 -- this routine displaces the pointer to the allocated object to reference 106 -- the component referencing the corresponding secondary dispatch table. 107 108 procedure Expand_Allocator_Expression (N : Node_Id); 109 -- Subsidiary to Expand_N_Allocator, for the case when the expression 110 -- is a qualified expression or an aggregate. 111 112 procedure Expand_Array_Comparison (N : Node_Id); 113 -- This routine handles expansion of the comparison operators (N_Op_Lt, 114 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic 115 -- code for these operators is similar, differing only in the details of 116 -- the actual comparison call that is made. Special processing (call a 117 -- run-time routine) 118 119 function Expand_Array_Equality 120 (Nod : Node_Id; 121 Lhs : Node_Id; 122 Rhs : Node_Id; 123 Bodies : List_Id; 124 Typ : Entity_Id) return Node_Id; 125 -- Expand an array equality into a call to a function implementing this 126 -- equality, and a call to it. Loc is the location for the generated nodes. 127 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list 128 -- on which to attach bodies of local functions that are created in the 129 -- process. It is the responsibility of the caller to insert those bodies 130 -- at the right place. Nod provides the Sloc value for the generated code. 131 -- Normally the types used for the generated equality routine are taken 132 -- from Lhs and Rhs. However, in some situations of generated code, the 133 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies 134 -- the type to be used for the formal parameters. 135 136 procedure Expand_Boolean_Operator (N : Node_Id); 137 -- Common expansion processing for Boolean operators (And, Or, Xor) for the 138 -- case of array type arguments. 139 140 procedure Expand_Short_Circuit_Operator (N : Node_Id); 141 -- Common expansion processing for short-circuit boolean operators 142 143 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id); 144 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is 145 -- where we allow comparison of "out of range" values. 146 147 function Expand_Composite_Equality 148 (Nod : Node_Id; 149 Typ : Entity_Id; 150 Lhs : Node_Id; 151 Rhs : Node_Id; 152 Bodies : List_Id) return Node_Id; 153 -- Local recursive function used to expand equality for nested composite 154 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which 155 -- to attach bodies of local functions that are created in the process. 156 -- It is the responsibility of the caller to insert those bodies at the 157 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs 158 -- are the left and right sides for the comparison, and Typ is the type of 159 -- the objects to compare. 160 161 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); 162 -- Routine to expand concatenation of a sequence of two or more operands 163 -- (in the list Operands) and replace node Cnode with the result of the 164 -- concatenation. The operands can be of any appropriate type, and can 165 -- include both arrays and singleton elements. 166 167 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id); 168 -- N is an N_In membership test mode, with the overflow check mode set to 169 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed 170 -- integer type. This is a case where top level processing is required to 171 -- handle overflow checks in subtrees. 172 173 procedure Fixup_Universal_Fixed_Operation (N : Node_Id); 174 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal 175 -- fixed. We do not have such a type at runtime, so the purpose of this 176 -- routine is to find the real type by looking up the tree. We also 177 -- determine if the operation must be rounded. 178 179 function Has_Inferable_Discriminants (N : Node_Id) return Boolean; 180 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable 181 -- discriminants if it has a constrained nominal type, unless the object 182 -- is a component of an enclosing Unchecked_Union object that is subject 183 -- to a per-object constraint and the enclosing object lacks inferable 184 -- discriminants. 185 -- 186 -- An expression of an Unchecked_Union type has inferable discriminants 187 -- if it is either a name of an object with inferable discriminants or a 188 -- qualified expression whose subtype mark denotes a constrained subtype. 189 190 procedure Insert_Dereference_Action (N : Node_Id); 191 -- N is an expression whose type is an access. When the type of the 192 -- associated storage pool is derived from Checked_Pool, generate a 193 -- call to the 'Dereference' primitive operation. 194 195 function Make_Array_Comparison_Op 196 (Typ : Entity_Id; 197 Nod : Node_Id) return Node_Id; 198 -- Comparisons between arrays are expanded in line. This function produces 199 -- the body of the implementation of (a > b), where a and b are one- 200 -- dimensional arrays of some discrete type. The original node is then 201 -- expanded into the appropriate call to this function. Nod provides the 202 -- Sloc value for the generated code. 203 204 function Make_Boolean_Array_Op 205 (Typ : Entity_Id; 206 N : Node_Id) return Node_Id; 207 -- Boolean operations on boolean arrays are expanded in line. This function 208 -- produce the body for the node N, which is (a and b), (a or b), or (a xor 209 -- b). It is used only the normal case and not the packed case. The type 210 -- involved, Typ, is the Boolean array type, and the logical operations in 211 -- the body are simple boolean operations. Note that Typ is always a 212 -- constrained type (the caller has ensured this by using 213 -- Convert_To_Actual_Subtype if necessary). 214 215 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean; 216 -- For signed arithmetic operations when the current overflow mode is 217 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks 218 -- as the first thing we do. We then return. We count on the recursive 219 -- apparatus for overflow checks to call us back with an equivalent 220 -- operation that is in CHECKED mode, avoiding a recursive entry into this 221 -- routine, and that is when we will proceed with the expansion of the 222 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do 223 -- these optimizations without first making this check, since there may be 224 -- operands further down the tree that are relying on the recursive calls 225 -- triggered by the top level nodes to properly process overflow checking 226 -- and remaining expansion on these nodes. Note that this call back may be 227 -- skipped if the operation is done in Bignum mode but that's fine, since 228 -- the Bignum call takes care of everything. 229 230 procedure Optimize_Length_Comparison (N : Node_Id); 231 -- Given an expression, if it is of the form X'Length op N (or the other 232 -- way round), where N is known at compile time to be 0 or 1, and X is a 233 -- simple entity, and op is a comparison operator, optimizes it into a 234 -- comparison of First and Last. 235 236 procedure Rewrite_Comparison (N : Node_Id); 237 -- If N is the node for a comparison whose outcome can be determined at 238 -- compile time, then the node N can be rewritten with True or False. If 239 -- the outcome cannot be determined at compile time, the call has no 240 -- effect. If N is a type conversion, then this processing is applied to 241 -- its expression. If N is neither comparison nor a type conversion, the 242 -- call has no effect. 243 244 procedure Tagged_Membership 245 (N : Node_Id; 246 SCIL_Node : out Node_Id; 247 Result : out Node_Id); 248 -- Construct the expression corresponding to the tagged membership test. 249 -- Deals with a second operand being (or not) a class-wide type. 250 251 function Safe_In_Place_Array_Op 252 (Lhs : Node_Id; 253 Op1 : Node_Id; 254 Op2 : Node_Id) return Boolean; 255 -- In the context of an assignment, where the right-hand side is a boolean 256 -- operation on arrays, check whether operation can be performed in place. 257 258 procedure Unary_Op_Validity_Checks (N : Node_Id); 259 pragma Inline (Unary_Op_Validity_Checks); 260 -- Performs validity checks for a unary operator 261 262 ------------------------------- 263 -- Binary_Op_Validity_Checks -- 264 ------------------------------- 265 266 procedure Binary_Op_Validity_Checks (N : Node_Id) is 267 begin 268 if Validity_Checks_On and Validity_Check_Operands then 269 Ensure_Valid (Left_Opnd (N)); 270 Ensure_Valid (Right_Opnd (N)); 271 end if; 272 end Binary_Op_Validity_Checks; 273 274 ------------------------------------ 275 -- Build_Boolean_Array_Proc_Call -- 276 ------------------------------------ 277 278 procedure Build_Boolean_Array_Proc_Call 279 (N : Node_Id; 280 Op1 : Node_Id; 281 Op2 : Node_Id) 282 is 283 Loc : constant Source_Ptr := Sloc (N); 284 Kind : constant Node_Kind := Nkind (Expression (N)); 285 Target : constant Node_Id := 286 Make_Attribute_Reference (Loc, 287 Prefix => Name (N), 288 Attribute_Name => Name_Address); 289 290 Arg1 : Node_Id := Op1; 291 Arg2 : Node_Id := Op2; 292 Call_Node : Node_Id; 293 Proc_Name : Entity_Id; 294 295 begin 296 if Kind = N_Op_Not then 297 if Nkind (Op1) in N_Binary_Op then 298 299 -- Use negated version of the binary operators 300 301 if Nkind (Op1) = N_Op_And then 302 Proc_Name := RTE (RE_Vector_Nand); 303 304 elsif Nkind (Op1) = N_Op_Or then 305 Proc_Name := RTE (RE_Vector_Nor); 306 307 else pragma Assert (Nkind (Op1) = N_Op_Xor); 308 Proc_Name := RTE (RE_Vector_Xor); 309 end if; 310 311 Call_Node := 312 Make_Procedure_Call_Statement (Loc, 313 Name => New_Occurrence_Of (Proc_Name, Loc), 314 315 Parameter_Associations => New_List ( 316 Target, 317 Make_Attribute_Reference (Loc, 318 Prefix => Left_Opnd (Op1), 319 Attribute_Name => Name_Address), 320 321 Make_Attribute_Reference (Loc, 322 Prefix => Right_Opnd (Op1), 323 Attribute_Name => Name_Address), 324 325 Make_Attribute_Reference (Loc, 326 Prefix => Left_Opnd (Op1), 327 Attribute_Name => Name_Length))); 328 329 else 330 Proc_Name := RTE (RE_Vector_Not); 331 332 Call_Node := 333 Make_Procedure_Call_Statement (Loc, 334 Name => New_Occurrence_Of (Proc_Name, Loc), 335 Parameter_Associations => New_List ( 336 Target, 337 338 Make_Attribute_Reference (Loc, 339 Prefix => Op1, 340 Attribute_Name => Name_Address), 341 342 Make_Attribute_Reference (Loc, 343 Prefix => Op1, 344 Attribute_Name => Name_Length))); 345 end if; 346 347 else 348 -- We use the following equivalences: 349 350 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) 351 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) 352 -- (not X) xor (not Y) = X xor Y 353 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) 354 355 if Nkind (Op1) = N_Op_Not then 356 Arg1 := Right_Opnd (Op1); 357 Arg2 := Right_Opnd (Op2); 358 if Kind = N_Op_And then 359 Proc_Name := RTE (RE_Vector_Nor); 360 elsif Kind = N_Op_Or then 361 Proc_Name := RTE (RE_Vector_Nand); 362 else 363 Proc_Name := RTE (RE_Vector_Xor); 364 end if; 365 366 else 367 if Kind = N_Op_And then 368 Proc_Name := RTE (RE_Vector_And); 369 elsif Kind = N_Op_Or then 370 Proc_Name := RTE (RE_Vector_Or); 371 elsif Nkind (Op2) = N_Op_Not then 372 Proc_Name := RTE (RE_Vector_Nxor); 373 Arg2 := Right_Opnd (Op2); 374 else 375 Proc_Name := RTE (RE_Vector_Xor); 376 end if; 377 end if; 378 379 Call_Node := 380 Make_Procedure_Call_Statement (Loc, 381 Name => New_Occurrence_Of (Proc_Name, Loc), 382 Parameter_Associations => New_List ( 383 Target, 384 Make_Attribute_Reference (Loc, 385 Prefix => Arg1, 386 Attribute_Name => Name_Address), 387 Make_Attribute_Reference (Loc, 388 Prefix => Arg2, 389 Attribute_Name => Name_Address), 390 Make_Attribute_Reference (Loc, 391 Prefix => Arg1, 392 Attribute_Name => Name_Length))); 393 end if; 394 395 Rewrite (N, Call_Node); 396 Analyze (N); 397 398 exception 399 when RE_Not_Available => 400 return; 401 end Build_Boolean_Array_Proc_Call; 402 403 ------------------------------ 404 -- Current_Anonymous_Master -- 405 ------------------------------ 406 407 function Current_Anonymous_Master return Entity_Id is 408 Decls : List_Id; 409 Loc : Source_Ptr; 410 Subp_Body : Node_Id; 411 Unit_Decl : Node_Id; 412 Unit_Id : Entity_Id; 413 414 begin 415 Unit_Id := Cunit_Entity (Current_Sem_Unit); 416 417 -- Find the entity of the current unit 418 419 if Ekind (Unit_Id) = E_Subprogram_Body then 420 421 -- When processing subprogram bodies, the proper scope is always that 422 -- of the spec. 423 424 Subp_Body := Unit_Id; 425 while Present (Subp_Body) 426 and then Nkind (Subp_Body) /= N_Subprogram_Body 427 loop 428 Subp_Body := Parent (Subp_Body); 429 end loop; 430 431 Unit_Id := Corresponding_Spec (Subp_Body); 432 end if; 433 434 Loc := Sloc (Unit_Id); 435 Unit_Decl := Unit (Cunit (Current_Sem_Unit)); 436 437 -- Find the declarations list of the current unit 438 439 if Nkind (Unit_Decl) = N_Package_Declaration then 440 Unit_Decl := Specification (Unit_Decl); 441 Decls := Visible_Declarations (Unit_Decl); 442 443 if No (Decls) then 444 Decls := New_List (Make_Null_Statement (Loc)); 445 Set_Visible_Declarations (Unit_Decl, Decls); 446 447 elsif Is_Empty_List (Decls) then 448 Append_To (Decls, Make_Null_Statement (Loc)); 449 end if; 450 451 else 452 Decls := Declarations (Unit_Decl); 453 454 if No (Decls) then 455 Decls := New_List (Make_Null_Statement (Loc)); 456 Set_Declarations (Unit_Decl, Decls); 457 458 elsif Is_Empty_List (Decls) then 459 Append_To (Decls, Make_Null_Statement (Loc)); 460 end if; 461 end if; 462 463 -- The current unit has an existing anonymous master, traverse its 464 -- declarations and locate the entity. 465 466 if Has_Anonymous_Master (Unit_Id) then 467 declare 468 Decl : Node_Id; 469 Fin_Mas_Id : Entity_Id; 470 471 begin 472 Decl := First (Decls); 473 while Present (Decl) loop 474 475 -- Look for the first variable in the declarations whole type 476 -- is Finalization_Master. 477 478 if Nkind (Decl) = N_Object_Declaration then 479 Fin_Mas_Id := Defining_Identifier (Decl); 480 481 if Ekind (Fin_Mas_Id) = E_Variable 482 and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) 483 then 484 return Fin_Mas_Id; 485 end if; 486 end if; 487 488 Next (Decl); 489 end loop; 490 491 -- The master was not found even though the unit was labeled as 492 -- having one. 493 494 raise Program_Error; 495 end; 496 497 -- Create a new anonymous master 498 499 else 500 declare 501 First_Decl : constant Node_Id := First (Decls); 502 Action : Node_Id; 503 Fin_Mas_Id : Entity_Id; 504 505 begin 506 -- Since the master and its associated initialization is inserted 507 -- at top level, use the scope of the unit when analyzing. 508 509 Push_Scope (Unit_Id); 510 511 -- Create the finalization master 512 513 Fin_Mas_Id := 514 Make_Defining_Identifier (Loc, 515 Chars => New_External_Name (Chars (Unit_Id), "AM")); 516 517 -- Generate: 518 -- <Fin_Mas_Id> : Finalization_Master; 519 520 Action := 521 Make_Object_Declaration (Loc, 522 Defining_Identifier => Fin_Mas_Id, 523 Object_Definition => 524 New_Reference_To (RTE (RE_Finalization_Master), Loc)); 525 526 Insert_Before_And_Analyze (First_Decl, Action); 527 528 -- Mark the unit to prevent the generation of multiple masters 529 530 Set_Has_Anonymous_Master (Unit_Id); 531 532 -- Do not set the base pool and mode of operation on .NET/JVM 533 -- since those targets do not support pools and all VM masters 534 -- are heterogeneous by default. 535 536 if VM_Target = No_VM then 537 538 -- Generate: 539 -- Set_Base_Pool 540 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access); 541 542 Action := 543 Make_Procedure_Call_Statement (Loc, 544 Name => 545 New_Reference_To (RTE (RE_Set_Base_Pool), Loc), 546 547 Parameter_Associations => New_List ( 548 New_Reference_To (Fin_Mas_Id, Loc), 549 Make_Attribute_Reference (Loc, 550 Prefix => 551 New_Reference_To (RTE (RE_Global_Pool_Object), Loc), 552 Attribute_Name => Name_Unrestricted_Access))); 553 554 Insert_Before_And_Analyze (First_Decl, Action); 555 556 -- Generate: 557 -- Set_Is_Heterogeneous (<Fin_Mas_Id>); 558 559 Action := 560 Make_Procedure_Call_Statement (Loc, 561 Name => 562 New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc), 563 Parameter_Associations => New_List ( 564 New_Reference_To (Fin_Mas_Id, Loc))); 565 566 Insert_Before_And_Analyze (First_Decl, Action); 567 end if; 568 569 -- Restore the original state of the scope stack 570 571 Pop_Scope; 572 573 return Fin_Mas_Id; 574 end; 575 end if; 576 end Current_Anonymous_Master; 577 578 -------------------------------- 579 -- Displace_Allocator_Pointer -- 580 -------------------------------- 581 582 procedure Displace_Allocator_Pointer (N : Node_Id) is 583 Loc : constant Source_Ptr := Sloc (N); 584 Orig_Node : constant Node_Id := Original_Node (N); 585 Dtyp : Entity_Id; 586 Etyp : Entity_Id; 587 PtrT : Entity_Id; 588 589 begin 590 -- Do nothing in case of VM targets: the virtual machine will handle 591 -- interfaces directly. 592 593 if not Tagged_Type_Expansion then 594 return; 595 end if; 596 597 pragma Assert (Nkind (N) = N_Identifier 598 and then Nkind (Orig_Node) = N_Allocator); 599 600 PtrT := Etype (Orig_Node); 601 Dtyp := Available_View (Designated_Type (PtrT)); 602 Etyp := Etype (Expression (Orig_Node)); 603 604 if Is_Class_Wide_Type (Dtyp) 605 and then Is_Interface (Dtyp) 606 then 607 -- If the type of the allocator expression is not an interface type 608 -- we can generate code to reference the record component containing 609 -- the pointer to the secondary dispatch table. 610 611 if not Is_Interface (Etyp) then 612 declare 613 Saved_Typ : constant Entity_Id := Etype (Orig_Node); 614 615 begin 616 -- 1) Get access to the allocated object 617 618 Rewrite (N, 619 Make_Explicit_Dereference (Loc, Relocate_Node (N))); 620 Set_Etype (N, Etyp); 621 Set_Analyzed (N); 622 623 -- 2) Add the conversion to displace the pointer to reference 624 -- the secondary dispatch table. 625 626 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N))); 627 Analyze_And_Resolve (N, Dtyp); 628 629 -- 3) The 'access to the secondary dispatch table will be used 630 -- as the value returned by the allocator. 631 632 Rewrite (N, 633 Make_Attribute_Reference (Loc, 634 Prefix => Relocate_Node (N), 635 Attribute_Name => Name_Access)); 636 Set_Etype (N, Saved_Typ); 637 Set_Analyzed (N); 638 end; 639 640 -- If the type of the allocator expression is an interface type we 641 -- generate a run-time call to displace "this" to reference the 642 -- component containing the pointer to the secondary dispatch table 643 -- or else raise Constraint_Error if the actual object does not 644 -- implement the target interface. This case corresponds with the 645 -- following example: 646 647 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is 648 -- begin 649 -- return new Iface_2'Class'(Obj); 650 -- end Op; 651 652 else 653 Rewrite (N, 654 Unchecked_Convert_To (PtrT, 655 Make_Function_Call (Loc, 656 Name => New_Reference_To (RTE (RE_Displace), Loc), 657 Parameter_Associations => New_List ( 658 Unchecked_Convert_To (RTE (RE_Address), 659 Relocate_Node (N)), 660 661 New_Occurrence_Of 662 (Elists.Node 663 (First_Elmt 664 (Access_Disp_Table (Etype (Base_Type (Dtyp))))), 665 Loc))))); 666 Analyze_And_Resolve (N, PtrT); 667 end if; 668 end if; 669 end Displace_Allocator_Pointer; 670 671 --------------------------------- 672 -- Expand_Allocator_Expression -- 673 --------------------------------- 674 675 procedure Expand_Allocator_Expression (N : Node_Id) is 676 Loc : constant Source_Ptr := Sloc (N); 677 Exp : constant Node_Id := Expression (Expression (N)); 678 PtrT : constant Entity_Id := Etype (N); 679 DesigT : constant Entity_Id := Designated_Type (PtrT); 680 681 procedure Apply_Accessibility_Check 682 (Ref : Node_Id; 683 Built_In_Place : Boolean := False); 684 -- Ada 2005 (AI-344): For an allocator with a class-wide designated 685 -- type, generate an accessibility check to verify that the level of the 686 -- type of the created object is not deeper than the level of the access 687 -- type. If the type of the qualified expression is class-wide, then 688 -- always generate the check (except in the case where it is known to be 689 -- unnecessary, see comment below). Otherwise, only generate the check 690 -- if the level of the qualified expression type is statically deeper 691 -- than the access type. 692 -- 693 -- Although the static accessibility will generally have been performed 694 -- as a legality check, it won't have been done in cases where the 695 -- allocator appears in generic body, so a run-time check is needed in 696 -- general. One special case is when the access type is declared in the 697 -- same scope as the class-wide allocator, in which case the check can 698 -- never fail, so it need not be generated. 699 -- 700 -- As an open issue, there seem to be cases where the static level 701 -- associated with the class-wide object's underlying type is not 702 -- sufficient to perform the proper accessibility check, such as for 703 -- allocators in nested subprograms or accept statements initialized by 704 -- class-wide formals when the actual originates outside at a deeper 705 -- static level. The nested subprogram case might require passing 706 -- accessibility levels along with class-wide parameters, and the task 707 -- case seems to be an actual gap in the language rules that needs to 708 -- be fixed by the ARG. ??? 709 710 ------------------------------- 711 -- Apply_Accessibility_Check -- 712 ------------------------------- 713 714 procedure Apply_Accessibility_Check 715 (Ref : Node_Id; 716 Built_In_Place : Boolean := False) 717 is 718 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); 719 Cond : Node_Id; 720 Free_Stmt : Node_Id; 721 Obj_Ref : Node_Id; 722 Stmts : List_Id; 723 724 begin 725 if Ada_Version >= Ada_2005 726 and then Is_Class_Wide_Type (DesigT) 727 and then not Scope_Suppress.Suppress (Accessibility_Check) 728 and then 729 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) 730 or else 731 (Is_Class_Wide_Type (Etype (Exp)) 732 and then Scope (PtrT) /= Current_Scope)) 733 and then (Tagged_Type_Expansion or else VM_Target /= No_VM) 734 then 735 -- If the allocator was built in place, Ref is already a reference 736 -- to the access object initialized to the result of the allocator 737 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call 738 -- Remove_Side_Effects for cases where the build-in-place call may 739 -- still be the prefix of the reference (to avoid generating 740 -- duplicate calls). Otherwise, it is the entity associated with 741 -- the object containing the address of the allocated object. 742 743 if Built_In_Place then 744 Remove_Side_Effects (Ref); 745 Obj_Ref := New_Copy (Ref); 746 else 747 Obj_Ref := New_Reference_To (Ref, Loc); 748 end if; 749 750 -- Step 1: Create the object clean up code 751 752 Stmts := New_List; 753 754 -- Create an explicit free statement to clean up the allocated 755 -- object in case the accessibility check fails. Generate: 756 757 -- Free (Obj_Ref); 758 759 Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref)); 760 Set_Storage_Pool (Free_Stmt, Pool_Id); 761 762 Append_To (Stmts, Free_Stmt); 763 764 -- Finalize the object (if applicable), but wrap the call inside 765 -- a block to ensure that the object would still be deallocated in 766 -- case the finalization fails. Generate: 767 768 -- begin 769 -- [Deep_]Finalize (Obj_Ref.all); 770 -- exception 771 -- when others => 772 -- Free (Obj_Ref); 773 -- raise; 774 -- end; 775 776 if Needs_Finalization (DesigT) then 777 Prepend_To (Stmts, 778 Make_Block_Statement (Loc, 779 Handled_Statement_Sequence => 780 Make_Handled_Sequence_Of_Statements (Loc, 781 Statements => New_List ( 782 Make_Final_Call ( 783 Obj_Ref => 784 Make_Explicit_Dereference (Loc, 785 Prefix => New_Copy (Obj_Ref)), 786 Typ => DesigT)), 787 788 Exception_Handlers => New_List ( 789 Make_Exception_Handler (Loc, 790 Exception_Choices => New_List ( 791 Make_Others_Choice (Loc)), 792 Statements => New_List ( 793 New_Copy_Tree (Free_Stmt), 794 Make_Raise_Statement (Loc))))))); 795 end if; 796 797 -- Signal the accessibility failure through a Program_Error 798 799 Append_To (Stmts, 800 Make_Raise_Program_Error (Loc, 801 Condition => New_Reference_To (Standard_True, Loc), 802 Reason => PE_Accessibility_Check_Failed)); 803 804 -- Step 2: Create the accessibility comparison 805 806 -- Generate: 807 -- Ref'Tag 808 809 Obj_Ref := 810 Make_Attribute_Reference (Loc, 811 Prefix => Obj_Ref, 812 Attribute_Name => Name_Tag); 813 814 -- For tagged types, determine the accessibility level by looking 815 -- at the type specific data of the dispatch table. Generate: 816 817 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level 818 819 if Tagged_Type_Expansion then 820 Cond := Build_Get_Access_Level (Loc, Obj_Ref); 821 822 -- Use a runtime call to determine the accessibility level when 823 -- compiling on virtual machine targets. Generate: 824 825 -- Get_Access_Level (Ref'Tag) 826 827 else 828 Cond := 829 Make_Function_Call (Loc, 830 Name => 831 New_Reference_To (RTE (RE_Get_Access_Level), Loc), 832 Parameter_Associations => New_List (Obj_Ref)); 833 end if; 834 835 Cond := 836 Make_Op_Gt (Loc, 837 Left_Opnd => Cond, 838 Right_Opnd => 839 Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); 840 841 -- Due to the complexity and side effects of the check, utilize an 842 -- if statement instead of the regular Program_Error circuitry. 843 844 Insert_Action (N, 845 Make_If_Statement (Loc, 846 Condition => Cond, 847 Then_Statements => Stmts)); 848 end if; 849 end Apply_Accessibility_Check; 850 851 -- Local variables 852 853 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); 854 Indic : constant Node_Id := Subtype_Mark (Expression (N)); 855 T : constant Entity_Id := Entity (Indic); 856 Node : Node_Id; 857 Tag_Assign : Node_Id; 858 Temp : Entity_Id; 859 Temp_Decl : Node_Id; 860 861 TagT : Entity_Id := Empty; 862 -- Type used as source for tag assignment 863 864 TagR : Node_Id := Empty; 865 -- Target reference for tag assignment 866 867 -- Start of processing for Expand_Allocator_Expression 868 869 begin 870 -- Handle call to C++ constructor 871 872 if Is_CPP_Constructor_Call (Exp) then 873 Make_CPP_Constructor_Call_In_Allocator 874 (Allocator => N, 875 Function_Call => Exp); 876 return; 877 end if; 878 879 -- In the case of an Ada 2012 allocator whose initial value comes from a 880 -- function call, pass "the accessibility level determined by the point 881 -- of call" (AI05-0234) to the function. Conceptually, this belongs in 882 -- Expand_Call but it couldn't be done there (because the Etype of the 883 -- allocator wasn't set then) so we generate the parameter here. See 884 -- the Boolean variable Defer in (a block within) Expand_Call. 885 886 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then 887 declare 888 Subp : Entity_Id; 889 890 begin 891 if Nkind (Name (Exp)) = N_Explicit_Dereference then 892 Subp := Designated_Type (Etype (Prefix (Name (Exp)))); 893 else 894 Subp := Entity (Name (Exp)); 895 end if; 896 897 Subp := Ultimate_Alias (Subp); 898 899 if Present (Extra_Accessibility_Of_Result (Subp)) then 900 Add_Extra_Actual_To_Call 901 (Subprogram_Call => Exp, 902 Extra_Formal => Extra_Accessibility_Of_Result (Subp), 903 Extra_Actual => Dynamic_Accessibility_Level (PtrT)); 904 end if; 905 end; 906 end if; 907 908 -- Case of tagged type or type requiring finalization 909 910 if Is_Tagged_Type (T) or else Needs_Finalization (T) then 911 912 -- Ada 2005 (AI-318-02): If the initialization expression is a call 913 -- to a build-in-place function, then access to the allocated object 914 -- must be passed to the function. Currently we limit such functions 915 -- to those with constrained limited result subtypes, but eventually 916 -- we plan to expand the allowed forms of functions that are treated 917 -- as build-in-place. 918 919 if Ada_Version >= Ada_2005 920 and then Is_Build_In_Place_Function_Call (Exp) 921 then 922 Make_Build_In_Place_Call_In_Allocator (N, Exp); 923 Apply_Accessibility_Check (N, Built_In_Place => True); 924 return; 925 end if; 926 927 -- Actions inserted before: 928 -- Temp : constant ptr_T := new T'(Expression); 929 -- Temp._tag = T'tag; -- when not class-wide 930 -- [Deep_]Adjust (Temp.all); 931 932 -- We analyze by hand the new internal allocator to avoid any 933 -- recursion and inappropriate call to Initialize 934 935 -- We don't want to remove side effects when the expression must be 936 -- built in place. In the case of a build-in-place function call, 937 -- that could lead to a duplication of the call, which was already 938 -- substituted for the allocator. 939 940 if not Aggr_In_Place then 941 Remove_Side_Effects (Exp); 942 end if; 943 944 Temp := Make_Temporary (Loc, 'P', N); 945 946 -- For a class wide allocation generate the following code: 947 948 -- type Equiv_Record is record ... end record; 949 -- implicit subtype CW is <Class_Wide_Subytpe>; 950 -- temp : PtrT := new CW'(CW!(expr)); 951 952 if Is_Class_Wide_Type (T) then 953 Expand_Subtype_From_Expr (Empty, T, Indic, Exp); 954 955 -- Ada 2005 (AI-251): If the expression is a class-wide interface 956 -- object we generate code to move up "this" to reference the 957 -- base of the object before allocating the new object. 958 959 -- Note that Exp'Address is recursively expanded into a call 960 -- to Base_Address (Exp.Tag) 961 962 if Is_Class_Wide_Type (Etype (Exp)) 963 and then Is_Interface (Etype (Exp)) 964 and then Tagged_Type_Expansion 965 then 966 Set_Expression 967 (Expression (N), 968 Unchecked_Convert_To (Entity (Indic), 969 Make_Explicit_Dereference (Loc, 970 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 971 Make_Attribute_Reference (Loc, 972 Prefix => Exp, 973 Attribute_Name => Name_Address))))); 974 else 975 Set_Expression 976 (Expression (N), 977 Unchecked_Convert_To (Entity (Indic), Exp)); 978 end if; 979 980 Analyze_And_Resolve (Expression (N), Entity (Indic)); 981 end if; 982 983 -- Processing for allocators returning non-interface types 984 985 if not Is_Interface (Directly_Designated_Type (PtrT)) then 986 if Aggr_In_Place then 987 Temp_Decl := 988 Make_Object_Declaration (Loc, 989 Defining_Identifier => Temp, 990 Object_Definition => New_Reference_To (PtrT, Loc), 991 Expression => 992 Make_Allocator (Loc, 993 Expression => 994 New_Reference_To (Etype (Exp), Loc))); 995 996 -- Copy the Comes_From_Source flag for the allocator we just 997 -- built, since logically this allocator is a replacement of 998 -- the original allocator node. This is for proper handling of 999 -- restriction No_Implicit_Heap_Allocations. 1000 1001 Set_Comes_From_Source 1002 (Expression (Temp_Decl), Comes_From_Source (N)); 1003 1004 Set_No_Initialization (Expression (Temp_Decl)); 1005 Insert_Action (N, Temp_Decl); 1006 1007 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1008 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1009 1010 -- Attach the object to the associated finalization master. 1011 -- This is done manually on .NET/JVM since those compilers do 1012 -- no support pools and can't benefit from internally generated 1013 -- Allocate / Deallocate procedures. 1014 1015 if VM_Target /= No_VM 1016 and then Is_Controlled (DesigT) 1017 and then Present (Finalization_Master (PtrT)) 1018 then 1019 Insert_Action (N, 1020 Make_Attach_Call ( 1021 Obj_Ref => 1022 New_Reference_To (Temp, Loc), 1023 Ptr_Typ => PtrT)); 1024 end if; 1025 1026 else 1027 Node := Relocate_Node (N); 1028 Set_Analyzed (Node); 1029 1030 Temp_Decl := 1031 Make_Object_Declaration (Loc, 1032 Defining_Identifier => Temp, 1033 Constant_Present => True, 1034 Object_Definition => New_Reference_To (PtrT, Loc), 1035 Expression => Node); 1036 1037 Insert_Action (N, Temp_Decl); 1038 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1039 1040 -- Attach the object to the associated finalization master. 1041 -- This is done manually on .NET/JVM since those compilers do 1042 -- no support pools and can't benefit from internally generated 1043 -- Allocate / Deallocate procedures. 1044 1045 if VM_Target /= No_VM 1046 and then Is_Controlled (DesigT) 1047 and then Present (Finalization_Master (PtrT)) 1048 then 1049 Insert_Action (N, 1050 Make_Attach_Call ( 1051 Obj_Ref => 1052 New_Reference_To (Temp, Loc), 1053 Ptr_Typ => PtrT)); 1054 end if; 1055 end if; 1056 1057 -- Ada 2005 (AI-251): Handle allocators whose designated type is an 1058 -- interface type. In this case we use the type of the qualified 1059 -- expression to allocate the object. 1060 1061 else 1062 declare 1063 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 1064 New_Decl : Node_Id; 1065 1066 begin 1067 New_Decl := 1068 Make_Full_Type_Declaration (Loc, 1069 Defining_Identifier => Def_Id, 1070 Type_Definition => 1071 Make_Access_To_Object_Definition (Loc, 1072 All_Present => True, 1073 Null_Exclusion_Present => False, 1074 Constant_Present => 1075 Is_Access_Constant (Etype (N)), 1076 Subtype_Indication => 1077 New_Reference_To (Etype (Exp), Loc))); 1078 1079 Insert_Action (N, New_Decl); 1080 1081 -- Inherit the allocation-related attributes from the original 1082 -- access type. 1083 1084 Set_Finalization_Master (Def_Id, Finalization_Master (PtrT)); 1085 1086 Set_Associated_Storage_Pool (Def_Id, 1087 Associated_Storage_Pool (PtrT)); 1088 1089 -- Declare the object using the previous type declaration 1090 1091 if Aggr_In_Place then 1092 Temp_Decl := 1093 Make_Object_Declaration (Loc, 1094 Defining_Identifier => Temp, 1095 Object_Definition => New_Reference_To (Def_Id, Loc), 1096 Expression => 1097 Make_Allocator (Loc, 1098 New_Reference_To (Etype (Exp), Loc))); 1099 1100 -- Copy the Comes_From_Source flag for the allocator we just 1101 -- built, since logically this allocator is a replacement of 1102 -- the original allocator node. This is for proper handling 1103 -- of restriction No_Implicit_Heap_Allocations. 1104 1105 Set_Comes_From_Source 1106 (Expression (Temp_Decl), Comes_From_Source (N)); 1107 1108 Set_No_Initialization (Expression (Temp_Decl)); 1109 Insert_Action (N, Temp_Decl); 1110 1111 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1112 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1113 1114 else 1115 Node := Relocate_Node (N); 1116 Set_Analyzed (Node); 1117 1118 Temp_Decl := 1119 Make_Object_Declaration (Loc, 1120 Defining_Identifier => Temp, 1121 Constant_Present => True, 1122 Object_Definition => New_Reference_To (Def_Id, Loc), 1123 Expression => Node); 1124 1125 Insert_Action (N, Temp_Decl); 1126 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1127 end if; 1128 1129 -- Generate an additional object containing the address of the 1130 -- returned object. The type of this second object declaration 1131 -- is the correct type required for the common processing that 1132 -- is still performed by this subprogram. The displacement of 1133 -- this pointer to reference the component associated with the 1134 -- interface type will be done at the end of common processing. 1135 1136 New_Decl := 1137 Make_Object_Declaration (Loc, 1138 Defining_Identifier => Make_Temporary (Loc, 'P'), 1139 Object_Definition => New_Reference_To (PtrT, Loc), 1140 Expression => 1141 Unchecked_Convert_To (PtrT, 1142 New_Reference_To (Temp, Loc))); 1143 1144 Insert_Action (N, New_Decl); 1145 1146 Temp_Decl := New_Decl; 1147 Temp := Defining_Identifier (New_Decl); 1148 end; 1149 end if; 1150 1151 Apply_Accessibility_Check (Temp); 1152 1153 -- Generate the tag assignment 1154 1155 -- Suppress the tag assignment when VM_Target because VM tags are 1156 -- represented implicitly in objects. 1157 1158 if not Tagged_Type_Expansion then 1159 null; 1160 1161 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide 1162 -- interface objects because in this case the tag does not change. 1163 1164 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then 1165 pragma Assert (Is_Class_Wide_Type 1166 (Directly_Designated_Type (Etype (N)))); 1167 null; 1168 1169 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then 1170 TagT := T; 1171 TagR := New_Reference_To (Temp, Loc); 1172 1173 elsif Is_Private_Type (T) 1174 and then Is_Tagged_Type (Underlying_Type (T)) 1175 then 1176 TagT := Underlying_Type (T); 1177 TagR := 1178 Unchecked_Convert_To (Underlying_Type (T), 1179 Make_Explicit_Dereference (Loc, 1180 Prefix => New_Reference_To (Temp, Loc))); 1181 end if; 1182 1183 if Present (TagT) then 1184 declare 1185 Full_T : constant Entity_Id := Underlying_Type (TagT); 1186 begin 1187 Tag_Assign := 1188 Make_Assignment_Statement (Loc, 1189 Name => 1190 Make_Selected_Component (Loc, 1191 Prefix => TagR, 1192 Selector_Name => 1193 New_Reference_To (First_Tag_Component (Full_T), Loc)), 1194 Expression => 1195 Unchecked_Convert_To (RTE (RE_Tag), 1196 New_Reference_To 1197 (Elists.Node 1198 (First_Elmt (Access_Disp_Table (Full_T))), Loc))); 1199 end; 1200 1201 -- The previous assignment has to be done in any case 1202 1203 Set_Assignment_OK (Name (Tag_Assign)); 1204 Insert_Action (N, Tag_Assign); 1205 end if; 1206 1207 if Needs_Finalization (DesigT) 1208 and then Needs_Finalization (T) 1209 then 1210 -- Generate an Adjust call if the object will be moved. In Ada 1211 -- 2005, the object may be inherently limited, in which case 1212 -- there is no Adjust procedure, and the object is built in 1213 -- place. In Ada 95, the object can be limited but not 1214 -- inherently limited if this allocator came from a return 1215 -- statement (we're allocating the result on the secondary 1216 -- stack). In that case, the object will be moved, so we _do_ 1217 -- want to Adjust. 1218 1219 if not Aggr_In_Place 1220 and then not Is_Immutably_Limited_Type (T) 1221 then 1222 Insert_Action (N, 1223 Make_Adjust_Call ( 1224 Obj_Ref => 1225 1226 -- An unchecked conversion is needed in the classwide 1227 -- case because the designated type can be an ancestor 1228 -- of the subtype mark of the allocator. 1229 1230 Unchecked_Convert_To (T, 1231 Make_Explicit_Dereference (Loc, 1232 Prefix => New_Reference_To (Temp, Loc))), 1233 Typ => T)); 1234 end if; 1235 1236 -- Generate: 1237 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access); 1238 1239 -- Do not generate this call in the following cases: 1240 1241 -- * .NET/JVM - these targets do not support address arithmetic 1242 -- and unchecked conversion, key elements of Finalize_Address. 1243 1244 -- * Alfa mode - the call is useless and results in unwanted 1245 -- expansion. 1246 1247 -- * CodePeer mode - TSS primitive Finalize_Address is not 1248 -- created in this mode. 1249 1250 if VM_Target = No_VM 1251 and then not Alfa_Mode 1252 and then not CodePeer_Mode 1253 and then Present (Finalization_Master (PtrT)) 1254 and then Present (Temp_Decl) 1255 and then Nkind (Expression (Temp_Decl)) = N_Allocator 1256 then 1257 Insert_Action (N, 1258 Make_Set_Finalize_Address_Call 1259 (Loc => Loc, 1260 Typ => T, 1261 Ptr_Typ => PtrT)); 1262 end if; 1263 end if; 1264 1265 Rewrite (N, New_Reference_To (Temp, Loc)); 1266 Analyze_And_Resolve (N, PtrT); 1267 1268 -- Ada 2005 (AI-251): Displace the pointer to reference the record 1269 -- component containing the secondary dispatch table of the interface 1270 -- type. 1271 1272 if Is_Interface (Directly_Designated_Type (PtrT)) then 1273 Displace_Allocator_Pointer (N); 1274 end if; 1275 1276 elsif Aggr_In_Place then 1277 Temp := Make_Temporary (Loc, 'P', N); 1278 Temp_Decl := 1279 Make_Object_Declaration (Loc, 1280 Defining_Identifier => Temp, 1281 Object_Definition => New_Reference_To (PtrT, Loc), 1282 Expression => 1283 Make_Allocator (Loc, 1284 Expression => New_Reference_To (Etype (Exp), Loc))); 1285 1286 -- Copy the Comes_From_Source flag for the allocator we just built, 1287 -- since logically this allocator is a replacement of the original 1288 -- allocator node. This is for proper handling of restriction 1289 -- No_Implicit_Heap_Allocations. 1290 1291 Set_Comes_From_Source 1292 (Expression (Temp_Decl), Comes_From_Source (N)); 1293 1294 Set_No_Initialization (Expression (Temp_Decl)); 1295 Insert_Action (N, Temp_Decl); 1296 1297 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1298 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1299 1300 -- Attach the object to the associated finalization master. Thisis 1301 -- done manually on .NET/JVM since those compilers do no support 1302 -- pools and cannot benefit from internally generated Allocate and 1303 -- Deallocate procedures. 1304 1305 if VM_Target /= No_VM 1306 and then Is_Controlled (DesigT) 1307 and then Present (Finalization_Master (PtrT)) 1308 then 1309 Insert_Action (N, 1310 Make_Attach_Call 1311 (Obj_Ref => New_Reference_To (Temp, Loc), 1312 Ptr_Typ => PtrT)); 1313 end if; 1314 1315 Rewrite (N, New_Reference_To (Temp, Loc)); 1316 Analyze_And_Resolve (N, PtrT); 1317 1318 elsif Is_Access_Type (T) 1319 and then Can_Never_Be_Null (T) 1320 then 1321 Install_Null_Excluding_Check (Exp); 1322 1323 elsif Is_Access_Type (DesigT) 1324 and then Nkind (Exp) = N_Allocator 1325 and then Nkind (Expression (Exp)) /= N_Qualified_Expression 1326 then 1327 -- Apply constraint to designated subtype indication 1328 1329 Apply_Constraint_Check (Expression (Exp), 1330 Designated_Type (DesigT), 1331 No_Sliding => True); 1332 1333 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then 1334 1335 -- Propagate constraint_error to enclosing allocator 1336 1337 Rewrite (Exp, New_Copy (Expression (Exp))); 1338 end if; 1339 1340 else 1341 Build_Allocate_Deallocate_Proc (N, True); 1342 1343 -- If we have: 1344 -- type A is access T1; 1345 -- X : A := new T2'(...); 1346 -- T1 and T2 can be different subtypes, and we might need to check 1347 -- both constraints. First check against the type of the qualified 1348 -- expression. 1349 1350 Apply_Constraint_Check (Exp, T, No_Sliding => True); 1351 1352 if Do_Range_Check (Exp) then 1353 Set_Do_Range_Check (Exp, False); 1354 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 1355 end if; 1356 1357 -- A check is also needed in cases where the designated subtype is 1358 -- constrained and differs from the subtype given in the qualified 1359 -- expression. Note that the check on the qualified expression does 1360 -- not allow sliding, but this check does (a relaxation from Ada 83). 1361 1362 if Is_Constrained (DesigT) 1363 and then not Subtypes_Statically_Match (T, DesigT) 1364 then 1365 Apply_Constraint_Check 1366 (Exp, DesigT, No_Sliding => False); 1367 1368 if Do_Range_Check (Exp) then 1369 Set_Do_Range_Check (Exp, False); 1370 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 1371 end if; 1372 end if; 1373 1374 -- For an access to unconstrained packed array, GIGI needs to see an 1375 -- expression with a constrained subtype in order to compute the 1376 -- proper size for the allocator. 1377 1378 if Is_Array_Type (T) 1379 and then not Is_Constrained (T) 1380 and then Is_Packed (T) 1381 then 1382 declare 1383 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); 1384 Internal_Exp : constant Node_Id := Relocate_Node (Exp); 1385 begin 1386 Insert_Action (Exp, 1387 Make_Subtype_Declaration (Loc, 1388 Defining_Identifier => ConstrT, 1389 Subtype_Indication => 1390 Make_Subtype_From_Expr (Internal_Exp, T))); 1391 Freeze_Itype (ConstrT, Exp); 1392 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); 1393 end; 1394 end if; 1395 1396 -- Ada 2005 (AI-318-02): If the initialization expression is a call 1397 -- to a build-in-place function, then access to the allocated object 1398 -- must be passed to the function. Currently we limit such functions 1399 -- to those with constrained limited result subtypes, but eventually 1400 -- we plan to expand the allowed forms of functions that are treated 1401 -- as build-in-place. 1402 1403 if Ada_Version >= Ada_2005 1404 and then Is_Build_In_Place_Function_Call (Exp) 1405 then 1406 Make_Build_In_Place_Call_In_Allocator (N, Exp); 1407 end if; 1408 end if; 1409 1410 exception 1411 when RE_Not_Available => 1412 return; 1413 end Expand_Allocator_Expression; 1414 1415 ----------------------------- 1416 -- Expand_Array_Comparison -- 1417 ----------------------------- 1418 1419 -- Expansion is only required in the case of array types. For the unpacked 1420 -- case, an appropriate runtime routine is called. For packed cases, and 1421 -- also in some other cases where a runtime routine cannot be called, the 1422 -- form of the expansion is: 1423 1424 -- [body for greater_nn; boolean_expression] 1425 1426 -- The body is built by Make_Array_Comparison_Op, and the form of the 1427 -- Boolean expression depends on the operator involved. 1428 1429 procedure Expand_Array_Comparison (N : Node_Id) is 1430 Loc : constant Source_Ptr := Sloc (N); 1431 Op1 : Node_Id := Left_Opnd (N); 1432 Op2 : Node_Id := Right_Opnd (N); 1433 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 1434 Ctyp : constant Entity_Id := Component_Type (Typ1); 1435 1436 Expr : Node_Id; 1437 Func_Body : Node_Id; 1438 Func_Name : Entity_Id; 1439 1440 Comp : RE_Id; 1441 1442 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; 1443 -- True for byte addressable target 1444 1445 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; 1446 -- Returns True if the length of the given operand is known to be less 1447 -- than 4. Returns False if this length is known to be four or greater 1448 -- or is not known at compile time. 1449 1450 ------------------------ 1451 -- Length_Less_Than_4 -- 1452 ------------------------ 1453 1454 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is 1455 Otyp : constant Entity_Id := Etype (Opnd); 1456 1457 begin 1458 if Ekind (Otyp) = E_String_Literal_Subtype then 1459 return String_Literal_Length (Otyp) < 4; 1460 1461 else 1462 declare 1463 Ityp : constant Entity_Id := Etype (First_Index (Otyp)); 1464 Lo : constant Node_Id := Type_Low_Bound (Ityp); 1465 Hi : constant Node_Id := Type_High_Bound (Ityp); 1466 Lov : Uint; 1467 Hiv : Uint; 1468 1469 begin 1470 if Compile_Time_Known_Value (Lo) then 1471 Lov := Expr_Value (Lo); 1472 else 1473 return False; 1474 end if; 1475 1476 if Compile_Time_Known_Value (Hi) then 1477 Hiv := Expr_Value (Hi); 1478 else 1479 return False; 1480 end if; 1481 1482 return Hiv < Lov + 3; 1483 end; 1484 end if; 1485 end Length_Less_Than_4; 1486 1487 -- Start of processing for Expand_Array_Comparison 1488 1489 begin 1490 -- Deal first with unpacked case, where we can call a runtime routine 1491 -- except that we avoid this for targets for which are not addressable 1492 -- by bytes, and for the JVM/CIL, since they do not support direct 1493 -- addressing of array components. 1494 1495 if not Is_Bit_Packed_Array (Typ1) 1496 and then Byte_Addressable 1497 and then VM_Target = No_VM 1498 then 1499 -- The call we generate is: 1500 1501 -- Compare_Array_xn[_Unaligned] 1502 -- (left'address, right'address, left'length, right'length) <op> 0 1503 1504 -- x = U for unsigned, S for signed 1505 -- n = 8,16,32,64 for component size 1506 -- Add _Unaligned if length < 4 and component size is 8. 1507 -- <op> is the standard comparison operator 1508 1509 if Component_Size (Typ1) = 8 then 1510 if Length_Less_Than_4 (Op1) 1511 or else 1512 Length_Less_Than_4 (Op2) 1513 then 1514 if Is_Unsigned_Type (Ctyp) then 1515 Comp := RE_Compare_Array_U8_Unaligned; 1516 else 1517 Comp := RE_Compare_Array_S8_Unaligned; 1518 end if; 1519 1520 else 1521 if Is_Unsigned_Type (Ctyp) then 1522 Comp := RE_Compare_Array_U8; 1523 else 1524 Comp := RE_Compare_Array_S8; 1525 end if; 1526 end if; 1527 1528 elsif Component_Size (Typ1) = 16 then 1529 if Is_Unsigned_Type (Ctyp) then 1530 Comp := RE_Compare_Array_U16; 1531 else 1532 Comp := RE_Compare_Array_S16; 1533 end if; 1534 1535 elsif Component_Size (Typ1) = 32 then 1536 if Is_Unsigned_Type (Ctyp) then 1537 Comp := RE_Compare_Array_U32; 1538 else 1539 Comp := RE_Compare_Array_S32; 1540 end if; 1541 1542 else pragma Assert (Component_Size (Typ1) = 64); 1543 if Is_Unsigned_Type (Ctyp) then 1544 Comp := RE_Compare_Array_U64; 1545 else 1546 Comp := RE_Compare_Array_S64; 1547 end if; 1548 end if; 1549 1550 Remove_Side_Effects (Op1, Name_Req => True); 1551 Remove_Side_Effects (Op2, Name_Req => True); 1552 1553 Rewrite (Op1, 1554 Make_Function_Call (Sloc (Op1), 1555 Name => New_Occurrence_Of (RTE (Comp), Loc), 1556 1557 Parameter_Associations => New_List ( 1558 Make_Attribute_Reference (Loc, 1559 Prefix => Relocate_Node (Op1), 1560 Attribute_Name => Name_Address), 1561 1562 Make_Attribute_Reference (Loc, 1563 Prefix => Relocate_Node (Op2), 1564 Attribute_Name => Name_Address), 1565 1566 Make_Attribute_Reference (Loc, 1567 Prefix => Relocate_Node (Op1), 1568 Attribute_Name => Name_Length), 1569 1570 Make_Attribute_Reference (Loc, 1571 Prefix => Relocate_Node (Op2), 1572 Attribute_Name => Name_Length)))); 1573 1574 Rewrite (Op2, 1575 Make_Integer_Literal (Sloc (Op2), 1576 Intval => Uint_0)); 1577 1578 Analyze_And_Resolve (Op1, Standard_Integer); 1579 Analyze_And_Resolve (Op2, Standard_Integer); 1580 return; 1581 end if; 1582 1583 -- Cases where we cannot make runtime call 1584 1585 -- For (a <= b) we convert to not (a > b) 1586 1587 if Chars (N) = Name_Op_Le then 1588 Rewrite (N, 1589 Make_Op_Not (Loc, 1590 Right_Opnd => 1591 Make_Op_Gt (Loc, 1592 Left_Opnd => Op1, 1593 Right_Opnd => Op2))); 1594 Analyze_And_Resolve (N, Standard_Boolean); 1595 return; 1596 1597 -- For < the Boolean expression is 1598 -- greater__nn (op2, op1) 1599 1600 elsif Chars (N) = Name_Op_Lt then 1601 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1602 1603 -- Switch operands 1604 1605 Op1 := Right_Opnd (N); 1606 Op2 := Left_Opnd (N); 1607 1608 -- For (a >= b) we convert to not (a < b) 1609 1610 elsif Chars (N) = Name_Op_Ge then 1611 Rewrite (N, 1612 Make_Op_Not (Loc, 1613 Right_Opnd => 1614 Make_Op_Lt (Loc, 1615 Left_Opnd => Op1, 1616 Right_Opnd => Op2))); 1617 Analyze_And_Resolve (N, Standard_Boolean); 1618 return; 1619 1620 -- For > the Boolean expression is 1621 -- greater__nn (op1, op2) 1622 1623 else 1624 pragma Assert (Chars (N) = Name_Op_Gt); 1625 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1626 end if; 1627 1628 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 1629 Expr := 1630 Make_Function_Call (Loc, 1631 Name => New_Reference_To (Func_Name, Loc), 1632 Parameter_Associations => New_List (Op1, Op2)); 1633 1634 Insert_Action (N, Func_Body); 1635 Rewrite (N, Expr); 1636 Analyze_And_Resolve (N, Standard_Boolean); 1637 1638 exception 1639 when RE_Not_Available => 1640 return; 1641 end Expand_Array_Comparison; 1642 1643 --------------------------- 1644 -- Expand_Array_Equality -- 1645 --------------------------- 1646 1647 -- Expand an equality function for multi-dimensional arrays. Here is an 1648 -- example of such a function for Nb_Dimension = 2 1649 1650 -- function Enn (A : atyp; B : btyp) return boolean is 1651 -- begin 1652 -- if (A'length (1) = 0 or else A'length (2) = 0) 1653 -- and then 1654 -- (B'length (1) = 0 or else B'length (2) = 0) 1655 -- then 1656 -- return True; -- RM 4.5.2(22) 1657 -- end if; 1658 1659 -- if A'length (1) /= B'length (1) 1660 -- or else 1661 -- A'length (2) /= B'length (2) 1662 -- then 1663 -- return False; -- RM 4.5.2(23) 1664 -- end if; 1665 1666 -- declare 1667 -- A1 : Index_T1 := A'first (1); 1668 -- B1 : Index_T1 := B'first (1); 1669 -- begin 1670 -- loop 1671 -- declare 1672 -- A2 : Index_T2 := A'first (2); 1673 -- B2 : Index_T2 := B'first (2); 1674 -- begin 1675 -- loop 1676 -- if A (A1, A2) /= B (B1, B2) then 1677 -- return False; 1678 -- end if; 1679 1680 -- exit when A2 = A'last (2); 1681 -- A2 := Index_T2'succ (A2); 1682 -- B2 := Index_T2'succ (B2); 1683 -- end loop; 1684 -- end; 1685 1686 -- exit when A1 = A'last (1); 1687 -- A1 := Index_T1'succ (A1); 1688 -- B1 := Index_T1'succ (B1); 1689 -- end loop; 1690 -- end; 1691 1692 -- return true; 1693 -- end Enn; 1694 1695 -- Note on the formal types used (atyp and btyp). If either of the arrays 1696 -- is of a private type, we use the underlying type, and do an unchecked 1697 -- conversion of the actual. If either of the arrays has a bound depending 1698 -- on a discriminant, then we use the base type since otherwise we have an 1699 -- escaped discriminant in the function. 1700 1701 -- If both arrays are constrained and have the same bounds, we can generate 1702 -- a loop with an explicit iteration scheme using a 'Range attribute over 1703 -- the first array. 1704 1705 function Expand_Array_Equality 1706 (Nod : Node_Id; 1707 Lhs : Node_Id; 1708 Rhs : Node_Id; 1709 Bodies : List_Id; 1710 Typ : Entity_Id) return Node_Id 1711 is 1712 Loc : constant Source_Ptr := Sloc (Nod); 1713 Decls : constant List_Id := New_List; 1714 Index_List1 : constant List_Id := New_List; 1715 Index_List2 : constant List_Id := New_List; 1716 1717 Actuals : List_Id; 1718 Formals : List_Id; 1719 Func_Name : Entity_Id; 1720 Func_Body : Node_Id; 1721 1722 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 1723 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 1724 1725 Ltyp : Entity_Id; 1726 Rtyp : Entity_Id; 1727 -- The parameter types to be used for the formals 1728 1729 function Arr_Attr 1730 (Arr : Entity_Id; 1731 Nam : Name_Id; 1732 Num : Int) return Node_Id; 1733 -- This builds the attribute reference Arr'Nam (Expr) 1734 1735 function Component_Equality (Typ : Entity_Id) return Node_Id; 1736 -- Create one statement to compare corresponding components, designated 1737 -- by a full set of indexes. 1738 1739 function Get_Arg_Type (N : Node_Id) return Entity_Id; 1740 -- Given one of the arguments, computes the appropriate type to be used 1741 -- for that argument in the corresponding function formal 1742 1743 function Handle_One_Dimension 1744 (N : Int; 1745 Index : Node_Id) return Node_Id; 1746 -- This procedure returns the following code 1747 -- 1748 -- declare 1749 -- Bn : Index_T := B'First (N); 1750 -- begin 1751 -- loop 1752 -- xxx 1753 -- exit when An = A'Last (N); 1754 -- An := Index_T'Succ (An) 1755 -- Bn := Index_T'Succ (Bn) 1756 -- end loop; 1757 -- end; 1758 -- 1759 -- If both indexes are constrained and identical, the procedure 1760 -- returns a simpler loop: 1761 -- 1762 -- for An in A'Range (N) loop 1763 -- xxx 1764 -- end loop 1765 -- 1766 -- N is the dimension for which we are generating a loop. Index is the 1767 -- N'th index node, whose Etype is Index_Type_n in the above code. The 1768 -- xxx statement is either the loop or declare for the next dimension 1769 -- or if this is the last dimension the comparison of corresponding 1770 -- components of the arrays. 1771 -- 1772 -- The actual way the code works is to return the comparison of 1773 -- corresponding components for the N+1 call. That's neater! 1774 1775 function Test_Empty_Arrays return Node_Id; 1776 -- This function constructs the test for both arrays being empty 1777 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) 1778 -- and then 1779 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) 1780 1781 function Test_Lengths_Correspond return Node_Id; 1782 -- This function constructs the test for arrays having different lengths 1783 -- in at least one index position, in which case the resulting code is: 1784 1785 -- A'length (1) /= B'length (1) 1786 -- or else 1787 -- A'length (2) /= B'length (2) 1788 -- or else 1789 -- ... 1790 1791 -------------- 1792 -- Arr_Attr -- 1793 -------------- 1794 1795 function Arr_Attr 1796 (Arr : Entity_Id; 1797 Nam : Name_Id; 1798 Num : Int) return Node_Id 1799 is 1800 begin 1801 return 1802 Make_Attribute_Reference (Loc, 1803 Attribute_Name => Nam, 1804 Prefix => New_Reference_To (Arr, Loc), 1805 Expressions => New_List (Make_Integer_Literal (Loc, Num))); 1806 end Arr_Attr; 1807 1808 ------------------------ 1809 -- Component_Equality -- 1810 ------------------------ 1811 1812 function Component_Equality (Typ : Entity_Id) return Node_Id is 1813 Test : Node_Id; 1814 L, R : Node_Id; 1815 1816 begin 1817 -- if a(i1...) /= b(j1...) then return false; end if; 1818 1819 L := 1820 Make_Indexed_Component (Loc, 1821 Prefix => Make_Identifier (Loc, Chars (A)), 1822 Expressions => Index_List1); 1823 1824 R := 1825 Make_Indexed_Component (Loc, 1826 Prefix => Make_Identifier (Loc, Chars (B)), 1827 Expressions => Index_List2); 1828 1829 Test := Expand_Composite_Equality 1830 (Nod, Component_Type (Typ), L, R, Decls); 1831 1832 -- If some (sub)component is an unchecked_union, the whole operation 1833 -- will raise program error. 1834 1835 if Nkind (Test) = N_Raise_Program_Error then 1836 1837 -- This node is going to be inserted at a location where a 1838 -- statement is expected: clear its Etype so analysis will set 1839 -- it to the expected Standard_Void_Type. 1840 1841 Set_Etype (Test, Empty); 1842 return Test; 1843 1844 else 1845 return 1846 Make_Implicit_If_Statement (Nod, 1847 Condition => Make_Op_Not (Loc, Right_Opnd => Test), 1848 Then_Statements => New_List ( 1849 Make_Simple_Return_Statement (Loc, 1850 Expression => New_Occurrence_Of (Standard_False, Loc)))); 1851 end if; 1852 end Component_Equality; 1853 1854 ------------------ 1855 -- Get_Arg_Type -- 1856 ------------------ 1857 1858 function Get_Arg_Type (N : Node_Id) return Entity_Id is 1859 T : Entity_Id; 1860 X : Node_Id; 1861 1862 begin 1863 T := Etype (N); 1864 1865 if No (T) then 1866 return Typ; 1867 1868 else 1869 T := Underlying_Type (T); 1870 1871 X := First_Index (T); 1872 while Present (X) loop 1873 if Denotes_Discriminant (Type_Low_Bound (Etype (X))) 1874 or else 1875 Denotes_Discriminant (Type_High_Bound (Etype (X))) 1876 then 1877 T := Base_Type (T); 1878 exit; 1879 end if; 1880 1881 Next_Index (X); 1882 end loop; 1883 1884 return T; 1885 end if; 1886 end Get_Arg_Type; 1887 1888 -------------------------- 1889 -- Handle_One_Dimension -- 1890 --------------------------- 1891 1892 function Handle_One_Dimension 1893 (N : Int; 1894 Index : Node_Id) return Node_Id 1895 is 1896 Need_Separate_Indexes : constant Boolean := 1897 Ltyp /= Rtyp 1898 or else not Is_Constrained (Ltyp); 1899 -- If the index types are identical, and we are working with 1900 -- constrained types, then we can use the same index for both 1901 -- of the arrays. 1902 1903 An : constant Entity_Id := Make_Temporary (Loc, 'A'); 1904 1905 Bn : Entity_Id; 1906 Index_T : Entity_Id; 1907 Stm_List : List_Id; 1908 Loop_Stm : Node_Id; 1909 1910 begin 1911 if N > Number_Dimensions (Ltyp) then 1912 return Component_Equality (Ltyp); 1913 end if; 1914 1915 -- Case where we generate a loop 1916 1917 Index_T := Base_Type (Etype (Index)); 1918 1919 if Need_Separate_Indexes then 1920 Bn := Make_Temporary (Loc, 'B'); 1921 else 1922 Bn := An; 1923 end if; 1924 1925 Append (New_Reference_To (An, Loc), Index_List1); 1926 Append (New_Reference_To (Bn, Loc), Index_List2); 1927 1928 Stm_List := New_List ( 1929 Handle_One_Dimension (N + 1, Next_Index (Index))); 1930 1931 if Need_Separate_Indexes then 1932 1933 -- Generate guard for loop, followed by increments of indexes 1934 1935 Append_To (Stm_List, 1936 Make_Exit_Statement (Loc, 1937 Condition => 1938 Make_Op_Eq (Loc, 1939 Left_Opnd => New_Reference_To (An, Loc), 1940 Right_Opnd => Arr_Attr (A, Name_Last, N)))); 1941 1942 Append_To (Stm_List, 1943 Make_Assignment_Statement (Loc, 1944 Name => New_Reference_To (An, Loc), 1945 Expression => 1946 Make_Attribute_Reference (Loc, 1947 Prefix => New_Reference_To (Index_T, Loc), 1948 Attribute_Name => Name_Succ, 1949 Expressions => New_List (New_Reference_To (An, Loc))))); 1950 1951 Append_To (Stm_List, 1952 Make_Assignment_Statement (Loc, 1953 Name => New_Reference_To (Bn, Loc), 1954 Expression => 1955 Make_Attribute_Reference (Loc, 1956 Prefix => New_Reference_To (Index_T, Loc), 1957 Attribute_Name => Name_Succ, 1958 Expressions => New_List (New_Reference_To (Bn, Loc))))); 1959 end if; 1960 1961 -- If separate indexes, we need a declare block for An and Bn, and a 1962 -- loop without an iteration scheme. 1963 1964 if Need_Separate_Indexes then 1965 Loop_Stm := 1966 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); 1967 1968 return 1969 Make_Block_Statement (Loc, 1970 Declarations => New_List ( 1971 Make_Object_Declaration (Loc, 1972 Defining_Identifier => An, 1973 Object_Definition => New_Reference_To (Index_T, Loc), 1974 Expression => Arr_Attr (A, Name_First, N)), 1975 1976 Make_Object_Declaration (Loc, 1977 Defining_Identifier => Bn, 1978 Object_Definition => New_Reference_To (Index_T, Loc), 1979 Expression => Arr_Attr (B, Name_First, N))), 1980 1981 Handled_Statement_Sequence => 1982 Make_Handled_Sequence_Of_Statements (Loc, 1983 Statements => New_List (Loop_Stm))); 1984 1985 -- If no separate indexes, return loop statement with explicit 1986 -- iteration scheme on its own 1987 1988 else 1989 Loop_Stm := 1990 Make_Implicit_Loop_Statement (Nod, 1991 Statements => Stm_List, 1992 Iteration_Scheme => 1993 Make_Iteration_Scheme (Loc, 1994 Loop_Parameter_Specification => 1995 Make_Loop_Parameter_Specification (Loc, 1996 Defining_Identifier => An, 1997 Discrete_Subtype_Definition => 1998 Arr_Attr (A, Name_Range, N)))); 1999 return Loop_Stm; 2000 end if; 2001 end Handle_One_Dimension; 2002 2003 ----------------------- 2004 -- Test_Empty_Arrays -- 2005 ----------------------- 2006 2007 function Test_Empty_Arrays return Node_Id is 2008 Alist : Node_Id; 2009 Blist : Node_Id; 2010 2011 Atest : Node_Id; 2012 Btest : Node_Id; 2013 2014 begin 2015 Alist := Empty; 2016 Blist := Empty; 2017 for J in 1 .. Number_Dimensions (Ltyp) loop 2018 Atest := 2019 Make_Op_Eq (Loc, 2020 Left_Opnd => Arr_Attr (A, Name_Length, J), 2021 Right_Opnd => Make_Integer_Literal (Loc, 0)); 2022 2023 Btest := 2024 Make_Op_Eq (Loc, 2025 Left_Opnd => Arr_Attr (B, Name_Length, J), 2026 Right_Opnd => Make_Integer_Literal (Loc, 0)); 2027 2028 if No (Alist) then 2029 Alist := Atest; 2030 Blist := Btest; 2031 2032 else 2033 Alist := 2034 Make_Or_Else (Loc, 2035 Left_Opnd => Relocate_Node (Alist), 2036 Right_Opnd => Atest); 2037 2038 Blist := 2039 Make_Or_Else (Loc, 2040 Left_Opnd => Relocate_Node (Blist), 2041 Right_Opnd => Btest); 2042 end if; 2043 end loop; 2044 2045 return 2046 Make_And_Then (Loc, 2047 Left_Opnd => Alist, 2048 Right_Opnd => Blist); 2049 end Test_Empty_Arrays; 2050 2051 ----------------------------- 2052 -- Test_Lengths_Correspond -- 2053 ----------------------------- 2054 2055 function Test_Lengths_Correspond return Node_Id is 2056 Result : Node_Id; 2057 Rtest : Node_Id; 2058 2059 begin 2060 Result := Empty; 2061 for J in 1 .. Number_Dimensions (Ltyp) loop 2062 Rtest := 2063 Make_Op_Ne (Loc, 2064 Left_Opnd => Arr_Attr (A, Name_Length, J), 2065 Right_Opnd => Arr_Attr (B, Name_Length, J)); 2066 2067 if No (Result) then 2068 Result := Rtest; 2069 else 2070 Result := 2071 Make_Or_Else (Loc, 2072 Left_Opnd => Relocate_Node (Result), 2073 Right_Opnd => Rtest); 2074 end if; 2075 end loop; 2076 2077 return Result; 2078 end Test_Lengths_Correspond; 2079 2080 -- Start of processing for Expand_Array_Equality 2081 2082 begin 2083 Ltyp := Get_Arg_Type (Lhs); 2084 Rtyp := Get_Arg_Type (Rhs); 2085 2086 -- For now, if the argument types are not the same, go to the base type, 2087 -- since the code assumes that the formals have the same type. This is 2088 -- fixable in future ??? 2089 2090 if Ltyp /= Rtyp then 2091 Ltyp := Base_Type (Ltyp); 2092 Rtyp := Base_Type (Rtyp); 2093 pragma Assert (Ltyp = Rtyp); 2094 end if; 2095 2096 -- Build list of formals for function 2097 2098 Formals := New_List ( 2099 Make_Parameter_Specification (Loc, 2100 Defining_Identifier => A, 2101 Parameter_Type => New_Reference_To (Ltyp, Loc)), 2102 2103 Make_Parameter_Specification (Loc, 2104 Defining_Identifier => B, 2105 Parameter_Type => New_Reference_To (Rtyp, Loc))); 2106 2107 Func_Name := Make_Temporary (Loc, 'E'); 2108 2109 -- Build statement sequence for function 2110 2111 Func_Body := 2112 Make_Subprogram_Body (Loc, 2113 Specification => 2114 Make_Function_Specification (Loc, 2115 Defining_Unit_Name => Func_Name, 2116 Parameter_Specifications => Formals, 2117 Result_Definition => New_Reference_To (Standard_Boolean, Loc)), 2118 2119 Declarations => Decls, 2120 2121 Handled_Statement_Sequence => 2122 Make_Handled_Sequence_Of_Statements (Loc, 2123 Statements => New_List ( 2124 2125 Make_Implicit_If_Statement (Nod, 2126 Condition => Test_Empty_Arrays, 2127 Then_Statements => New_List ( 2128 Make_Simple_Return_Statement (Loc, 2129 Expression => 2130 New_Occurrence_Of (Standard_True, Loc)))), 2131 2132 Make_Implicit_If_Statement (Nod, 2133 Condition => Test_Lengths_Correspond, 2134 Then_Statements => New_List ( 2135 Make_Simple_Return_Statement (Loc, 2136 Expression => 2137 New_Occurrence_Of (Standard_False, Loc)))), 2138 2139 Handle_One_Dimension (1, First_Index (Ltyp)), 2140 2141 Make_Simple_Return_Statement (Loc, 2142 Expression => New_Occurrence_Of (Standard_True, Loc))))); 2143 2144 Set_Has_Completion (Func_Name, True); 2145 Set_Is_Inlined (Func_Name); 2146 2147 -- If the array type is distinct from the type of the arguments, it 2148 -- is the full view of a private type. Apply an unchecked conversion 2149 -- to insure that analysis of the call succeeds. 2150 2151 declare 2152 L, R : Node_Id; 2153 2154 begin 2155 L := Lhs; 2156 R := Rhs; 2157 2158 if No (Etype (Lhs)) 2159 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp) 2160 then 2161 L := OK_Convert_To (Ltyp, Lhs); 2162 end if; 2163 2164 if No (Etype (Rhs)) 2165 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp) 2166 then 2167 R := OK_Convert_To (Rtyp, Rhs); 2168 end if; 2169 2170 Actuals := New_List (L, R); 2171 end; 2172 2173 Append_To (Bodies, Func_Body); 2174 2175 return 2176 Make_Function_Call (Loc, 2177 Name => New_Reference_To (Func_Name, Loc), 2178 Parameter_Associations => Actuals); 2179 end Expand_Array_Equality; 2180 2181 ----------------------------- 2182 -- Expand_Boolean_Operator -- 2183 ----------------------------- 2184 2185 -- Note that we first get the actual subtypes of the operands, since we 2186 -- always want to deal with types that have bounds. 2187 2188 procedure Expand_Boolean_Operator (N : Node_Id) is 2189 Typ : constant Entity_Id := Etype (N); 2190 2191 begin 2192 -- Special case of bit packed array where both operands are known to be 2193 -- properly aligned. In this case we use an efficient run time routine 2194 -- to carry out the operation (see System.Bit_Ops). 2195 2196 if Is_Bit_Packed_Array (Typ) 2197 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) 2198 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 2199 then 2200 Expand_Packed_Boolean_Operator (N); 2201 return; 2202 end if; 2203 2204 -- For the normal non-packed case, the general expansion is to build 2205 -- function for carrying out the comparison (use Make_Boolean_Array_Op) 2206 -- and then inserting it into the tree. The original operator node is 2207 -- then rewritten as a call to this function. We also use this in the 2208 -- packed case if either operand is a possibly unaligned object. 2209 2210 declare 2211 Loc : constant Source_Ptr := Sloc (N); 2212 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 2213 R : constant Node_Id := Relocate_Node (Right_Opnd (N)); 2214 Func_Body : Node_Id; 2215 Func_Name : Entity_Id; 2216 2217 begin 2218 Convert_To_Actual_Subtype (L); 2219 Convert_To_Actual_Subtype (R); 2220 Ensure_Defined (Etype (L), N); 2221 Ensure_Defined (Etype (R), N); 2222 Apply_Length_Check (R, Etype (L)); 2223 2224 if Nkind (N) = N_Op_Xor then 2225 Silly_Boolean_Array_Xor_Test (N, Etype (L)); 2226 end if; 2227 2228 if Nkind (Parent (N)) = N_Assignment_Statement 2229 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) 2230 then 2231 Build_Boolean_Array_Proc_Call (Parent (N), L, R); 2232 2233 elsif Nkind (Parent (N)) = N_Op_Not 2234 and then Nkind (N) = N_Op_And 2235 and then 2236 Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) 2237 then 2238 return; 2239 else 2240 2241 Func_Body := Make_Boolean_Array_Op (Etype (L), N); 2242 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 2243 Insert_Action (N, Func_Body); 2244 2245 -- Now rewrite the expression with a call 2246 2247 Rewrite (N, 2248 Make_Function_Call (Loc, 2249 Name => New_Reference_To (Func_Name, Loc), 2250 Parameter_Associations => 2251 New_List ( 2252 L, 2253 Make_Type_Conversion 2254 (Loc, New_Reference_To (Etype (L), Loc), R)))); 2255 2256 Analyze_And_Resolve (N, Typ); 2257 end if; 2258 end; 2259 end Expand_Boolean_Operator; 2260 2261 ------------------------------------------------ 2262 -- Expand_Compare_Minimize_Eliminate_Overflow -- 2263 ------------------------------------------------ 2264 2265 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is 2266 Loc : constant Source_Ptr := Sloc (N); 2267 2268 Result_Type : constant Entity_Id := Etype (N); 2269 -- Capture result type (could be a derived boolean type) 2270 2271 Llo, Lhi : Uint; 2272 Rlo, Rhi : Uint; 2273 2274 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 2275 -- Entity for Long_Long_Integer'Base 2276 2277 Check : constant Overflow_Mode_Type := Overflow_Check_Mode; 2278 -- Current overflow checking mode 2279 2280 procedure Set_True; 2281 procedure Set_False; 2282 -- These procedures rewrite N with an occurrence of Standard_True or 2283 -- Standard_False, and then makes a call to Warn_On_Known_Condition. 2284 2285 --------------- 2286 -- Set_False -- 2287 --------------- 2288 2289 procedure Set_False is 2290 begin 2291 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 2292 Warn_On_Known_Condition (N); 2293 end Set_False; 2294 2295 -------------- 2296 -- Set_True -- 2297 -------------- 2298 2299 procedure Set_True is 2300 begin 2301 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 2302 Warn_On_Known_Condition (N); 2303 end Set_True; 2304 2305 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow 2306 2307 begin 2308 -- Nothing to do unless we have a comparison operator with operands 2309 -- that are signed integer types, and we are operating in either 2310 -- MINIMIZED or ELIMINATED overflow checking mode. 2311 2312 if Nkind (N) not in N_Op_Compare 2313 or else Check not in Minimized_Or_Eliminated 2314 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N))) 2315 then 2316 return; 2317 end if; 2318 2319 -- OK, this is the case we are interested in. First step is to process 2320 -- our operands using the Minimize_Eliminate circuitry which applies 2321 -- this processing to the two operand subtrees. 2322 2323 Minimize_Eliminate_Overflows 2324 (Left_Opnd (N), Llo, Lhi, Top_Level => False); 2325 Minimize_Eliminate_Overflows 2326 (Right_Opnd (N), Rlo, Rhi, Top_Level => False); 2327 2328 -- See if the range information decides the result of the comparison. 2329 -- We can only do this if we in fact have full range information (which 2330 -- won't be the case if either operand is bignum at this stage). 2331 2332 if Llo /= No_Uint and then Rlo /= No_Uint then 2333 case N_Op_Compare (Nkind (N)) is 2334 when N_Op_Eq => 2335 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2336 Set_True; 2337 elsif Llo > Rhi or else Lhi < Rlo then 2338 Set_False; 2339 end if; 2340 2341 when N_Op_Ge => 2342 if Llo >= Rhi then 2343 Set_True; 2344 elsif Lhi < Rlo then 2345 Set_False; 2346 end if; 2347 2348 when N_Op_Gt => 2349 if Llo > Rhi then 2350 Set_True; 2351 elsif Lhi <= Rlo then 2352 Set_False; 2353 end if; 2354 2355 when N_Op_Le => 2356 if Llo > Rhi then 2357 Set_False; 2358 elsif Lhi <= Rlo then 2359 Set_True; 2360 end if; 2361 2362 when N_Op_Lt => 2363 if Llo >= Rhi then 2364 Set_False; 2365 elsif Lhi < Rlo then 2366 Set_True; 2367 end if; 2368 2369 when N_Op_Ne => 2370 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2371 Set_False; 2372 elsif Llo > Rhi or else Lhi < Rlo then 2373 Set_True; 2374 end if; 2375 end case; 2376 2377 -- All done if we did the rewrite 2378 2379 if Nkind (N) not in N_Op_Compare then 2380 return; 2381 end if; 2382 end if; 2383 2384 -- Otherwise, time to do the comparison 2385 2386 declare 2387 Ltype : constant Entity_Id := Etype (Left_Opnd (N)); 2388 Rtype : constant Entity_Id := Etype (Right_Opnd (N)); 2389 2390 begin 2391 -- If the two operands have the same signed integer type we are 2392 -- all set, nothing more to do. This is the case where either 2393 -- both operands were unchanged, or we rewrote both of them to 2394 -- be Long_Long_Integer. 2395 2396 -- Note: Entity for the comparison may be wrong, but it's not worth 2397 -- the effort to change it, since the back end does not use it. 2398 2399 if Is_Signed_Integer_Type (Ltype) 2400 and then Base_Type (Ltype) = Base_Type (Rtype) 2401 then 2402 return; 2403 2404 -- Here if bignums are involved (can only happen in ELIMINATED mode) 2405 2406 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then 2407 declare 2408 Left : Node_Id := Left_Opnd (N); 2409 Right : Node_Id := Right_Opnd (N); 2410 -- Bignum references for left and right operands 2411 2412 begin 2413 if not Is_RTE (Ltype, RE_Bignum) then 2414 Left := Convert_To_Bignum (Left); 2415 elsif not Is_RTE (Rtype, RE_Bignum) then 2416 Right := Convert_To_Bignum (Right); 2417 end if; 2418 2419 -- We rewrite our node with: 2420 2421 -- do 2422 -- Bnn : Result_Type; 2423 -- declare 2424 -- M : Mark_Id := SS_Mark; 2425 -- begin 2426 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc) 2427 -- SS_Release (M); 2428 -- end; 2429 -- in 2430 -- Bnn 2431 -- end 2432 2433 declare 2434 Blk : constant Node_Id := Make_Bignum_Block (Loc); 2435 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 2436 Ent : RE_Id; 2437 2438 begin 2439 case N_Op_Compare (Nkind (N)) is 2440 when N_Op_Eq => Ent := RE_Big_EQ; 2441 when N_Op_Ge => Ent := RE_Big_GE; 2442 when N_Op_Gt => Ent := RE_Big_GT; 2443 when N_Op_Le => Ent := RE_Big_LE; 2444 when N_Op_Lt => Ent := RE_Big_LT; 2445 when N_Op_Ne => Ent := RE_Big_NE; 2446 end case; 2447 2448 -- Insert assignment to Bnn into the bignum block 2449 2450 Insert_Before 2451 (First (Statements (Handled_Statement_Sequence (Blk))), 2452 Make_Assignment_Statement (Loc, 2453 Name => New_Occurrence_Of (Bnn, Loc), 2454 Expression => 2455 Make_Function_Call (Loc, 2456 Name => 2457 New_Occurrence_Of (RTE (Ent), Loc), 2458 Parameter_Associations => New_List (Left, Right)))); 2459 2460 -- Now do the rewrite with expression actions 2461 2462 Rewrite (N, 2463 Make_Expression_With_Actions (Loc, 2464 Actions => New_List ( 2465 Make_Object_Declaration (Loc, 2466 Defining_Identifier => Bnn, 2467 Object_Definition => 2468 New_Occurrence_Of (Result_Type, Loc)), 2469 Blk), 2470 Expression => New_Occurrence_Of (Bnn, Loc))); 2471 Analyze_And_Resolve (N, Result_Type); 2472 end; 2473 end; 2474 2475 -- No bignums involved, but types are different, so we must have 2476 -- rewritten one of the operands as a Long_Long_Integer but not 2477 -- the other one. 2478 2479 -- If left operand is Long_Long_Integer, convert right operand 2480 -- and we are done (with a comparison of two Long_Long_Integers). 2481 2482 elsif Ltype = LLIB then 2483 Convert_To_And_Rewrite (LLIB, Right_Opnd (N)); 2484 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks); 2485 return; 2486 2487 -- If right operand is Long_Long_Integer, convert left operand 2488 -- and we are done (with a comparison of two Long_Long_Integers). 2489 2490 -- This is the only remaining possibility 2491 2492 else pragma Assert (Rtype = LLIB); 2493 Convert_To_And_Rewrite (LLIB, Left_Opnd (N)); 2494 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks); 2495 return; 2496 end if; 2497 end; 2498 end Expand_Compare_Minimize_Eliminate_Overflow; 2499 2500 ------------------------------- 2501 -- Expand_Composite_Equality -- 2502 ------------------------------- 2503 2504 -- This function is only called for comparing internal fields of composite 2505 -- types when these fields are themselves composites. This is a special 2506 -- case because it is not possible to respect normal Ada visibility rules. 2507 2508 function Expand_Composite_Equality 2509 (Nod : Node_Id; 2510 Typ : Entity_Id; 2511 Lhs : Node_Id; 2512 Rhs : Node_Id; 2513 Bodies : List_Id) return Node_Id 2514 is 2515 Loc : constant Source_Ptr := Sloc (Nod); 2516 Full_Type : Entity_Id; 2517 Prim : Elmt_Id; 2518 Eq_Op : Entity_Id; 2519 2520 function Find_Primitive_Eq return Node_Id; 2521 -- AI05-0123: Locate primitive equality for type if it exists, and 2522 -- build the corresponding call. If operation is abstract, replace 2523 -- call with an explicit raise. Return Empty if there is no primitive. 2524 2525 ----------------------- 2526 -- Find_Primitive_Eq -- 2527 ----------------------- 2528 2529 function Find_Primitive_Eq return Node_Id is 2530 Prim_E : Elmt_Id; 2531 Prim : Node_Id; 2532 2533 begin 2534 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); 2535 while Present (Prim_E) loop 2536 Prim := Node (Prim_E); 2537 2538 -- Locate primitive equality with the right signature 2539 2540 if Chars (Prim) = Name_Op_Eq 2541 and then Etype (First_Formal (Prim)) = 2542 Etype (Next_Formal (First_Formal (Prim))) 2543 and then Etype (Prim) = Standard_Boolean 2544 then 2545 if Is_Abstract_Subprogram (Prim) then 2546 return 2547 Make_Raise_Program_Error (Loc, 2548 Reason => PE_Explicit_Raise); 2549 2550 else 2551 return 2552 Make_Function_Call (Loc, 2553 Name => New_Reference_To (Prim, Loc), 2554 Parameter_Associations => New_List (Lhs, Rhs)); 2555 end if; 2556 end if; 2557 2558 Next_Elmt (Prim_E); 2559 end loop; 2560 2561 -- If not found, predefined operation will be used 2562 2563 return Empty; 2564 end Find_Primitive_Eq; 2565 2566 -- Start of processing for Expand_Composite_Equality 2567 2568 begin 2569 if Is_Private_Type (Typ) then 2570 Full_Type := Underlying_Type (Typ); 2571 else 2572 Full_Type := Typ; 2573 end if; 2574 2575 -- Defense against malformed private types with no completion the error 2576 -- will be diagnosed later by check_completion 2577 2578 if No (Full_Type) then 2579 return New_Reference_To (Standard_False, Loc); 2580 end if; 2581 2582 Full_Type := Base_Type (Full_Type); 2583 2584 if Is_Array_Type (Full_Type) then 2585 2586 -- If the operand is an elementary type other than a floating-point 2587 -- type, then we can simply use the built-in block bitwise equality, 2588 -- since the predefined equality operators always apply and bitwise 2589 -- equality is fine for all these cases. 2590 2591 if Is_Elementary_Type (Component_Type (Full_Type)) 2592 and then not Is_Floating_Point_Type (Component_Type (Full_Type)) 2593 then 2594 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2595 2596 -- For composite component types, and floating-point types, use the 2597 -- expansion. This deals with tagged component types (where we use 2598 -- the applicable equality routine) and floating-point, (where we 2599 -- need to worry about negative zeroes), and also the case of any 2600 -- composite type recursively containing such fields. 2601 2602 else 2603 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type); 2604 end if; 2605 2606 elsif Is_Tagged_Type (Full_Type) then 2607 2608 -- Call the primitive operation "=" of this type 2609 2610 if Is_Class_Wide_Type (Full_Type) then 2611 Full_Type := Root_Type (Full_Type); 2612 end if; 2613 2614 -- If this is derived from an untagged private type completed with a 2615 -- tagged type, it does not have a full view, so we use the primitive 2616 -- operations of the private type. This check should no longer be 2617 -- necessary when these types receive their full views ??? 2618 2619 if Is_Private_Type (Typ) 2620 and then not Is_Tagged_Type (Typ) 2621 and then not Is_Controlled (Typ) 2622 and then Is_Derived_Type (Typ) 2623 and then No (Full_View (Typ)) 2624 then 2625 Prim := First_Elmt (Collect_Primitive_Operations (Typ)); 2626 else 2627 Prim := First_Elmt (Primitive_Operations (Full_Type)); 2628 end if; 2629 2630 loop 2631 Eq_Op := Node (Prim); 2632 exit when Chars (Eq_Op) = Name_Op_Eq 2633 and then Etype (First_Formal (Eq_Op)) = 2634 Etype (Next_Formal (First_Formal (Eq_Op))) 2635 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean; 2636 Next_Elmt (Prim); 2637 pragma Assert (Present (Prim)); 2638 end loop; 2639 2640 Eq_Op := Node (Prim); 2641 2642 return 2643 Make_Function_Call (Loc, 2644 Name => New_Reference_To (Eq_Op, Loc), 2645 Parameter_Associations => 2646 New_List 2647 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), 2648 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); 2649 2650 elsif Is_Record_Type (Full_Type) then 2651 Eq_Op := TSS (Full_Type, TSS_Composite_Equality); 2652 2653 if Present (Eq_Op) then 2654 if Etype (First_Formal (Eq_Op)) /= Full_Type then 2655 2656 -- Inherited equality from parent type. Convert the actuals to 2657 -- match signature of operation. 2658 2659 declare 2660 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2661 2662 begin 2663 return 2664 Make_Function_Call (Loc, 2665 Name => New_Reference_To (Eq_Op, Loc), 2666 Parameter_Associations => New_List ( 2667 OK_Convert_To (T, Lhs), 2668 OK_Convert_To (T, Rhs))); 2669 end; 2670 2671 else 2672 -- Comparison between Unchecked_Union components 2673 2674 if Is_Unchecked_Union (Full_Type) then 2675 declare 2676 Lhs_Type : Node_Id := Full_Type; 2677 Rhs_Type : Node_Id := Full_Type; 2678 Lhs_Discr_Val : Node_Id; 2679 Rhs_Discr_Val : Node_Id; 2680 2681 begin 2682 -- Lhs subtype 2683 2684 if Nkind (Lhs) = N_Selected_Component then 2685 Lhs_Type := Etype (Entity (Selector_Name (Lhs))); 2686 end if; 2687 2688 -- Rhs subtype 2689 2690 if Nkind (Rhs) = N_Selected_Component then 2691 Rhs_Type := Etype (Entity (Selector_Name (Rhs))); 2692 end if; 2693 2694 -- Lhs of the composite equality 2695 2696 if Is_Constrained (Lhs_Type) then 2697 2698 -- Since the enclosing record type can never be an 2699 -- Unchecked_Union (this code is executed for records 2700 -- that do not have variants), we may reference its 2701 -- discriminant(s). 2702 2703 if Nkind (Lhs) = N_Selected_Component 2704 and then Has_Per_Object_Constraint ( 2705 Entity (Selector_Name (Lhs))) 2706 then 2707 Lhs_Discr_Val := 2708 Make_Selected_Component (Loc, 2709 Prefix => Prefix (Lhs), 2710 Selector_Name => 2711 New_Copy 2712 (Get_Discriminant_Value 2713 (First_Discriminant (Lhs_Type), 2714 Lhs_Type, 2715 Stored_Constraint (Lhs_Type)))); 2716 2717 else 2718 Lhs_Discr_Val := 2719 New_Copy 2720 (Get_Discriminant_Value 2721 (First_Discriminant (Lhs_Type), 2722 Lhs_Type, 2723 Stored_Constraint (Lhs_Type))); 2724 2725 end if; 2726 else 2727 -- It is not possible to infer the discriminant since 2728 -- the subtype is not constrained. 2729 2730 return 2731 Make_Raise_Program_Error (Loc, 2732 Reason => PE_Unchecked_Union_Restriction); 2733 end if; 2734 2735 -- Rhs of the composite equality 2736 2737 if Is_Constrained (Rhs_Type) then 2738 if Nkind (Rhs) = N_Selected_Component 2739 and then Has_Per_Object_Constraint 2740 (Entity (Selector_Name (Rhs))) 2741 then 2742 Rhs_Discr_Val := 2743 Make_Selected_Component (Loc, 2744 Prefix => Prefix (Rhs), 2745 Selector_Name => 2746 New_Copy 2747 (Get_Discriminant_Value 2748 (First_Discriminant (Rhs_Type), 2749 Rhs_Type, 2750 Stored_Constraint (Rhs_Type)))); 2751 2752 else 2753 Rhs_Discr_Val := 2754 New_Copy 2755 (Get_Discriminant_Value 2756 (First_Discriminant (Rhs_Type), 2757 Rhs_Type, 2758 Stored_Constraint (Rhs_Type))); 2759 2760 end if; 2761 else 2762 return 2763 Make_Raise_Program_Error (Loc, 2764 Reason => PE_Unchecked_Union_Restriction); 2765 end if; 2766 2767 -- Call the TSS equality function with the inferred 2768 -- discriminant values. 2769 2770 return 2771 Make_Function_Call (Loc, 2772 Name => New_Reference_To (Eq_Op, Loc), 2773 Parameter_Associations => New_List ( 2774 Lhs, 2775 Rhs, 2776 Lhs_Discr_Val, 2777 Rhs_Discr_Val)); 2778 end; 2779 2780 else 2781 return 2782 Make_Function_Call (Loc, 2783 Name => New_Reference_To (Eq_Op, Loc), 2784 Parameter_Associations => New_List (Lhs, Rhs)); 2785 end if; 2786 end if; 2787 2788 -- Equality composes in Ada 2012 for untagged record types. It also 2789 -- composes for bounded strings, because they are part of the 2790 -- predefined environment. We could make it compose for bounded 2791 -- strings by making them tagged, or by making sure all subcomponents 2792 -- are set to the same value, even when not used. Instead, we have 2793 -- this special case in the compiler, because it's more efficient. 2794 2795 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then 2796 2797 -- if no TSS has been created for the type, check whether there is 2798 -- a primitive equality declared for it. 2799 2800 declare 2801 Op : constant Node_Id := Find_Primitive_Eq; 2802 2803 begin 2804 -- Use user-defined primitive if it exists, otherwise use 2805 -- predefined equality. 2806 2807 if Present (Op) then 2808 return Op; 2809 else 2810 return Make_Op_Eq (Loc, Lhs, Rhs); 2811 end if; 2812 end; 2813 2814 else 2815 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); 2816 end if; 2817 2818 else 2819 -- If not array or record type, it is predefined equality. 2820 2821 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2822 end if; 2823 end Expand_Composite_Equality; 2824 2825 ------------------------ 2826 -- Expand_Concatenate -- 2827 ------------------------ 2828 2829 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is 2830 Loc : constant Source_Ptr := Sloc (Cnode); 2831 2832 Atyp : constant Entity_Id := Base_Type (Etype (Cnode)); 2833 -- Result type of concatenation 2834 2835 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode))); 2836 -- Component type. Elements of this component type can appear as one 2837 -- of the operands of concatenation as well as arrays. 2838 2839 Istyp : constant Entity_Id := Etype (First_Index (Atyp)); 2840 -- Index subtype 2841 2842 Ityp : constant Entity_Id := Base_Type (Istyp); 2843 -- Index type. This is the base type of the index subtype, and is used 2844 -- for all computed bounds (which may be out of range of Istyp in the 2845 -- case of null ranges). 2846 2847 Artyp : Entity_Id; 2848 -- This is the type we use to do arithmetic to compute the bounds and 2849 -- lengths of operands. The choice of this type is a little subtle and 2850 -- is discussed in a separate section at the start of the body code. 2851 2852 Concatenation_Error : exception; 2853 -- Raised if concatenation is sure to raise a CE 2854 2855 Result_May_Be_Null : Boolean := True; 2856 -- Reset to False if at least one operand is encountered which is known 2857 -- at compile time to be non-null. Used for handling the special case 2858 -- of setting the high bound to the last operand high bound for a null 2859 -- result, thus ensuring a proper high bound in the super-flat case. 2860 2861 N : constant Nat := List_Length (Opnds); 2862 -- Number of concatenation operands including possibly null operands 2863 2864 NN : Nat := 0; 2865 -- Number of operands excluding any known to be null, except that the 2866 -- last operand is always retained, in case it provides the bounds for 2867 -- a null result. 2868 2869 Opnd : Node_Id; 2870 -- Current operand being processed in the loop through operands. After 2871 -- this loop is complete, always contains the last operand (which is not 2872 -- the same as Operands (NN), since null operands are skipped). 2873 2874 -- Arrays describing the operands, only the first NN entries of each 2875 -- array are set (NN < N when we exclude known null operands). 2876 2877 Is_Fixed_Length : array (1 .. N) of Boolean; 2878 -- True if length of corresponding operand known at compile time 2879 2880 Operands : array (1 .. N) of Node_Id; 2881 -- Set to the corresponding entry in the Opnds list (but note that null 2882 -- operands are excluded, so not all entries in the list are stored). 2883 2884 Fixed_Length : array (1 .. N) of Uint; 2885 -- Set to length of operand. Entries in this array are set only if the 2886 -- corresponding entry in Is_Fixed_Length is True. 2887 2888 Opnd_Low_Bound : array (1 .. N) of Node_Id; 2889 -- Set to lower bound of operand. Either an integer literal in the case 2890 -- where the bound is known at compile time, else actual lower bound. 2891 -- The operand low bound is of type Ityp. 2892 2893 Var_Length : array (1 .. N) of Entity_Id; 2894 -- Set to an entity of type Natural that contains the length of an 2895 -- operand whose length is not known at compile time. Entries in this 2896 -- array are set only if the corresponding entry in Is_Fixed_Length 2897 -- is False. The entity is of type Artyp. 2898 2899 Aggr_Length : array (0 .. N) of Node_Id; 2900 -- The J'th entry in an expression node that represents the total length 2901 -- of operands 1 through J. It is either an integer literal node, or a 2902 -- reference to a constant entity with the right value, so it is fine 2903 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th 2904 -- entry always is set to zero. The length is of type Artyp. 2905 2906 Low_Bound : Node_Id; 2907 -- A tree node representing the low bound of the result (of type Ityp). 2908 -- This is either an integer literal node, or an identifier reference to 2909 -- a constant entity initialized to the appropriate value. 2910 2911 Last_Opnd_Low_Bound : Node_Id; 2912 -- A tree node representing the low bound of the last operand. This 2913 -- need only be set if the result could be null. It is used for the 2914 -- special case of setting the right low bound for a null result. 2915 -- This is of type Ityp. 2916 2917 Last_Opnd_High_Bound : Node_Id; 2918 -- A tree node representing the high bound of the last operand. This 2919 -- need only be set if the result could be null. It is used for the 2920 -- special case of setting the right high bound for a null result. 2921 -- This is of type Ityp. 2922 2923 High_Bound : Node_Id; 2924 -- A tree node representing the high bound of the result (of type Ityp) 2925 2926 Result : Node_Id; 2927 -- Result of the concatenation (of type Ityp) 2928 2929 Actions : constant List_Id := New_List; 2930 -- Collect actions to be inserted 2931 2932 Known_Non_Null_Operand_Seen : Boolean; 2933 -- Set True during generation of the assignments of operands into 2934 -- result once an operand known to be non-null has been seen. 2935 2936 function Make_Artyp_Literal (Val : Nat) return Node_Id; 2937 -- This function makes an N_Integer_Literal node that is returned in 2938 -- analyzed form with the type set to Artyp. Importantly this literal 2939 -- is not flagged as static, so that if we do computations with it that 2940 -- result in statically detected out of range conditions, we will not 2941 -- generate error messages but instead warning messages. 2942 2943 function To_Artyp (X : Node_Id) return Node_Id; 2944 -- Given a node of type Ityp, returns the corresponding value of type 2945 -- Artyp. For non-enumeration types, this is a plain integer conversion. 2946 -- For enum types, the Pos of the value is returned. 2947 2948 function To_Ityp (X : Node_Id) return Node_Id; 2949 -- The inverse function (uses Val in the case of enumeration types) 2950 2951 ------------------------ 2952 -- Make_Artyp_Literal -- 2953 ------------------------ 2954 2955 function Make_Artyp_Literal (Val : Nat) return Node_Id is 2956 Result : constant Node_Id := Make_Integer_Literal (Loc, Val); 2957 begin 2958 Set_Etype (Result, Artyp); 2959 Set_Analyzed (Result, True); 2960 Set_Is_Static_Expression (Result, False); 2961 return Result; 2962 end Make_Artyp_Literal; 2963 2964 -------------- 2965 -- To_Artyp -- 2966 -------------- 2967 2968 function To_Artyp (X : Node_Id) return Node_Id is 2969 begin 2970 if Ityp = Base_Type (Artyp) then 2971 return X; 2972 2973 elsif Is_Enumeration_Type (Ityp) then 2974 return 2975 Make_Attribute_Reference (Loc, 2976 Prefix => New_Occurrence_Of (Ityp, Loc), 2977 Attribute_Name => Name_Pos, 2978 Expressions => New_List (X)); 2979 2980 else 2981 return Convert_To (Artyp, X); 2982 end if; 2983 end To_Artyp; 2984 2985 ------------- 2986 -- To_Ityp -- 2987 ------------- 2988 2989 function To_Ityp (X : Node_Id) return Node_Id is 2990 begin 2991 if Is_Enumeration_Type (Ityp) then 2992 return 2993 Make_Attribute_Reference (Loc, 2994 Prefix => New_Occurrence_Of (Ityp, Loc), 2995 Attribute_Name => Name_Val, 2996 Expressions => New_List (X)); 2997 2998 -- Case where we will do a type conversion 2999 3000 else 3001 if Ityp = Base_Type (Artyp) then 3002 return X; 3003 else 3004 return Convert_To (Ityp, X); 3005 end if; 3006 end if; 3007 end To_Ityp; 3008 3009 -- Local Declarations 3010 3011 Opnd_Typ : Entity_Id; 3012 Ent : Entity_Id; 3013 Len : Uint; 3014 J : Nat; 3015 Clen : Node_Id; 3016 Set : Boolean; 3017 3018 -- Start of processing for Expand_Concatenate 3019 3020 begin 3021 -- Choose an appropriate computational type 3022 3023 -- We will be doing calculations of lengths and bounds in this routine 3024 -- and computing one from the other in some cases, e.g. getting the high 3025 -- bound by adding the length-1 to the low bound. 3026 3027 -- We can't just use the index type, or even its base type for this 3028 -- purpose for two reasons. First it might be an enumeration type which 3029 -- is not suitable for computations of any kind, and second it may 3030 -- simply not have enough range. For example if the index type is 3031 -- -128..+127 then lengths can be up to 256, which is out of range of 3032 -- the type. 3033 3034 -- For enumeration types, we can simply use Standard_Integer, this is 3035 -- sufficient since the actual number of enumeration literals cannot 3036 -- possibly exceed the range of integer (remember we will be doing the 3037 -- arithmetic with POS values, not representation values). 3038 3039 if Is_Enumeration_Type (Ityp) then 3040 Artyp := Standard_Integer; 3041 3042 -- If index type is Positive, we use the standard unsigned type, to give 3043 -- more room on the top of the range, obviating the need for an overflow 3044 -- check when creating the upper bound. This is needed to avoid junk 3045 -- overflow checks in the common case of String types. 3046 3047 -- ??? Disabled for now 3048 3049 -- elsif Istyp = Standard_Positive then 3050 -- Artyp := Standard_Unsigned; 3051 3052 -- For modular types, we use a 32-bit modular type for types whose size 3053 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the 3054 -- identity type, and for larger unsigned types we use 64-bits. 3055 3056 elsif Is_Modular_Integer_Type (Ityp) then 3057 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then 3058 Artyp := Standard_Unsigned; 3059 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then 3060 Artyp := Ityp; 3061 else 3062 Artyp := RTE (RE_Long_Long_Unsigned); 3063 end if; 3064 3065 -- Similar treatment for signed types 3066 3067 else 3068 if RM_Size (Ityp) < RM_Size (Standard_Integer) then 3069 Artyp := Standard_Integer; 3070 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then 3071 Artyp := Ityp; 3072 else 3073 Artyp := Standard_Long_Long_Integer; 3074 end if; 3075 end if; 3076 3077 -- Supply dummy entry at start of length array 3078 3079 Aggr_Length (0) := Make_Artyp_Literal (0); 3080 3081 -- Go through operands setting up the above arrays 3082 3083 J := 1; 3084 while J <= N loop 3085 Opnd := Remove_Head (Opnds); 3086 Opnd_Typ := Etype (Opnd); 3087 3088 -- The parent got messed up when we put the operands in a list, 3089 -- so now put back the proper parent for the saved operand, that 3090 -- is to say the concatenation node, to make sure that each operand 3091 -- is seen as a subexpression, e.g. if actions must be inserted. 3092 3093 Set_Parent (Opnd, Cnode); 3094 3095 -- Set will be True when we have setup one entry in the array 3096 3097 Set := False; 3098 3099 -- Singleton element (or character literal) case 3100 3101 if Base_Type (Opnd_Typ) = Ctyp then 3102 NN := NN + 1; 3103 Operands (NN) := Opnd; 3104 Is_Fixed_Length (NN) := True; 3105 Fixed_Length (NN) := Uint_1; 3106 Result_May_Be_Null := False; 3107 3108 -- Set low bound of operand (no need to set Last_Opnd_High_Bound 3109 -- since we know that the result cannot be null). 3110 3111 Opnd_Low_Bound (NN) := 3112 Make_Attribute_Reference (Loc, 3113 Prefix => New_Reference_To (Istyp, Loc), 3114 Attribute_Name => Name_First); 3115 3116 Set := True; 3117 3118 -- String literal case (can only occur for strings of course) 3119 3120 elsif Nkind (Opnd) = N_String_Literal then 3121 Len := String_Literal_Length (Opnd_Typ); 3122 3123 if Len /= 0 then 3124 Result_May_Be_Null := False; 3125 end if; 3126 3127 -- Capture last operand low and high bound if result could be null 3128 3129 if J = N and then Result_May_Be_Null then 3130 Last_Opnd_Low_Bound := 3131 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3132 3133 Last_Opnd_High_Bound := 3134 Make_Op_Subtract (Loc, 3135 Left_Opnd => 3136 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), 3137 Right_Opnd => Make_Integer_Literal (Loc, 1)); 3138 end if; 3139 3140 -- Skip null string literal 3141 3142 if J < N and then Len = 0 then 3143 goto Continue; 3144 end if; 3145 3146 NN := NN + 1; 3147 Operands (NN) := Opnd; 3148 Is_Fixed_Length (NN) := True; 3149 3150 -- Set length and bounds 3151 3152 Fixed_Length (NN) := Len; 3153 3154 Opnd_Low_Bound (NN) := 3155 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3156 3157 Set := True; 3158 3159 -- All other cases 3160 3161 else 3162 -- Check constrained case with known bounds 3163 3164 if Is_Constrained (Opnd_Typ) then 3165 declare 3166 Index : constant Node_Id := First_Index (Opnd_Typ); 3167 Indx_Typ : constant Entity_Id := Etype (Index); 3168 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ); 3169 Hi : constant Node_Id := Type_High_Bound (Indx_Typ); 3170 3171 begin 3172 -- Fixed length constrained array type with known at compile 3173 -- time bounds is last case of fixed length operand. 3174 3175 if Compile_Time_Known_Value (Lo) 3176 and then 3177 Compile_Time_Known_Value (Hi) 3178 then 3179 declare 3180 Loval : constant Uint := Expr_Value (Lo); 3181 Hival : constant Uint := Expr_Value (Hi); 3182 Len : constant Uint := 3183 UI_Max (Hival - Loval + 1, Uint_0); 3184 3185 begin 3186 if Len > 0 then 3187 Result_May_Be_Null := False; 3188 end if; 3189 3190 -- Capture last operand bounds if result could be null 3191 3192 if J = N and then Result_May_Be_Null then 3193 Last_Opnd_Low_Bound := 3194 Convert_To (Ityp, 3195 Make_Integer_Literal (Loc, Expr_Value (Lo))); 3196 3197 Last_Opnd_High_Bound := 3198 Convert_To (Ityp, 3199 Make_Integer_Literal (Loc, Expr_Value (Hi))); 3200 end if; 3201 3202 -- Exclude null length case unless last operand 3203 3204 if J < N and then Len = 0 then 3205 goto Continue; 3206 end if; 3207 3208 NN := NN + 1; 3209 Operands (NN) := Opnd; 3210 Is_Fixed_Length (NN) := True; 3211 Fixed_Length (NN) := Len; 3212 3213 Opnd_Low_Bound (NN) := 3214 To_Ityp 3215 (Make_Integer_Literal (Loc, Expr_Value (Lo))); 3216 Set := True; 3217 end; 3218 end if; 3219 end; 3220 end if; 3221 3222 -- All cases where the length is not known at compile time, or the 3223 -- special case of an operand which is known to be null but has a 3224 -- lower bound other than 1 or is other than a string type. 3225 3226 if not Set then 3227 NN := NN + 1; 3228 3229 -- Capture operand bounds 3230 3231 Opnd_Low_Bound (NN) := 3232 Make_Attribute_Reference (Loc, 3233 Prefix => 3234 Duplicate_Subexpr (Opnd, Name_Req => True), 3235 Attribute_Name => Name_First); 3236 Set_Parent (Opnd_Low_Bound (NN), Opnd); 3237 3238 -- Capture last operand bounds if result could be null 3239 3240 if J = N and Result_May_Be_Null then 3241 Last_Opnd_Low_Bound := 3242 Convert_To (Ityp, 3243 Make_Attribute_Reference (Loc, 3244 Prefix => 3245 Duplicate_Subexpr (Opnd, Name_Req => True), 3246 Attribute_Name => Name_First)); 3247 Set_Parent (Last_Opnd_Low_Bound, Opnd); 3248 3249 Last_Opnd_High_Bound := 3250 Convert_To (Ityp, 3251 Make_Attribute_Reference (Loc, 3252 Prefix => 3253 Duplicate_Subexpr (Opnd, Name_Req => True), 3254 Attribute_Name => Name_Last)); 3255 Set_Parent (Last_Opnd_High_Bound, Opnd); 3256 end if; 3257 3258 -- Capture length of operand in entity 3259 3260 Operands (NN) := Opnd; 3261 Is_Fixed_Length (NN) := False; 3262 3263 Var_Length (NN) := Make_Temporary (Loc, 'L'); 3264 3265 Append_To (Actions, 3266 Make_Object_Declaration (Loc, 3267 Defining_Identifier => Var_Length (NN), 3268 Constant_Present => True, 3269 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3270 Expression => 3271 Make_Attribute_Reference (Loc, 3272 Prefix => 3273 Duplicate_Subexpr (Opnd, Name_Req => True), 3274 Attribute_Name => Name_Length))); 3275 end if; 3276 end if; 3277 3278 -- Set next entry in aggregate length array 3279 3280 -- For first entry, make either integer literal for fixed length 3281 -- or a reference to the saved length for variable length. 3282 3283 if NN = 1 then 3284 if Is_Fixed_Length (1) then 3285 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1)); 3286 else 3287 Aggr_Length (1) := New_Reference_To (Var_Length (1), Loc); 3288 end if; 3289 3290 -- If entry is fixed length and only fixed lengths so far, make 3291 -- appropriate new integer literal adding new length. 3292 3293 elsif Is_Fixed_Length (NN) 3294 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal 3295 then 3296 Aggr_Length (NN) := 3297 Make_Integer_Literal (Loc, 3298 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1))); 3299 3300 -- All other cases, construct an addition node for the length and 3301 -- create an entity initialized to this length. 3302 3303 else 3304 Ent := Make_Temporary (Loc, 'L'); 3305 3306 if Is_Fixed_Length (NN) then 3307 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); 3308 else 3309 Clen := New_Reference_To (Var_Length (NN), Loc); 3310 end if; 3311 3312 Append_To (Actions, 3313 Make_Object_Declaration (Loc, 3314 Defining_Identifier => Ent, 3315 Constant_Present => True, 3316 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3317 Expression => 3318 Make_Op_Add (Loc, 3319 Left_Opnd => New_Copy (Aggr_Length (NN - 1)), 3320 Right_Opnd => Clen))); 3321 3322 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent)); 3323 end if; 3324 3325 <<Continue>> 3326 J := J + 1; 3327 end loop; 3328 3329 -- If we have only skipped null operands, return the last operand 3330 3331 if NN = 0 then 3332 Result := Opnd; 3333 goto Done; 3334 end if; 3335 3336 -- If we have only one non-null operand, return it and we are done. 3337 -- There is one case in which this cannot be done, and that is when 3338 -- the sole operand is of the element type, in which case it must be 3339 -- converted to an array, and the easiest way of doing that is to go 3340 -- through the normal general circuit. 3341 3342 if NN = 1 3343 and then Base_Type (Etype (Operands (1))) /= Ctyp 3344 then 3345 Result := Operands (1); 3346 goto Done; 3347 end if; 3348 3349 -- Cases where we have a real concatenation 3350 3351 -- Next step is to find the low bound for the result array that we 3352 -- will allocate. The rules for this are in (RM 4.5.6(5-7)). 3353 3354 -- If the ultimate ancestor of the index subtype is a constrained array 3355 -- definition, then the lower bound is that of the index subtype as 3356 -- specified by (RM 4.5.3(6)). 3357 3358 -- The right test here is to go to the root type, and then the ultimate 3359 -- ancestor is the first subtype of this root type. 3360 3361 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then 3362 Low_Bound := 3363 Make_Attribute_Reference (Loc, 3364 Prefix => 3365 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc), 3366 Attribute_Name => Name_First); 3367 3368 -- If the first operand in the list has known length we know that 3369 -- the lower bound of the result is the lower bound of this operand. 3370 3371 elsif Is_Fixed_Length (1) then 3372 Low_Bound := Opnd_Low_Bound (1); 3373 3374 -- OK, we don't know the lower bound, we have to build a horrible 3375 -- if expression node of the form 3376 3377 -- if Cond1'Length /= 0 then 3378 -- Opnd1 low bound 3379 -- else 3380 -- if Opnd2'Length /= 0 then 3381 -- Opnd2 low bound 3382 -- else 3383 -- ... 3384 3385 -- The nesting ends either when we hit an operand whose length is known 3386 -- at compile time, or on reaching the last operand, whose low bound we 3387 -- take unconditionally whether or not it is null. It's easiest to do 3388 -- this with a recursive procedure: 3389 3390 else 3391 declare 3392 function Get_Known_Bound (J : Nat) return Node_Id; 3393 -- Returns the lower bound determined by operands J .. NN 3394 3395 --------------------- 3396 -- Get_Known_Bound -- 3397 --------------------- 3398 3399 function Get_Known_Bound (J : Nat) return Node_Id is 3400 begin 3401 if Is_Fixed_Length (J) or else J = NN then 3402 return New_Copy (Opnd_Low_Bound (J)); 3403 3404 else 3405 return 3406 Make_If_Expression (Loc, 3407 Expressions => New_List ( 3408 3409 Make_Op_Ne (Loc, 3410 Left_Opnd => New_Reference_To (Var_Length (J), Loc), 3411 Right_Opnd => Make_Integer_Literal (Loc, 0)), 3412 3413 New_Copy (Opnd_Low_Bound (J)), 3414 Get_Known_Bound (J + 1))); 3415 end if; 3416 end Get_Known_Bound; 3417 3418 begin 3419 Ent := Make_Temporary (Loc, 'L'); 3420 3421 Append_To (Actions, 3422 Make_Object_Declaration (Loc, 3423 Defining_Identifier => Ent, 3424 Constant_Present => True, 3425 Object_Definition => New_Occurrence_Of (Ityp, Loc), 3426 Expression => Get_Known_Bound (1))); 3427 3428 Low_Bound := New_Reference_To (Ent, Loc); 3429 end; 3430 end if; 3431 3432 -- Now we can safely compute the upper bound, normally 3433 -- Low_Bound + Length - 1. 3434 3435 High_Bound := 3436 To_Ityp ( 3437 Make_Op_Add (Loc, 3438 Left_Opnd => To_Artyp (New_Copy (Low_Bound)), 3439 Right_Opnd => 3440 Make_Op_Subtract (Loc, 3441 Left_Opnd => New_Copy (Aggr_Length (NN)), 3442 Right_Opnd => Make_Artyp_Literal (1)))); 3443 3444 -- Note that calculation of the high bound may cause overflow in some 3445 -- very weird cases, so in the general case we need an overflow check on 3446 -- the high bound. We can avoid this for the common case of string types 3447 -- and other types whose index is Positive, since we chose a wider range 3448 -- for the arithmetic type. 3449 3450 if Istyp /= Standard_Positive then 3451 Activate_Overflow_Check (High_Bound); 3452 end if; 3453 3454 -- Handle the exceptional case where the result is null, in which case 3455 -- case the bounds come from the last operand (so that we get the proper 3456 -- bounds if the last operand is super-flat). 3457 3458 if Result_May_Be_Null then 3459 Low_Bound := 3460 Make_If_Expression (Loc, 3461 Expressions => New_List ( 3462 Make_Op_Eq (Loc, 3463 Left_Opnd => New_Copy (Aggr_Length (NN)), 3464 Right_Opnd => Make_Artyp_Literal (0)), 3465 Last_Opnd_Low_Bound, 3466 Low_Bound)); 3467 3468 High_Bound := 3469 Make_If_Expression (Loc, 3470 Expressions => New_List ( 3471 Make_Op_Eq (Loc, 3472 Left_Opnd => New_Copy (Aggr_Length (NN)), 3473 Right_Opnd => Make_Artyp_Literal (0)), 3474 Last_Opnd_High_Bound, 3475 High_Bound)); 3476 end if; 3477 3478 -- Here is where we insert the saved up actions 3479 3480 Insert_Actions (Cnode, Actions, Suppress => All_Checks); 3481 3482 -- Now we construct an array object with appropriate bounds. We mark 3483 -- the target as internal to prevent useless initialization when 3484 -- Initialize_Scalars is enabled. Also since this is the actual result 3485 -- entity, we make sure we have debug information for the result. 3486 3487 Ent := Make_Temporary (Loc, 'S'); 3488 Set_Is_Internal (Ent); 3489 Set_Needs_Debug_Info (Ent); 3490 3491 -- If the bound is statically known to be out of range, we do not want 3492 -- to abort, we want a warning and a runtime constraint error. Note that 3493 -- we have arranged that the result will not be treated as a static 3494 -- constant, so we won't get an illegality during this insertion. 3495 3496 Insert_Action (Cnode, 3497 Make_Object_Declaration (Loc, 3498 Defining_Identifier => Ent, 3499 Object_Definition => 3500 Make_Subtype_Indication (Loc, 3501 Subtype_Mark => New_Occurrence_Of (Atyp, Loc), 3502 Constraint => 3503 Make_Index_Or_Discriminant_Constraint (Loc, 3504 Constraints => New_List ( 3505 Make_Range (Loc, 3506 Low_Bound => Low_Bound, 3507 High_Bound => High_Bound))))), 3508 Suppress => All_Checks); 3509 3510 -- If the result of the concatenation appears as the initializing 3511 -- expression of an object declaration, we can just rename the 3512 -- result, rather than copying it. 3513 3514 Set_OK_To_Rename (Ent); 3515 3516 -- Catch the static out of range case now 3517 3518 if Raises_Constraint_Error (High_Bound) then 3519 raise Concatenation_Error; 3520 end if; 3521 3522 -- Now we will generate the assignments to do the actual concatenation 3523 3524 -- There is one case in which we will not do this, namely when all the 3525 -- following conditions are met: 3526 3527 -- The result type is Standard.String 3528 3529 -- There are nine or fewer retained (non-null) operands 3530 3531 -- The optimization level is -O0 3532 3533 -- The corresponding System.Concat_n.Str_Concat_n routine is 3534 -- available in the run time. 3535 3536 -- The debug flag gnatd.c is not set 3537 3538 -- If all these conditions are met then we generate a call to the 3539 -- relevant concatenation routine. The purpose of this is to avoid 3540 -- undesirable code bloat at -O0. 3541 3542 if Atyp = Standard_String 3543 and then NN in 2 .. 9 3544 and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC) 3545 and then not Debug_Flag_Dot_C 3546 then 3547 declare 3548 RR : constant array (Nat range 2 .. 9) of RE_Id := 3549 (RE_Str_Concat_2, 3550 RE_Str_Concat_3, 3551 RE_Str_Concat_4, 3552 RE_Str_Concat_5, 3553 RE_Str_Concat_6, 3554 RE_Str_Concat_7, 3555 RE_Str_Concat_8, 3556 RE_Str_Concat_9); 3557 3558 begin 3559 if RTE_Available (RR (NN)) then 3560 declare 3561 Opnds : constant List_Id := 3562 New_List (New_Occurrence_Of (Ent, Loc)); 3563 3564 begin 3565 for J in 1 .. NN loop 3566 if Is_List_Member (Operands (J)) then 3567 Remove (Operands (J)); 3568 end if; 3569 3570 if Base_Type (Etype (Operands (J))) = Ctyp then 3571 Append_To (Opnds, 3572 Make_Aggregate (Loc, 3573 Component_Associations => New_List ( 3574 Make_Component_Association (Loc, 3575 Choices => New_List ( 3576 Make_Integer_Literal (Loc, 1)), 3577 Expression => Operands (J))))); 3578 3579 else 3580 Append_To (Opnds, Operands (J)); 3581 end if; 3582 end loop; 3583 3584 Insert_Action (Cnode, 3585 Make_Procedure_Call_Statement (Loc, 3586 Name => New_Reference_To (RTE (RR (NN)), Loc), 3587 Parameter_Associations => Opnds)); 3588 3589 Result := New_Reference_To (Ent, Loc); 3590 goto Done; 3591 end; 3592 end if; 3593 end; 3594 end if; 3595 3596 -- Not special case so generate the assignments 3597 3598 Known_Non_Null_Operand_Seen := False; 3599 3600 for J in 1 .. NN loop 3601 declare 3602 Lo : constant Node_Id := 3603 Make_Op_Add (Loc, 3604 Left_Opnd => To_Artyp (New_Copy (Low_Bound)), 3605 Right_Opnd => Aggr_Length (J - 1)); 3606 3607 Hi : constant Node_Id := 3608 Make_Op_Add (Loc, 3609 Left_Opnd => To_Artyp (New_Copy (Low_Bound)), 3610 Right_Opnd => 3611 Make_Op_Subtract (Loc, 3612 Left_Opnd => Aggr_Length (J), 3613 Right_Opnd => Make_Artyp_Literal (1))); 3614 3615 begin 3616 -- Singleton case, simple assignment 3617 3618 if Base_Type (Etype (Operands (J))) = Ctyp then 3619 Known_Non_Null_Operand_Seen := True; 3620 Insert_Action (Cnode, 3621 Make_Assignment_Statement (Loc, 3622 Name => 3623 Make_Indexed_Component (Loc, 3624 Prefix => New_Occurrence_Of (Ent, Loc), 3625 Expressions => New_List (To_Ityp (Lo))), 3626 Expression => Operands (J)), 3627 Suppress => All_Checks); 3628 3629 -- Array case, slice assignment, skipped when argument is fixed 3630 -- length and known to be null. 3631 3632 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then 3633 declare 3634 Assign : Node_Id := 3635 Make_Assignment_Statement (Loc, 3636 Name => 3637 Make_Slice (Loc, 3638 Prefix => 3639 New_Occurrence_Of (Ent, Loc), 3640 Discrete_Range => 3641 Make_Range (Loc, 3642 Low_Bound => To_Ityp (Lo), 3643 High_Bound => To_Ityp (Hi))), 3644 Expression => Operands (J)); 3645 begin 3646 if Is_Fixed_Length (J) then 3647 Known_Non_Null_Operand_Seen := True; 3648 3649 elsif not Known_Non_Null_Operand_Seen then 3650 3651 -- Here if operand length is not statically known and no 3652 -- operand known to be non-null has been processed yet. 3653 -- If operand length is 0, we do not need to perform the 3654 -- assignment, and we must avoid the evaluation of the 3655 -- high bound of the slice, since it may underflow if the 3656 -- low bound is Ityp'First. 3657 3658 Assign := 3659 Make_Implicit_If_Statement (Cnode, 3660 Condition => 3661 Make_Op_Ne (Loc, 3662 Left_Opnd => 3663 New_Occurrence_Of (Var_Length (J), Loc), 3664 Right_Opnd => Make_Integer_Literal (Loc, 0)), 3665 Then_Statements => New_List (Assign)); 3666 end if; 3667 3668 Insert_Action (Cnode, Assign, Suppress => All_Checks); 3669 end; 3670 end if; 3671 end; 3672 end loop; 3673 3674 -- Finally we build the result, which is a reference to the array object 3675 3676 Result := New_Reference_To (Ent, Loc); 3677 3678 <<Done>> 3679 Rewrite (Cnode, Result); 3680 Analyze_And_Resolve (Cnode, Atyp); 3681 3682 exception 3683 when Concatenation_Error => 3684 3685 -- Kill warning generated for the declaration of the static out of 3686 -- range high bound, and instead generate a Constraint_Error with 3687 -- an appropriate specific message. 3688 3689 Kill_Dead_Code (Declaration_Node (Entity (High_Bound))); 3690 Apply_Compile_Time_Constraint_Error 3691 (N => Cnode, 3692 Msg => "concatenation result upper bound out of range??", 3693 Reason => CE_Range_Check_Failed); 3694 end Expand_Concatenate; 3695 3696 --------------------------------------------------- 3697 -- Expand_Membership_Minimize_Eliminate_Overflow -- 3698 --------------------------------------------------- 3699 3700 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is 3701 pragma Assert (Nkind (N) = N_In); 3702 -- Despite the name, this routine applies only to N_In, not to 3703 -- N_Not_In. The latter is always rewritten as not (X in Y). 3704 3705 Result_Type : constant Entity_Id := Etype (N); 3706 -- Capture result type, may be a derived boolean type 3707 3708 Loc : constant Source_Ptr := Sloc (N); 3709 Lop : constant Node_Id := Left_Opnd (N); 3710 Rop : constant Node_Id := Right_Opnd (N); 3711 3712 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It 3713 -- is thus tempting to capture these values, but due to the rewrites 3714 -- that occur as a result of overflow checking, these values change 3715 -- as we go along, and it is safe just to always use Etype explicitly. 3716 3717 Restype : constant Entity_Id := Etype (N); 3718 -- Save result type 3719 3720 Lo, Hi : Uint; 3721 -- Bounds in Minimize calls, not used currently 3722 3723 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 3724 -- Entity for Long_Long_Integer'Base (Standard should export this???) 3725 3726 begin 3727 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False); 3728 3729 -- If right operand is a subtype name, and the subtype name has no 3730 -- predicate, then we can just replace the right operand with an 3731 -- explicit range T'First .. T'Last, and use the explicit range code. 3732 3733 if Nkind (Rop) /= N_Range 3734 and then No (Predicate_Function (Etype (Rop))) 3735 then 3736 declare 3737 Rtyp : constant Entity_Id := Etype (Rop); 3738 begin 3739 Rewrite (Rop, 3740 Make_Range (Loc, 3741 Low_Bound => 3742 Make_Attribute_Reference (Loc, 3743 Attribute_Name => Name_First, 3744 Prefix => New_Reference_To (Rtyp, Loc)), 3745 High_Bound => 3746 Make_Attribute_Reference (Loc, 3747 Attribute_Name => Name_Last, 3748 Prefix => New_Reference_To (Rtyp, Loc)))); 3749 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks); 3750 end; 3751 end if; 3752 3753 -- Here for the explicit range case. Note that the bounds of the range 3754 -- have not been processed for minimized or eliminated checks. 3755 3756 if Nkind (Rop) = N_Range then 3757 Minimize_Eliminate_Overflows 3758 (Low_Bound (Rop), Lo, Hi, Top_Level => False); 3759 Minimize_Eliminate_Overflows 3760 (High_Bound (Rop), Lo, Hi, Top_Level => False); 3761 3762 -- We have A in B .. C, treated as A >= B and then A <= C 3763 3764 -- Bignum case 3765 3766 if Is_RTE (Etype (Lop), RE_Bignum) 3767 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum) 3768 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum) 3769 then 3770 declare 3771 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3772 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3773 L : constant Entity_Id := 3774 Make_Defining_Identifier (Loc, Name_uL); 3775 Lopnd : constant Node_Id := Convert_To_Bignum (Lop); 3776 Lbound : constant Node_Id := 3777 Convert_To_Bignum (Low_Bound (Rop)); 3778 Hbound : constant Node_Id := 3779 Convert_To_Bignum (High_Bound (Rop)); 3780 3781 -- Now we rewrite the membership test node to look like 3782 3783 -- do 3784 -- Bnn : Result_Type; 3785 -- declare 3786 -- M : Mark_Id := SS_Mark; 3787 -- L : Bignum := Lopnd; 3788 -- begin 3789 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound) 3790 -- SS_Release (M); 3791 -- end; 3792 -- in 3793 -- Bnn 3794 -- end 3795 3796 begin 3797 -- Insert declaration of L into declarations of bignum block 3798 3799 Insert_After 3800 (Last (Declarations (Blk)), 3801 Make_Object_Declaration (Loc, 3802 Defining_Identifier => L, 3803 Object_Definition => 3804 New_Occurrence_Of (RTE (RE_Bignum), Loc), 3805 Expression => Lopnd)); 3806 3807 -- Insert assignment to Bnn into expressions of bignum block 3808 3809 Insert_Before 3810 (First (Statements (Handled_Statement_Sequence (Blk))), 3811 Make_Assignment_Statement (Loc, 3812 Name => New_Occurrence_Of (Bnn, Loc), 3813 Expression => 3814 Make_And_Then (Loc, 3815 Left_Opnd => 3816 Make_Function_Call (Loc, 3817 Name => 3818 New_Occurrence_Of (RTE (RE_Big_GE), Loc), 3819 Parameter_Associations => New_List ( 3820 New_Occurrence_Of (L, Loc), 3821 Lbound)), 3822 Right_Opnd => 3823 Make_Function_Call (Loc, 3824 Name => 3825 New_Occurrence_Of (RTE (RE_Big_LE), Loc), 3826 Parameter_Associations => New_List ( 3827 New_Occurrence_Of (L, Loc), 3828 Hbound))))); 3829 3830 -- Now rewrite the node 3831 3832 Rewrite (N, 3833 Make_Expression_With_Actions (Loc, 3834 Actions => New_List ( 3835 Make_Object_Declaration (Loc, 3836 Defining_Identifier => Bnn, 3837 Object_Definition => 3838 New_Occurrence_Of (Result_Type, Loc)), 3839 Blk), 3840 Expression => New_Occurrence_Of (Bnn, Loc))); 3841 Analyze_And_Resolve (N, Result_Type); 3842 return; 3843 end; 3844 3845 -- Here if no bignums around 3846 3847 else 3848 -- Case where types are all the same 3849 3850 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop))) 3851 and then 3852 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop))) 3853 then 3854 null; 3855 3856 -- If types are not all the same, it means that we have rewritten 3857 -- at least one of them to be of type Long_Long_Integer, and we 3858 -- will convert the other operands to Long_Long_Integer. 3859 3860 else 3861 Convert_To_And_Rewrite (LLIB, Lop); 3862 Set_Analyzed (Lop, False); 3863 Analyze_And_Resolve (Lop, LLIB); 3864 3865 -- For the right operand, avoid unnecessary recursion into 3866 -- this routine, we know that overflow is not possible. 3867 3868 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop)); 3869 Convert_To_And_Rewrite (LLIB, High_Bound (Rop)); 3870 Set_Analyzed (Rop, False); 3871 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check); 3872 end if; 3873 3874 -- Now the three operands are of the same signed integer type, 3875 -- so we can use the normal expansion routine for membership, 3876 -- setting the flag to prevent recursion into this procedure. 3877 3878 Set_No_Minimize_Eliminate (N); 3879 Expand_N_In (N); 3880 end if; 3881 3882 -- Right operand is a subtype name and the subtype has a predicate. We 3883 -- have to make sure the predicate is checked, and for that we need to 3884 -- use the standard N_In circuitry with appropriate types. 3885 3886 else 3887 pragma Assert (Present (Predicate_Function (Etype (Rop)))); 3888 3889 -- If types are "right", just call Expand_N_In preventing recursion 3890 3891 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then 3892 Set_No_Minimize_Eliminate (N); 3893 Expand_N_In (N); 3894 3895 -- Bignum case 3896 3897 elsif Is_RTE (Etype (Lop), RE_Bignum) then 3898 3899 -- For X in T, we want to rewrite our node as 3900 3901 -- do 3902 -- Bnn : Result_Type; 3903 3904 -- declare 3905 -- M : Mark_Id := SS_Mark; 3906 -- Lnn : Long_Long_Integer'Base 3907 -- Nnn : Bignum; 3908 3909 -- begin 3910 -- Nnn := X; 3911 3912 -- if not Bignum_In_LLI_Range (Nnn) then 3913 -- Bnn := False; 3914 -- else 3915 -- Lnn := From_Bignum (Nnn); 3916 -- Bnn := 3917 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last) 3918 -- and then T'Base (Lnn) in T; 3919 -- end if; 3920 -- 3921 -- SS_Release (M); 3922 -- end 3923 -- in 3924 -- Bnn 3925 -- end 3926 3927 -- A bit gruesome, but there doesn't seem to be a simpler way 3928 3929 declare 3930 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3931 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3932 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N); 3933 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N); 3934 T : constant Entity_Id := Etype (Rop); 3935 TB : constant Entity_Id := Base_Type (T); 3936 Nin : Node_Id; 3937 3938 begin 3939 -- Mark the last membership operation to prevent recursion 3940 3941 Nin := 3942 Make_In (Loc, 3943 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)), 3944 Right_Opnd => New_Occurrence_Of (T, Loc)); 3945 Set_No_Minimize_Eliminate (Nin); 3946 3947 -- Now decorate the block 3948 3949 Insert_After 3950 (Last (Declarations (Blk)), 3951 Make_Object_Declaration (Loc, 3952 Defining_Identifier => Lnn, 3953 Object_Definition => New_Occurrence_Of (LLIB, Loc))); 3954 3955 Insert_After 3956 (Last (Declarations (Blk)), 3957 Make_Object_Declaration (Loc, 3958 Defining_Identifier => Nnn, 3959 Object_Definition => 3960 New_Occurrence_Of (RTE (RE_Bignum), Loc))); 3961 3962 Insert_List_Before 3963 (First (Statements (Handled_Statement_Sequence (Blk))), 3964 New_List ( 3965 Make_Assignment_Statement (Loc, 3966 Name => New_Occurrence_Of (Nnn, Loc), 3967 Expression => Relocate_Node (Lop)), 3968 3969 Make_If_Statement (Loc, 3970 Condition => 3971 Make_Op_Not (Loc, 3972 Right_Opnd => 3973 Make_Function_Call (Loc, 3974 Name => 3975 New_Occurrence_Of 3976 (RTE (RE_Bignum_In_LLI_Range), Loc), 3977 Parameter_Associations => New_List ( 3978 New_Occurrence_Of (Nnn, Loc)))), 3979 3980 Then_Statements => New_List ( 3981 Make_Assignment_Statement (Loc, 3982 Name => New_Occurrence_Of (Bnn, Loc), 3983 Expression => 3984 New_Occurrence_Of (Standard_False, Loc))), 3985 3986 Else_Statements => New_List ( 3987 Make_Assignment_Statement (Loc, 3988 Name => New_Occurrence_Of (Lnn, Loc), 3989 Expression => 3990 Make_Function_Call (Loc, 3991 Name => 3992 New_Occurrence_Of (RTE (RE_From_Bignum), Loc), 3993 Parameter_Associations => New_List ( 3994 New_Occurrence_Of (Nnn, Loc)))), 3995 3996 Make_Assignment_Statement (Loc, 3997 Name => New_Occurrence_Of (Bnn, Loc), 3998 Expression => 3999 Make_And_Then (Loc, 4000 Left_Opnd => 4001 Make_In (Loc, 4002 Left_Opnd => New_Occurrence_Of (Lnn, Loc), 4003 Right_Opnd => 4004 Make_Range (Loc, 4005 Low_Bound => 4006 Convert_To (LLIB, 4007 Make_Attribute_Reference (Loc, 4008 Attribute_Name => Name_First, 4009 Prefix => 4010 New_Occurrence_Of (TB, Loc))), 4011 4012 High_Bound => 4013 Convert_To (LLIB, 4014 Make_Attribute_Reference (Loc, 4015 Attribute_Name => Name_Last, 4016 Prefix => 4017 New_Occurrence_Of (TB, Loc))))), 4018 4019 Right_Opnd => Nin)))))); 4020 4021 -- Now we can do the rewrite 4022 4023 Rewrite (N, 4024 Make_Expression_With_Actions (Loc, 4025 Actions => New_List ( 4026 Make_Object_Declaration (Loc, 4027 Defining_Identifier => Bnn, 4028 Object_Definition => 4029 New_Occurrence_Of (Result_Type, Loc)), 4030 Blk), 4031 Expression => New_Occurrence_Of (Bnn, Loc))); 4032 Analyze_And_Resolve (N, Result_Type); 4033 return; 4034 end; 4035 4036 -- Not bignum case, but types don't match (this means we rewrote the 4037 -- left operand to be Long_Long_Integer). 4038 4039 else 4040 pragma Assert (Base_Type (Etype (Lop)) = LLIB); 4041 4042 -- We rewrite the membership test as (where T is the type with 4043 -- the predicate, i.e. the type of the right operand) 4044 4045 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last) 4046 -- and then T'Base (Lop) in T 4047 4048 declare 4049 T : constant Entity_Id := Etype (Rop); 4050 TB : constant Entity_Id := Base_Type (T); 4051 Nin : Node_Id; 4052 4053 begin 4054 -- The last membership test is marked to prevent recursion 4055 4056 Nin := 4057 Make_In (Loc, 4058 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)), 4059 Right_Opnd => New_Occurrence_Of (T, Loc)); 4060 Set_No_Minimize_Eliminate (Nin); 4061 4062 -- Now do the rewrite 4063 4064 Rewrite (N, 4065 Make_And_Then (Loc, 4066 Left_Opnd => 4067 Make_In (Loc, 4068 Left_Opnd => Lop, 4069 Right_Opnd => 4070 Make_Range (Loc, 4071 Low_Bound => 4072 Convert_To (LLIB, 4073 Make_Attribute_Reference (Loc, 4074 Attribute_Name => Name_First, 4075 Prefix => New_Occurrence_Of (TB, Loc))), 4076 High_Bound => 4077 Convert_To (LLIB, 4078 Make_Attribute_Reference (Loc, 4079 Attribute_Name => Name_Last, 4080 Prefix => New_Occurrence_Of (TB, Loc))))), 4081 Right_Opnd => Nin)); 4082 Set_Analyzed (N, False); 4083 Analyze_And_Resolve (N, Restype); 4084 end; 4085 end if; 4086 end if; 4087 end Expand_Membership_Minimize_Eliminate_Overflow; 4088 4089 ------------------------ 4090 -- Expand_N_Allocator -- 4091 ------------------------ 4092 4093 procedure Expand_N_Allocator (N : Node_Id) is 4094 PtrT : constant Entity_Id := Etype (N); 4095 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); 4096 Etyp : constant Entity_Id := Etype (Expression (N)); 4097 Loc : constant Source_Ptr := Sloc (N); 4098 Desig : Entity_Id; 4099 Nod : Node_Id; 4100 Pool : Entity_Id; 4101 Temp : Entity_Id; 4102 4103 procedure Rewrite_Coextension (N : Node_Id); 4104 -- Static coextensions have the same lifetime as the entity they 4105 -- constrain. Such occurrences can be rewritten as aliased objects 4106 -- and their unrestricted access used instead of the coextension. 4107 4108 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; 4109 -- Given a constrained array type E, returns a node representing the 4110 -- code to compute the size in storage elements for the given type. 4111 -- This is done without using the attribute (which malfunctions for 4112 -- large sizes ???) 4113 4114 ------------------------- 4115 -- Rewrite_Coextension -- 4116 ------------------------- 4117 4118 procedure Rewrite_Coextension (N : Node_Id) is 4119 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C'); 4120 Temp_Decl : Node_Id; 4121 4122 begin 4123 -- Generate: 4124 -- Cnn : aliased Etyp; 4125 4126 Temp_Decl := 4127 Make_Object_Declaration (Loc, 4128 Defining_Identifier => Temp_Id, 4129 Aliased_Present => True, 4130 Object_Definition => New_Occurrence_Of (Etyp, Loc)); 4131 4132 if Nkind (Expression (N)) = N_Qualified_Expression then 4133 Set_Expression (Temp_Decl, Expression (Expression (N))); 4134 end if; 4135 4136 Insert_Action (N, Temp_Decl); 4137 Rewrite (N, 4138 Make_Attribute_Reference (Loc, 4139 Prefix => New_Occurrence_Of (Temp_Id, Loc), 4140 Attribute_Name => Name_Unrestricted_Access)); 4141 4142 Analyze_And_Resolve (N, PtrT); 4143 end Rewrite_Coextension; 4144 4145 ------------------------------ 4146 -- Size_In_Storage_Elements -- 4147 ------------------------------ 4148 4149 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is 4150 begin 4151 -- Logically this just returns E'Max_Size_In_Storage_Elements. 4152 -- However, the reason for the existence of this function is 4153 -- to construct a test for sizes too large, which means near the 4154 -- 32-bit limit on a 32-bit machine, and precisely the trouble 4155 -- is that we get overflows when sizes are greater than 2**31. 4156 4157 -- So what we end up doing for array types is to use the expression: 4158 4159 -- number-of-elements * component_type'Max_Size_In_Storage_Elements 4160 4161 -- which avoids this problem. All this is a bit bogus, but it does 4162 -- mean we catch common cases of trying to allocate arrays that 4163 -- are too large, and which in the absence of a check results in 4164 -- undetected chaos ??? 4165 4166 declare 4167 Len : Node_Id; 4168 Res : Node_Id; 4169 4170 begin 4171 for J in 1 .. Number_Dimensions (E) loop 4172 Len := 4173 Make_Attribute_Reference (Loc, 4174 Prefix => New_Occurrence_Of (E, Loc), 4175 Attribute_Name => Name_Length, 4176 Expressions => New_List (Make_Integer_Literal (Loc, J))); 4177 4178 if J = 1 then 4179 Res := Len; 4180 4181 else 4182 Res := 4183 Make_Op_Multiply (Loc, 4184 Left_Opnd => Res, 4185 Right_Opnd => Len); 4186 end if; 4187 end loop; 4188 4189 return 4190 Make_Op_Multiply (Loc, 4191 Left_Opnd => Len, 4192 Right_Opnd => 4193 Make_Attribute_Reference (Loc, 4194 Prefix => New_Occurrence_Of (Component_Type (E), Loc), 4195 Attribute_Name => Name_Max_Size_In_Storage_Elements)); 4196 end; 4197 end Size_In_Storage_Elements; 4198 4199 -- Start of processing for Expand_N_Allocator 4200 4201 begin 4202 -- RM E.2.3(22). We enforce that the expected type of an allocator 4203 -- shall not be a remote access-to-class-wide-limited-private type 4204 4205 -- Why is this being done at expansion time, seems clearly wrong ??? 4206 4207 Validate_Remote_Access_To_Class_Wide_Type (N); 4208 4209 -- Processing for anonymous access-to-controlled types. These access 4210 -- types receive a special finalization master which appears in the 4211 -- declarations of the enclosing semantic unit. This expansion is done 4212 -- now to ensure that any additional types generated by this routine or 4213 -- Expand_Allocator_Expression inherit the proper type attributes. 4214 4215 if (Ekind (PtrT) = E_Anonymous_Access_Type 4216 or else 4217 (Is_Itype (PtrT) and then No (Finalization_Master (PtrT)))) 4218 and then Needs_Finalization (Dtyp) 4219 then 4220 -- Anonymous access-to-controlled types allocate on the global pool. 4221 -- Do not set this attribute on .NET/JVM since those targets do not 4222 -- support pools. 4223 4224 if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then 4225 Set_Associated_Storage_Pool 4226 (PtrT, Get_Global_Pool_For_Access_Type (PtrT)); 4227 end if; 4228 4229 -- The finalization master must be inserted and analyzed as part of 4230 -- the current semantic unit. This form of expansion is not carried 4231 -- out in Alfa mode because it is useless. Note that the master is 4232 -- updated when analysis changes current units. 4233 4234 if not Alfa_Mode then 4235 Set_Finalization_Master (PtrT, Current_Anonymous_Master); 4236 end if; 4237 end if; 4238 4239 -- Set the storage pool and find the appropriate version of Allocate to 4240 -- call. Do not overwrite the storage pool if it is already set, which 4241 -- can happen for build-in-place function returns (see 4242 -- Exp_Ch4.Expand_N_Extended_Return_Statement). 4243 4244 if No (Storage_Pool (N)) then 4245 Pool := Associated_Storage_Pool (Root_Type (PtrT)); 4246 4247 if Present (Pool) then 4248 Set_Storage_Pool (N, Pool); 4249 4250 if Is_RTE (Pool, RE_SS_Pool) then 4251 if VM_Target = No_VM then 4252 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); 4253 end if; 4254 4255 -- In the case of an allocator for a simple storage pool, locate 4256 -- and save a reference to the pool type's Allocate routine. 4257 4258 elsif Present (Get_Rep_Pragma 4259 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 4260 then 4261 declare 4262 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); 4263 Alloc_Op : Entity_Id; 4264 begin 4265 Alloc_Op := Get_Name_Entity_Id (Name_Allocate); 4266 while Present (Alloc_Op) loop 4267 if Scope (Alloc_Op) = Scope (Pool_Type) 4268 and then Present (First_Formal (Alloc_Op)) 4269 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 4270 then 4271 Set_Procedure_To_Call (N, Alloc_Op); 4272 exit; 4273 else 4274 Alloc_Op := Homonym (Alloc_Op); 4275 end if; 4276 end loop; 4277 end; 4278 4279 elsif Is_Class_Wide_Type (Etype (Pool)) then 4280 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); 4281 4282 else 4283 Set_Procedure_To_Call (N, 4284 Find_Prim_Op (Etype (Pool), Name_Allocate)); 4285 end if; 4286 end if; 4287 end if; 4288 4289 -- Under certain circumstances we can replace an allocator by an access 4290 -- to statically allocated storage. The conditions, as noted in AARM 4291 -- 3.10 (10c) are as follows: 4292 4293 -- Size and initial value is known at compile time 4294 -- Access type is access-to-constant 4295 4296 -- The allocator is not part of a constraint on a record component, 4297 -- because in that case the inserted actions are delayed until the 4298 -- record declaration is fully analyzed, which is too late for the 4299 -- analysis of the rewritten allocator. 4300 4301 if Is_Access_Constant (PtrT) 4302 and then Nkind (Expression (N)) = N_Qualified_Expression 4303 and then Compile_Time_Known_Value (Expression (Expression (N))) 4304 and then Size_Known_At_Compile_Time 4305 (Etype (Expression (Expression (N)))) 4306 and then not Is_Record_Type (Current_Scope) 4307 then 4308 -- Here we can do the optimization. For the allocator 4309 4310 -- new x'(y) 4311 4312 -- We insert an object declaration 4313 4314 -- Tnn : aliased x := y; 4315 4316 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is 4317 -- marked as requiring static allocation. 4318 4319 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); 4320 Desig := Subtype_Mark (Expression (N)); 4321 4322 -- If context is constrained, use constrained subtype directly, 4323 -- so that the constant is not labelled as having a nominally 4324 -- unconstrained subtype. 4325 4326 if Entity (Desig) = Base_Type (Dtyp) then 4327 Desig := New_Occurrence_Of (Dtyp, Loc); 4328 end if; 4329 4330 Insert_Action (N, 4331 Make_Object_Declaration (Loc, 4332 Defining_Identifier => Temp, 4333 Aliased_Present => True, 4334 Constant_Present => Is_Access_Constant (PtrT), 4335 Object_Definition => Desig, 4336 Expression => Expression (Expression (N)))); 4337 4338 Rewrite (N, 4339 Make_Attribute_Reference (Loc, 4340 Prefix => New_Occurrence_Of (Temp, Loc), 4341 Attribute_Name => Name_Unrestricted_Access)); 4342 4343 Analyze_And_Resolve (N, PtrT); 4344 4345 -- We set the variable as statically allocated, since we don't want 4346 -- it going on the stack of the current procedure! 4347 4348 Set_Is_Statically_Allocated (Temp); 4349 return; 4350 end if; 4351 4352 -- Same if the allocator is an access discriminant for a local object: 4353 -- instead of an allocator we create a local value and constrain the 4354 -- enclosing object with the corresponding access attribute. 4355 4356 if Is_Static_Coextension (N) then 4357 Rewrite_Coextension (N); 4358 return; 4359 end if; 4360 4361 -- Check for size too large, we do this because the back end misses 4362 -- proper checks here and can generate rubbish allocation calls when 4363 -- we are near the limit. We only do this for the 32-bit address case 4364 -- since that is from a practical point of view where we see a problem. 4365 4366 if System_Address_Size = 32 4367 and then not Storage_Checks_Suppressed (PtrT) 4368 and then not Storage_Checks_Suppressed (Dtyp) 4369 and then not Storage_Checks_Suppressed (Etyp) 4370 then 4371 -- The check we want to generate should look like 4372 4373 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then 4374 -- raise Storage_Error; 4375 -- end if; 4376 4377 -- where 3.5 gigabytes is a constant large enough to accommodate any 4378 -- reasonable request for. But we can't do it this way because at 4379 -- least at the moment we don't compute this attribute right, and 4380 -- can silently give wrong results when the result gets large. Since 4381 -- this is all about large results, that's bad, so instead we only 4382 -- apply the check for constrained arrays, and manually compute the 4383 -- value of the attribute ??? 4384 4385 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then 4386 Insert_Action (N, 4387 Make_Raise_Storage_Error (Loc, 4388 Condition => 4389 Make_Op_Gt (Loc, 4390 Left_Opnd => Size_In_Storage_Elements (Etyp), 4391 Right_Opnd => 4392 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))), 4393 Reason => SE_Object_Too_Large)); 4394 end if; 4395 end if; 4396 4397 -- Handle case of qualified expression (other than optimization above) 4398 -- First apply constraint checks, because the bounds or discriminants 4399 -- in the aggregate might not match the subtype mark in the allocator. 4400 4401 if Nkind (Expression (N)) = N_Qualified_Expression then 4402 Apply_Constraint_Check 4403 (Expression (Expression (N)), Etype (Expression (N))); 4404 4405 Expand_Allocator_Expression (N); 4406 return; 4407 end if; 4408 4409 -- If the allocator is for a type which requires initialization, and 4410 -- there is no initial value (i.e. operand is a subtype indication 4411 -- rather than a qualified expression), then we must generate a call to 4412 -- the initialization routine using an expressions action node: 4413 4414 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] 4415 4416 -- Here ptr_T is the pointer type for the allocator, and T is the 4417 -- subtype of the allocator. A special case arises if the designated 4418 -- type of the access type is a task or contains tasks. In this case 4419 -- the call to Init (Temp.all ...) is replaced by code that ensures 4420 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block 4421 -- for details). In addition, if the type T is a task T, then the 4422 -- first argument to Init must be converted to the task record type. 4423 4424 declare 4425 T : constant Entity_Id := Entity (Expression (N)); 4426 Args : List_Id; 4427 Decls : List_Id; 4428 Decl : Node_Id; 4429 Discr : Elmt_Id; 4430 Init : Entity_Id; 4431 Init_Arg1 : Node_Id; 4432 Temp_Decl : Node_Id; 4433 Temp_Type : Entity_Id; 4434 4435 begin 4436 if No_Initialization (N) then 4437 4438 -- Even though this might be a simple allocation, create a custom 4439 -- Allocate if the context requires it. Since .NET/JVM compilers 4440 -- do not support pools, this step is skipped. 4441 4442 if VM_Target = No_VM 4443 and then Present (Finalization_Master (PtrT)) 4444 then 4445 Build_Allocate_Deallocate_Proc 4446 (N => N, 4447 Is_Allocate => True); 4448 end if; 4449 4450 -- Case of no initialization procedure present 4451 4452 elsif not Has_Non_Null_Base_Init_Proc (T) then 4453 4454 -- Case of simple initialization required 4455 4456 if Needs_Simple_Initialization (T) then 4457 Check_Restriction (No_Default_Initialization, N); 4458 Rewrite (Expression (N), 4459 Make_Qualified_Expression (Loc, 4460 Subtype_Mark => New_Occurrence_Of (T, Loc), 4461 Expression => Get_Simple_Init_Val (T, N))); 4462 4463 Analyze_And_Resolve (Expression (Expression (N)), T); 4464 Analyze_And_Resolve (Expression (N), T); 4465 Set_Paren_Count (Expression (Expression (N)), 1); 4466 Expand_N_Allocator (N); 4467 4468 -- No initialization required 4469 4470 else 4471 null; 4472 end if; 4473 4474 -- Case of initialization procedure present, must be called 4475 4476 else 4477 Check_Restriction (No_Default_Initialization, N); 4478 4479 if not Restriction_Active (No_Default_Initialization) then 4480 Init := Base_Init_Proc (T); 4481 Nod := N; 4482 Temp := Make_Temporary (Loc, 'P'); 4483 4484 -- Construct argument list for the initialization routine call 4485 4486 Init_Arg1 := 4487 Make_Explicit_Dereference (Loc, 4488 Prefix => 4489 New_Reference_To (Temp, Loc)); 4490 4491 Set_Assignment_OK (Init_Arg1); 4492 Temp_Type := PtrT; 4493 4494 -- The initialization procedure expects a specific type. if the 4495 -- context is access to class wide, indicate that the object 4496 -- being allocated has the right specific type. 4497 4498 if Is_Class_Wide_Type (Dtyp) then 4499 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1); 4500 end if; 4501 4502 -- If designated type is a concurrent type or if it is private 4503 -- type whose definition is a concurrent type, the first 4504 -- argument in the Init routine has to be unchecked conversion 4505 -- to the corresponding record type. If the designated type is 4506 -- a derived type, also convert the argument to its root type. 4507 4508 if Is_Concurrent_Type (T) then 4509 Init_Arg1 := 4510 Unchecked_Convert_To ( 4511 Corresponding_Record_Type (T), Init_Arg1); 4512 4513 elsif Is_Private_Type (T) 4514 and then Present (Full_View (T)) 4515 and then Is_Concurrent_Type (Full_View (T)) 4516 then 4517 Init_Arg1 := 4518 Unchecked_Convert_To 4519 (Corresponding_Record_Type (Full_View (T)), Init_Arg1); 4520 4521 elsif Etype (First_Formal (Init)) /= Base_Type (T) then 4522 declare 4523 Ftyp : constant Entity_Id := Etype (First_Formal (Init)); 4524 4525 begin 4526 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1); 4527 Set_Etype (Init_Arg1, Ftyp); 4528 end; 4529 end if; 4530 4531 Args := New_List (Init_Arg1); 4532 4533 -- For the task case, pass the Master_Id of the access type as 4534 -- the value of the _Master parameter, and _Chain as the value 4535 -- of the _Chain parameter (_Chain will be defined as part of 4536 -- the generated code for the allocator). 4537 4538 -- In Ada 2005, the context may be a function that returns an 4539 -- anonymous access type. In that case the Master_Id has been 4540 -- created when expanding the function declaration. 4541 4542 if Has_Task (T) then 4543 if No (Master_Id (Base_Type (PtrT))) then 4544 4545 -- The designated type was an incomplete type, and the 4546 -- access type did not get expanded. Salvage it now. 4547 4548 if not Restriction_Active (No_Task_Hierarchy) then 4549 pragma Assert (Present (Parent (Base_Type (PtrT)))); 4550 Expand_N_Full_Type_Declaration 4551 (Parent (Base_Type (PtrT))); 4552 end if; 4553 end if; 4554 4555 -- If the context of the allocator is a declaration or an 4556 -- assignment, we can generate a meaningful image for it, 4557 -- even though subsequent assignments might remove the 4558 -- connection between task and entity. We build this image 4559 -- when the left-hand side is a simple variable, a simple 4560 -- indexed assignment or a simple selected component. 4561 4562 if Nkind (Parent (N)) = N_Assignment_Statement then 4563 declare 4564 Nam : constant Node_Id := Name (Parent (N)); 4565 4566 begin 4567 if Is_Entity_Name (Nam) then 4568 Decls := 4569 Build_Task_Image_Decls 4570 (Loc, 4571 New_Occurrence_Of 4572 (Entity (Nam), Sloc (Nam)), T); 4573 4574 elsif Nkind_In (Nam, N_Indexed_Component, 4575 N_Selected_Component) 4576 and then Is_Entity_Name (Prefix (Nam)) 4577 then 4578 Decls := 4579 Build_Task_Image_Decls 4580 (Loc, Nam, Etype (Prefix (Nam))); 4581 else 4582 Decls := Build_Task_Image_Decls (Loc, T, T); 4583 end if; 4584 end; 4585 4586 elsif Nkind (Parent (N)) = N_Object_Declaration then 4587 Decls := 4588 Build_Task_Image_Decls 4589 (Loc, Defining_Identifier (Parent (N)), T); 4590 4591 else 4592 Decls := Build_Task_Image_Decls (Loc, T, T); 4593 end if; 4594 4595 if Restriction_Active (No_Task_Hierarchy) then 4596 Append_To (Args, 4597 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 4598 else 4599 Append_To (Args, 4600 New_Reference_To 4601 (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); 4602 end if; 4603 4604 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 4605 4606 Decl := Last (Decls); 4607 Append_To (Args, 4608 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 4609 4610 -- Has_Task is false, Decls not used 4611 4612 else 4613 Decls := No_List; 4614 end if; 4615 4616 -- Add discriminants if discriminated type 4617 4618 declare 4619 Dis : Boolean := False; 4620 Typ : Entity_Id; 4621 4622 begin 4623 if Has_Discriminants (T) then 4624 Dis := True; 4625 Typ := T; 4626 4627 elsif Is_Private_Type (T) 4628 and then Present (Full_View (T)) 4629 and then Has_Discriminants (Full_View (T)) 4630 then 4631 Dis := True; 4632 Typ := Full_View (T); 4633 end if; 4634 4635 if Dis then 4636 4637 -- If the allocated object will be constrained by the 4638 -- default values for discriminants, then build a subtype 4639 -- with those defaults, and change the allocated subtype 4640 -- to that. Note that this happens in fewer cases in Ada 4641 -- 2005 (AI-363). 4642 4643 if not Is_Constrained (Typ) 4644 and then Present (Discriminant_Default_Value 4645 (First_Discriminant (Typ))) 4646 and then (Ada_Version < Ada_2005 4647 or else not 4648 Effectively_Has_Constrained_Partial_View 4649 (Typ => Typ, 4650 Scop => Current_Scope)) 4651 then 4652 Typ := Build_Default_Subtype (Typ, N); 4653 Set_Expression (N, New_Reference_To (Typ, Loc)); 4654 end if; 4655 4656 Discr := First_Elmt (Discriminant_Constraint (Typ)); 4657 while Present (Discr) loop 4658 Nod := Node (Discr); 4659 Append (New_Copy_Tree (Node (Discr)), Args); 4660 4661 -- AI-416: when the discriminant constraint is an 4662 -- anonymous access type make sure an accessibility 4663 -- check is inserted if necessary (3.10.2(22.q/2)) 4664 4665 if Ada_Version >= Ada_2005 4666 and then 4667 Ekind (Etype (Nod)) = E_Anonymous_Access_Type 4668 then 4669 Apply_Accessibility_Check 4670 (Nod, Typ, Insert_Node => Nod); 4671 end if; 4672 4673 Next_Elmt (Discr); 4674 end loop; 4675 end if; 4676 end; 4677 4678 -- We set the allocator as analyzed so that when we analyze 4679 -- the if expression node, we do not get an unwanted recursive 4680 -- expansion of the allocator expression. 4681 4682 Set_Analyzed (N, True); 4683 Nod := Relocate_Node (N); 4684 4685 -- Here is the transformation: 4686 -- input: new Ctrl_Typ 4687 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ; 4688 -- Ctrl_TypIP (Temp.all, ...); 4689 -- [Deep_]Initialize (Temp.all); 4690 4691 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and 4692 -- is the subtype of the allocator. 4693 4694 Temp_Decl := 4695 Make_Object_Declaration (Loc, 4696 Defining_Identifier => Temp, 4697 Constant_Present => True, 4698 Object_Definition => New_Reference_To (Temp_Type, Loc), 4699 Expression => Nod); 4700 4701 Set_Assignment_OK (Temp_Decl); 4702 Insert_Action (N, Temp_Decl, Suppress => All_Checks); 4703 4704 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 4705 4706 -- If the designated type is a task type or contains tasks, 4707 -- create block to activate created tasks, and insert 4708 -- declaration for Task_Image variable ahead of call. 4709 4710 if Has_Task (T) then 4711 declare 4712 L : constant List_Id := New_List; 4713 Blk : Node_Id; 4714 begin 4715 Build_Task_Allocate_Block (L, Nod, Args); 4716 Blk := Last (L); 4717 Insert_List_Before (First (Declarations (Blk)), Decls); 4718 Insert_Actions (N, L); 4719 end; 4720 4721 else 4722 Insert_Action (N, 4723 Make_Procedure_Call_Statement (Loc, 4724 Name => New_Reference_To (Init, Loc), 4725 Parameter_Associations => Args)); 4726 end if; 4727 4728 if Needs_Finalization (T) then 4729 4730 -- Generate: 4731 -- [Deep_]Initialize (Init_Arg1); 4732 4733 Insert_Action (N, 4734 Make_Init_Call 4735 (Obj_Ref => New_Copy_Tree (Init_Arg1), 4736 Typ => T)); 4737 4738 if Present (Finalization_Master (PtrT)) then 4739 4740 -- Special processing for .NET/JVM, the allocated object 4741 -- is attached to the finalization master. Generate: 4742 4743 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1)); 4744 4745 -- Types derived from [Limited_]Controlled are the only 4746 -- ones considered since they have fields Prev and Next. 4747 4748 if VM_Target /= No_VM then 4749 if Is_Controlled (T) then 4750 Insert_Action (N, 4751 Make_Attach_Call 4752 (Obj_Ref => New_Copy_Tree (Init_Arg1), 4753 Ptr_Typ => PtrT)); 4754 end if; 4755 4756 -- Default case, generate: 4757 4758 -- Set_Finalize_Address 4759 -- (<PtrT>FM, <T>FD'Unrestricted_Access); 4760 4761 -- Do not generate this call in the following cases: 4762 -- 4763 -- * Alfa mode - the call is useless and results in 4764 -- unwanted expansion. 4765 -- 4766 -- * CodePeer mode - TSS primitive Finalize_Address is 4767 -- not created in this mode. 4768 4769 elsif not Alfa_Mode 4770 and then not CodePeer_Mode 4771 then 4772 Insert_Action (N, 4773 Make_Set_Finalize_Address_Call 4774 (Loc => Loc, 4775 Typ => T, 4776 Ptr_Typ => PtrT)); 4777 end if; 4778 end if; 4779 end if; 4780 4781 Rewrite (N, New_Reference_To (Temp, Loc)); 4782 Analyze_And_Resolve (N, PtrT); 4783 end if; 4784 end if; 4785 end; 4786 4787 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface 4788 -- object that has been rewritten as a reference, we displace "this" 4789 -- to reference properly its secondary dispatch table. 4790 4791 if Nkind (N) = N_Identifier 4792 and then Is_Interface (Dtyp) 4793 then 4794 Displace_Allocator_Pointer (N); 4795 end if; 4796 4797 exception 4798 when RE_Not_Available => 4799 return; 4800 end Expand_N_Allocator; 4801 4802 ----------------------- 4803 -- Expand_N_And_Then -- 4804 ----------------------- 4805 4806 procedure Expand_N_And_Then (N : Node_Id) 4807 renames Expand_Short_Circuit_Operator; 4808 4809 ------------------------------ 4810 -- Expand_N_Case_Expression -- 4811 ------------------------------ 4812 4813 procedure Expand_N_Case_Expression (N : Node_Id) is 4814 Loc : constant Source_Ptr := Sloc (N); 4815 Typ : constant Entity_Id := Etype (N); 4816 Cstmt : Node_Id; 4817 Tnn : Entity_Id; 4818 Pnn : Entity_Id; 4819 Actions : List_Id; 4820 Ttyp : Entity_Id; 4821 Alt : Node_Id; 4822 Fexp : Node_Id; 4823 4824 begin 4825 -- Check for MINIMIZED/ELIMINATED overflow mode 4826 4827 if Minimized_Eliminated_Overflow_Check (N) then 4828 Apply_Arithmetic_Overflow_Check (N); 4829 return; 4830 end if; 4831 4832 -- We expand 4833 4834 -- case X is when A => AX, when B => BX ... 4835 4836 -- to 4837 4838 -- do 4839 -- Tnn : typ; 4840 -- case X is 4841 -- when A => 4842 -- Tnn := AX; 4843 -- when B => 4844 -- Tnn := BX; 4845 -- ... 4846 -- end case; 4847 -- in Tnn end; 4848 4849 -- However, this expansion is wrong for limited types, and also 4850 -- wrong for unconstrained types (since the bounds may not be the 4851 -- same in all branches). Furthermore it involves an extra copy 4852 -- for large objects. So we take care of this by using the following 4853 -- modified expansion for non-elementary types: 4854 4855 -- do 4856 -- type Pnn is access all typ; 4857 -- Tnn : Pnn; 4858 -- case X is 4859 -- when A => 4860 -- T := AX'Unrestricted_Access; 4861 -- when B => 4862 -- T := BX'Unrestricted_Access; 4863 -- ... 4864 -- end case; 4865 -- in Tnn.all end; 4866 4867 Cstmt := 4868 Make_Case_Statement (Loc, 4869 Expression => Expression (N), 4870 Alternatives => New_List); 4871 4872 Actions := New_List; 4873 4874 -- Scalar case 4875 4876 if Is_Elementary_Type (Typ) then 4877 Ttyp := Typ; 4878 4879 else 4880 Pnn := Make_Temporary (Loc, 'P'); 4881 Append_To (Actions, 4882 Make_Full_Type_Declaration (Loc, 4883 Defining_Identifier => Pnn, 4884 Type_Definition => 4885 Make_Access_To_Object_Definition (Loc, 4886 All_Present => True, 4887 Subtype_Indication => 4888 New_Reference_To (Typ, Loc)))); 4889 Ttyp := Pnn; 4890 end if; 4891 4892 Tnn := Make_Temporary (Loc, 'T'); 4893 Append_To (Actions, 4894 Make_Object_Declaration (Loc, 4895 Defining_Identifier => Tnn, 4896 Object_Definition => New_Occurrence_Of (Ttyp, Loc))); 4897 4898 -- Now process the alternatives 4899 4900 Alt := First (Alternatives (N)); 4901 while Present (Alt) loop 4902 declare 4903 Aexp : Node_Id := Expression (Alt); 4904 Aloc : constant Source_Ptr := Sloc (Aexp); 4905 Stats : List_Id; 4906 4907 begin 4908 -- As described above, take Unrestricted_Access for case of non- 4909 -- scalar types, to avoid big copies, and special cases. 4910 4911 if not Is_Elementary_Type (Typ) then 4912 Aexp := 4913 Make_Attribute_Reference (Aloc, 4914 Prefix => Relocate_Node (Aexp), 4915 Attribute_Name => Name_Unrestricted_Access); 4916 end if; 4917 4918 Stats := New_List ( 4919 Make_Assignment_Statement (Aloc, 4920 Name => New_Occurrence_Of (Tnn, Loc), 4921 Expression => Aexp)); 4922 4923 -- Propagate declarations inserted in the node by Insert_Actions 4924 -- (for example, temporaries generated to remove side effects). 4925 -- These actions must remain attached to the alternative, given 4926 -- that they are generated by the corresponding expression. 4927 4928 if Present (Sinfo.Actions (Alt)) then 4929 Prepend_List (Sinfo.Actions (Alt), Stats); 4930 end if; 4931 4932 Append_To 4933 (Alternatives (Cstmt), 4934 Make_Case_Statement_Alternative (Sloc (Alt), 4935 Discrete_Choices => Discrete_Choices (Alt), 4936 Statements => Stats)); 4937 end; 4938 4939 Next (Alt); 4940 end loop; 4941 4942 Append_To (Actions, Cstmt); 4943 4944 -- Construct and return final expression with actions 4945 4946 if Is_Elementary_Type (Typ) then 4947 Fexp := New_Occurrence_Of (Tnn, Loc); 4948 else 4949 Fexp := 4950 Make_Explicit_Dereference (Loc, 4951 Prefix => New_Occurrence_Of (Tnn, Loc)); 4952 end if; 4953 4954 Rewrite (N, 4955 Make_Expression_With_Actions (Loc, 4956 Expression => Fexp, 4957 Actions => Actions)); 4958 4959 Analyze_And_Resolve (N, Typ); 4960 end Expand_N_Case_Expression; 4961 4962 ----------------------------------- 4963 -- Expand_N_Explicit_Dereference -- 4964 ----------------------------------- 4965 4966 procedure Expand_N_Explicit_Dereference (N : Node_Id) is 4967 begin 4968 -- Insert explicit dereference call for the checked storage pool case 4969 4970 Insert_Dereference_Action (Prefix (N)); 4971 4972 -- If the type is an Atomic type for which Atomic_Sync is enabled, then 4973 -- we set the atomic sync flag. 4974 4975 if Is_Atomic (Etype (N)) 4976 and then not Atomic_Synchronization_Disabled (Etype (N)) 4977 then 4978 Activate_Atomic_Synchronization (N); 4979 end if; 4980 end Expand_N_Explicit_Dereference; 4981 4982 -------------------------------------- 4983 -- Expand_N_Expression_With_Actions -- 4984 -------------------------------------- 4985 4986 procedure Expand_N_Expression_With_Actions (N : Node_Id) is 4987 In_Case_Or_If_Expression : constant Boolean := 4988 Within_Case_Or_If_Expression (N); 4989 4990 function Process_Action (Act : Node_Id) return Traverse_Result; 4991 -- Inspect and process a single action of an expression_with_actions 4992 4993 -------------------- 4994 -- Process_Action -- 4995 -------------------- 4996 4997 function Process_Action (Act : Node_Id) return Traverse_Result is 4998 procedure Process_Transient_Object (Obj_Decl : Node_Id); 4999 -- Obj_Decl denotes the declaration of a transient controlled object. 5000 -- Generate all necessary types and hooks to properly finalize the 5001 -- result when the enclosing context is elaborated/evaluated. 5002 5003 ------------------------------ 5004 -- Process_Transient_Object -- 5005 ------------------------------ 5006 5007 procedure Process_Transient_Object (Obj_Decl : Node_Id) is 5008 function Find_Enclosing_Context return Node_Id; 5009 -- Find the context where the expression_with_actions appears 5010 5011 ---------------------------- 5012 -- Find_Enclosing_Context -- 5013 ---------------------------- 5014 5015 function Find_Enclosing_Context return Node_Id is 5016 function Is_Body_Or_Unit (N : Node_Id) return Boolean; 5017 -- Determine whether N denotes a body or unit declaration 5018 5019 --------------------- 5020 -- Is_Body_Or_Unit -- 5021 --------------------- 5022 5023 function Is_Body_Or_Unit (N : Node_Id) return Boolean is 5024 begin 5025 return Nkind_In (N, N_Entry_Body, 5026 N_Package_Body, 5027 N_Package_Declaration, 5028 N_Protected_Body, 5029 N_Subprogram_Body, 5030 N_Task_Body); 5031 end Is_Body_Or_Unit; 5032 5033 -- Local variables 5034 5035 Par : Node_Id; 5036 Top : Node_Id; 5037 5038 -- Start of processing for Find_Enclosing_Context 5039 5040 begin 5041 -- The expression_with_actions is in a case/if expression and 5042 -- the lifetime of any temporary controlled object is therefore 5043 -- extended. Find a suitable insertion node by locating the top 5044 -- most case or if expressions. 5045 5046 if In_Case_Or_If_Expression then 5047 Par := N; 5048 Top := N; 5049 while Present (Par) loop 5050 if Nkind_In (Original_Node (Par), N_Case_Expression, 5051 N_If_Expression) 5052 then 5053 Top := Par; 5054 5055 -- Prevent the search from going too far 5056 5057 elsif Is_Body_Or_Unit (Par) then 5058 exit; 5059 end if; 5060 5061 Par := Parent (Par); 5062 end loop; 5063 5064 -- The topmost case or if expression is now recovered, but 5065 -- it may still not be the correct place to add all the 5066 -- generated code. Climb to find a parent that is part of a 5067 -- declarative or statement list. 5068 5069 Par := Top; 5070 while Present (Par) loop 5071 if Is_List_Member (Par) 5072 and then 5073 not Nkind_In (Par, N_Component_Association, 5074 N_Discriminant_Association, 5075 N_Parameter_Association, 5076 N_Pragma_Argument_Association) 5077 then 5078 return Par; 5079 5080 -- Prevent the search from going too far 5081 5082 elsif Is_Body_Or_Unit (Par) then 5083 exit; 5084 end if; 5085 5086 Par := Parent (Par); 5087 end loop; 5088 5089 return Par; 5090 5091 -- Short circuit operators in complex expressions are converted 5092 -- into expression_with_actions. 5093 5094 else 5095 -- Take care of the case where the expression_with_actions 5096 -- is buried deep inside an IF statement. The temporary 5097 -- function result must be finalized before the then, elsif 5098 -- or else statements are evaluated. 5099 5100 -- if Something 5101 -- and then Ctrl_Func_Call 5102 -- then 5103 -- <result must be finalized at this point> 5104 -- <statements> 5105 -- end if; 5106 5107 -- To achieve this, find the topmost logical operator. The 5108 -- generated actions are then inserted before/after it. 5109 5110 Par := N; 5111 while Present (Par) loop 5112 5113 -- Keep climbing past various operators 5114 5115 if Nkind (Parent (Par)) in N_Op 5116 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else) 5117 then 5118 Par := Parent (Par); 5119 else 5120 exit; 5121 end if; 5122 end loop; 5123 5124 Top := Par; 5125 5126 -- The expression_with_actions might be located in a pragma 5127 -- in which case locate the pragma itself: 5128 5129 -- pragma Precondition (... and then Ctrl_Func_Call ...); 5130 5131 -- Similar case occurs when the expression_with_actions is 5132 -- related to an object declaration or assignment: 5133 5134 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...; 5135 5136 -- Another case to consider is an expression_with_actions as 5137 -- part of a return statement: 5138 5139 -- return ... and then Ctrl_Func_Call ...; 5140 5141 while Present (Par) loop 5142 if Nkind_In (Par, N_Assignment_Statement, 5143 N_Object_Declaration, 5144 N_Pragma, 5145 N_Simple_Return_Statement) 5146 then 5147 return Par; 5148 5149 elsif Is_Body_Or_Unit (Par) then 5150 exit; 5151 end if; 5152 5153 Par := Parent (Par); 5154 end loop; 5155 5156 -- Return the topmost short circuit operator 5157 5158 return Top; 5159 end if; 5160 end Find_Enclosing_Context; 5161 5162 -- Local variables 5163 5164 Context : constant Node_Id := Find_Enclosing_Context; 5165 Loc : constant Source_Ptr := Sloc (Obj_Decl); 5166 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); 5167 Obj_Typ : constant Node_Id := Etype (Obj_Id); 5168 Desig_Typ : Entity_Id; 5169 Expr : Node_Id; 5170 Ptr_Id : Entity_Id; 5171 Temp_Id : Entity_Id; 5172 5173 -- Start of processing for Process_Transient_Object 5174 5175 begin 5176 -- Step 1: Create the access type which provides a reference to 5177 -- the transient object. 5178 5179 if Is_Access_Type (Obj_Typ) then 5180 Desig_Typ := Directly_Designated_Type (Obj_Typ); 5181 else 5182 Desig_Typ := Obj_Typ; 5183 end if; 5184 5185 -- Generate: 5186 -- Ann : access [all] <Desig_Typ>; 5187 5188 Ptr_Id := Make_Temporary (Loc, 'A'); 5189 5190 Insert_Action (Context, 5191 Make_Full_Type_Declaration (Loc, 5192 Defining_Identifier => Ptr_Id, 5193 Type_Definition => 5194 Make_Access_To_Object_Definition (Loc, 5195 All_Present => 5196 Ekind (Obj_Typ) = E_General_Access_Type, 5197 Subtype_Indication => New_Reference_To (Desig_Typ, Loc)))); 5198 5199 -- Step 2: Create a temporary which acts as a hook to the 5200 -- transient object. Generate: 5201 5202 -- Temp : Ptr_Id := null; 5203 5204 Temp_Id := Make_Temporary (Loc, 'T'); 5205 5206 Insert_Action (Context, 5207 Make_Object_Declaration (Loc, 5208 Defining_Identifier => Temp_Id, 5209 Object_Definition => New_Reference_To (Ptr_Id, Loc))); 5210 5211 -- Mark this temporary as created for the purposes of exporting 5212 -- the transient declaration out of the Actions list. This signals 5213 -- the machinery in Build_Finalizer to recognize this special 5214 -- case. 5215 5216 Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl); 5217 5218 -- Step 3: Hook the transient object to the temporary 5219 5220 if Is_Access_Type (Obj_Typ) then 5221 Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); 5222 else 5223 Expr := 5224 Make_Attribute_Reference (Loc, 5225 Prefix => New_Reference_To (Obj_Id, Loc), 5226 Attribute_Name => Name_Unrestricted_Access); 5227 end if; 5228 5229 -- Generate: 5230 -- Temp := Ptr_Id (Obj_Id); 5231 -- <or> 5232 -- Temp := Obj_Id'Unrestricted_Access; 5233 5234 Insert_After_And_Analyze (Obj_Decl, 5235 Make_Assignment_Statement (Loc, 5236 Name => New_Reference_To (Temp_Id, Loc), 5237 Expression => Expr)); 5238 5239 -- Step 4: Finalize the function result after the context has been 5240 -- evaluated/elaborated. Generate: 5241 5242 -- if Temp /= null then 5243 -- [Deep_]Finalize (Temp.all); 5244 -- Temp := null; 5245 -- end if; 5246 5247 -- When the expression_with_actions is part of a return statement, 5248 -- there is no need to insert a finalization call, as the general 5249 -- finalization mechanism (see Build_Finalizer) would take care of 5250 -- the temporary function result on subprogram exit. Note that it 5251 -- would also be impossible to insert the finalization code after 5252 -- the return statement as this would make it unreachable. 5253 5254 if Nkind (Context) /= N_Simple_Return_Statement then 5255 Insert_Action_After (Context, 5256 Make_If_Statement (Loc, 5257 Condition => 5258 Make_Op_Ne (Loc, 5259 Left_Opnd => New_Reference_To (Temp_Id, Loc), 5260 Right_Opnd => Make_Null (Loc)), 5261 5262 Then_Statements => New_List ( 5263 Make_Final_Call 5264 (Obj_Ref => 5265 Make_Explicit_Dereference (Loc, 5266 Prefix => New_Reference_To (Temp_Id, Loc)), 5267 Typ => Desig_Typ), 5268 5269 Make_Assignment_Statement (Loc, 5270 Name => New_Reference_To (Temp_Id, Loc), 5271 Expression => Make_Null (Loc))))); 5272 end if; 5273 end Process_Transient_Object; 5274 5275 -- Start of processing for Process_Action 5276 5277 begin 5278 if Nkind (Act) = N_Object_Declaration 5279 and then Is_Finalizable_Transient (Act, N) 5280 then 5281 Process_Transient_Object (Act); 5282 5283 -- Avoid processing temporary function results multiple times when 5284 -- dealing with nested expression_with_actions. 5285 5286 elsif Nkind (Act) = N_Expression_With_Actions then 5287 return Abandon; 5288 5289 -- Do not process temporary function results in loops. This is 5290 -- done by Expand_N_Loop_Statement and Build_Finalizer. 5291 5292 elsif Nkind (Act) = N_Loop_Statement then 5293 return Abandon; 5294 end if; 5295 5296 return OK; 5297 end Process_Action; 5298 5299 procedure Process_Single_Action is new Traverse_Proc (Process_Action); 5300 5301 -- Local variables 5302 5303 Act : Node_Id; 5304 5305 -- Start of processing for Expand_N_Expression_With_Actions 5306 5307 begin 5308 Act := First (Actions (N)); 5309 while Present (Act) loop 5310 Process_Single_Action (Act); 5311 5312 Next (Act); 5313 end loop; 5314 end Expand_N_Expression_With_Actions; 5315 5316 ---------------------------- 5317 -- Expand_N_If_Expression -- 5318 ---------------------------- 5319 5320 -- Deal with limited types and condition actions 5321 5322 procedure Expand_N_If_Expression (N : Node_Id) is 5323 function Create_Alternative 5324 (Loc : Source_Ptr; 5325 Temp_Id : Entity_Id; 5326 Flag_Id : Entity_Id; 5327 Expr : Node_Id) return List_Id; 5328 -- Build the statements of a "then" or "else" dependent expression 5329 -- alternative. Temp_Id is the if expression result, Flag_Id is a 5330 -- finalization flag created to service expression Expr. 5331 5332 function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean; 5333 -- Determine if expression Expr is a rewritten controlled function call 5334 5335 ------------------------ 5336 -- Create_Alternative -- 5337 ------------------------ 5338 5339 function Create_Alternative 5340 (Loc : Source_Ptr; 5341 Temp_Id : Entity_Id; 5342 Flag_Id : Entity_Id; 5343 Expr : Node_Id) return List_Id 5344 is 5345 Result : constant List_Id := New_List; 5346 5347 begin 5348 -- Generate: 5349 -- Fnn := True; 5350 5351 if Present (Flag_Id) 5352 and then not Is_Controlled_Function_Call (Expr) 5353 then 5354 Append_To (Result, 5355 Make_Assignment_Statement (Loc, 5356 Name => New_Reference_To (Flag_Id, Loc), 5357 Expression => New_Reference_To (Standard_True, Loc))); 5358 end if; 5359 5360 -- Generate: 5361 -- Cnn := <expr>'Unrestricted_Access; 5362 5363 Append_To (Result, 5364 Make_Assignment_Statement (Loc, 5365 Name => New_Reference_To (Temp_Id, Loc), 5366 Expression => 5367 Make_Attribute_Reference (Loc, 5368 Prefix => Relocate_Node (Expr), 5369 Attribute_Name => Name_Unrestricted_Access))); 5370 5371 return Result; 5372 end Create_Alternative; 5373 5374 --------------------------------- 5375 -- Is_Controlled_Function_Call -- 5376 --------------------------------- 5377 5378 function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean is 5379 begin 5380 return 5381 Nkind (Original_Node (Expr)) = N_Function_Call 5382 and then Needs_Finalization (Etype (Expr)); 5383 end Is_Controlled_Function_Call; 5384 5385 -- Local variables 5386 5387 Loc : constant Source_Ptr := Sloc (N); 5388 Cond : constant Node_Id := First (Expressions (N)); 5389 Thenx : constant Node_Id := Next (Cond); 5390 Elsex : constant Node_Id := Next (Thenx); 5391 Typ : constant Entity_Id := Etype (N); 5392 5393 Actions : List_Id; 5394 Cnn : Entity_Id; 5395 Decl : Node_Id; 5396 Expr : Node_Id; 5397 New_If : Node_Id; 5398 New_N : Node_Id; 5399 5400 -- Start of processing for Expand_N_If_Expression 5401 5402 begin 5403 -- Check for MINIMIZED/ELIMINATED overflow mode 5404 5405 if Minimized_Eliminated_Overflow_Check (N) then 5406 Apply_Arithmetic_Overflow_Check (N); 5407 return; 5408 end if; 5409 5410 -- Fold at compile time if condition known. We have already folded 5411 -- static if expressions, but it is possible to fold any case in which 5412 -- the condition is known at compile time, even though the result is 5413 -- non-static. 5414 5415 -- Note that we don't do the fold of such cases in Sem_Elab because 5416 -- it can cause infinite loops with the expander adding a conditional 5417 -- expression, and Sem_Elab circuitry removing it repeatedly. 5418 5419 if Compile_Time_Known_Value (Cond) then 5420 if Is_True (Expr_Value (Cond)) then 5421 Expr := Thenx; 5422 Actions := Then_Actions (N); 5423 else 5424 Expr := Elsex; 5425 Actions := Else_Actions (N); 5426 end if; 5427 5428 Remove (Expr); 5429 5430 if Present (Actions) then 5431 5432 -- If we are not allowed to use Expression_With_Actions, just skip 5433 -- the optimization, it is not critical for correctness. 5434 5435 if not Use_Expression_With_Actions then 5436 goto Skip_Optimization; 5437 end if; 5438 5439 Rewrite (N, 5440 Make_Expression_With_Actions (Loc, 5441 Expression => Relocate_Node (Expr), 5442 Actions => Actions)); 5443 Analyze_And_Resolve (N, Typ); 5444 5445 else 5446 Rewrite (N, Relocate_Node (Expr)); 5447 end if; 5448 5449 -- Note that the result is never static (legitimate cases of static 5450 -- if expressions were folded in Sem_Eval). 5451 5452 Set_Is_Static_Expression (N, False); 5453 return; 5454 end if; 5455 5456 <<Skip_Optimization>> 5457 5458 -- If the type is limited or unconstrained, we expand as follows to 5459 -- avoid any possibility of improper copies. 5460 5461 -- Note: it may be possible to avoid this special processing if the 5462 -- back end uses its own mechanisms for handling by-reference types ??? 5463 5464 -- type Ptr is access all Typ; 5465 -- Cnn : Ptr; 5466 -- if cond then 5467 -- <<then actions>> 5468 -- Cnn := then-expr'Unrestricted_Access; 5469 -- else 5470 -- <<else actions>> 5471 -- Cnn := else-expr'Unrestricted_Access; 5472 -- end if; 5473 5474 -- and replace the if expression by a reference to Cnn.all. 5475 5476 -- This special case can be skipped if the back end handles limited 5477 -- types properly and ensures that no incorrect copies are made. 5478 5479 if Is_By_Reference_Type (Typ) 5480 and then not Back_End_Handles_Limited_Types 5481 then 5482 declare 5483 Flag_Id : Entity_Id; 5484 Ptr_Typ : Entity_Id; 5485 5486 begin 5487 Flag_Id := Empty; 5488 5489 -- At least one of the if expression dependent expressions uses a 5490 -- controlled function to provide the result. Create a status flag 5491 -- to signal the finalization machinery that Cnn needs special 5492 -- handling. 5493 5494 if Is_Controlled_Function_Call (Thenx) 5495 or else 5496 Is_Controlled_Function_Call (Elsex) 5497 then 5498 Flag_Id := Make_Temporary (Loc, 'F'); 5499 5500 Insert_Action (N, 5501 Make_Object_Declaration (Loc, 5502 Defining_Identifier => Flag_Id, 5503 Object_Definition => 5504 New_Reference_To (Standard_Boolean, Loc), 5505 Expression => 5506 New_Reference_To (Standard_False, Loc))); 5507 end if; 5508 5509 -- Generate: 5510 -- type Ann is access all Typ; 5511 5512 Ptr_Typ := Make_Temporary (Loc, 'A'); 5513 5514 Insert_Action (N, 5515 Make_Full_Type_Declaration (Loc, 5516 Defining_Identifier => Ptr_Typ, 5517 Type_Definition => 5518 Make_Access_To_Object_Definition (Loc, 5519 All_Present => True, 5520 Subtype_Indication => New_Reference_To (Typ, Loc)))); 5521 5522 -- Generate: 5523 -- Cnn : Ann; 5524 5525 Cnn := Make_Temporary (Loc, 'C', N); 5526 Set_Ekind (Cnn, E_Variable); 5527 Set_Status_Flag_Or_Transient_Decl (Cnn, Flag_Id); 5528 5529 Decl := 5530 Make_Object_Declaration (Loc, 5531 Defining_Identifier => Cnn, 5532 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); 5533 5534 New_If := 5535 Make_Implicit_If_Statement (N, 5536 Condition => Relocate_Node (Cond), 5537 Then_Statements => 5538 Create_Alternative (Sloc (Thenx), Cnn, Flag_Id, Thenx), 5539 Else_Statements => 5540 Create_Alternative (Sloc (Elsex), Cnn, Flag_Id, Elsex)); 5541 5542 New_N := 5543 Make_Explicit_Dereference (Loc, 5544 Prefix => New_Occurrence_Of (Cnn, Loc)); 5545 end; 5546 5547 -- For other types, we only need to expand if there are other actions 5548 -- associated with either branch. 5549 5550 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then 5551 5552 -- We have two approaches to handling this. If we are allowed to use 5553 -- N_Expression_With_Actions, then we can just wrap the actions into 5554 -- the appropriate expression. 5555 5556 if Use_Expression_With_Actions then 5557 if Present (Then_Actions (N)) then 5558 Rewrite (Thenx, 5559 Make_Expression_With_Actions (Sloc (Thenx), 5560 Actions => Then_Actions (N), 5561 Expression => Relocate_Node (Thenx))); 5562 Set_Then_Actions (N, No_List); 5563 Analyze_And_Resolve (Thenx, Typ); 5564 end if; 5565 5566 if Present (Else_Actions (N)) then 5567 Rewrite (Elsex, 5568 Make_Expression_With_Actions (Sloc (Elsex), 5569 Actions => Else_Actions (N), 5570 Expression => Relocate_Node (Elsex))); 5571 Set_Else_Actions (N, No_List); 5572 Analyze_And_Resolve (Elsex, Typ); 5573 end if; 5574 5575 return; 5576 5577 -- if we can't use N_Expression_With_Actions nodes, then we insert 5578 -- the following sequence of actions (using Insert_Actions): 5579 5580 -- Cnn : typ; 5581 -- if cond then 5582 -- <<then actions>> 5583 -- Cnn := then-expr; 5584 -- else 5585 -- <<else actions>> 5586 -- Cnn := else-expr 5587 -- end if; 5588 5589 -- and replace the if expression by a reference to Cnn 5590 5591 else 5592 Cnn := Make_Temporary (Loc, 'C', N); 5593 5594 Decl := 5595 Make_Object_Declaration (Loc, 5596 Defining_Identifier => Cnn, 5597 Object_Definition => New_Occurrence_Of (Typ, Loc)); 5598 5599 New_If := 5600 Make_Implicit_If_Statement (N, 5601 Condition => Relocate_Node (Cond), 5602 5603 Then_Statements => New_List ( 5604 Make_Assignment_Statement (Sloc (Thenx), 5605 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 5606 Expression => Relocate_Node (Thenx))), 5607 5608 Else_Statements => New_List ( 5609 Make_Assignment_Statement (Sloc (Elsex), 5610 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 5611 Expression => Relocate_Node (Elsex)))); 5612 5613 Set_Assignment_OK (Name (First (Then_Statements (New_If)))); 5614 Set_Assignment_OK (Name (First (Else_Statements (New_If)))); 5615 5616 New_N := New_Occurrence_Of (Cnn, Loc); 5617 end if; 5618 5619 -- If no actions then no expansion needed, gigi will handle it using 5620 -- the same approach as a C conditional expression. 5621 5622 else 5623 return; 5624 end if; 5625 5626 -- Fall through here for either the limited expansion, or the case of 5627 -- inserting actions for non-limited types. In both these cases, we must 5628 -- move the SLOC of the parent If statement to the newly created one and 5629 -- change it to the SLOC of the expression which, after expansion, will 5630 -- correspond to what is being evaluated. 5631 5632 if Present (Parent (N)) 5633 and then Nkind (Parent (N)) = N_If_Statement 5634 then 5635 Set_Sloc (New_If, Sloc (Parent (N))); 5636 Set_Sloc (Parent (N), Loc); 5637 end if; 5638 5639 -- Make sure Then_Actions and Else_Actions are appropriately moved 5640 -- to the new if statement. 5641 5642 if Present (Then_Actions (N)) then 5643 Insert_List_Before 5644 (First (Then_Statements (New_If)), Then_Actions (N)); 5645 end if; 5646 5647 if Present (Else_Actions (N)) then 5648 Insert_List_Before 5649 (First (Else_Statements (New_If)), Else_Actions (N)); 5650 end if; 5651 5652 Insert_Action (N, Decl); 5653 Insert_Action (N, New_If); 5654 Rewrite (N, New_N); 5655 Analyze_And_Resolve (N, Typ); 5656 end Expand_N_If_Expression; 5657 5658 ----------------- 5659 -- Expand_N_In -- 5660 ----------------- 5661 5662 procedure Expand_N_In (N : Node_Id) is 5663 Loc : constant Source_Ptr := Sloc (N); 5664 Restyp : constant Entity_Id := Etype (N); 5665 Lop : constant Node_Id := Left_Opnd (N); 5666 Rop : constant Node_Id := Right_Opnd (N); 5667 Static : constant Boolean := Is_OK_Static_Expression (N); 5668 5669 Ltyp : Entity_Id; 5670 Rtyp : Entity_Id; 5671 5672 procedure Substitute_Valid_Check; 5673 -- Replaces node N by Lop'Valid. This is done when we have an explicit 5674 -- test for the left operand being in range of its subtype. 5675 5676 ---------------------------- 5677 -- Substitute_Valid_Check -- 5678 ---------------------------- 5679 5680 procedure Substitute_Valid_Check is 5681 begin 5682 Rewrite (N, 5683 Make_Attribute_Reference (Loc, 5684 Prefix => Relocate_Node (Lop), 5685 Attribute_Name => Name_Valid)); 5686 5687 Analyze_And_Resolve (N, Restyp); 5688 5689 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED, 5690 -- in which case, this usage makes sense, and in any case, we have 5691 -- actually eliminated the danger of optimization above. 5692 5693 if Overflow_Check_Mode not in Minimized_Or_Eliminated then 5694 Error_Msg_N 5695 ("??explicit membership test may be optimized away", N); 5696 Error_Msg_N -- CODEFIX 5697 ("\??use ''Valid attribute instead", N); 5698 end if; 5699 5700 return; 5701 end Substitute_Valid_Check; 5702 5703 -- Start of processing for Expand_N_In 5704 5705 begin 5706 -- If set membership case, expand with separate procedure 5707 5708 if Present (Alternatives (N)) then 5709 Expand_Set_Membership (N); 5710 return; 5711 end if; 5712 5713 -- Not set membership, proceed with expansion 5714 5715 Ltyp := Etype (Left_Opnd (N)); 5716 Rtyp := Etype (Right_Opnd (N)); 5717 5718 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer 5719 -- type, then expand with a separate procedure. Note the use of the 5720 -- flag No_Minimize_Eliminate to prevent infinite recursion. 5721 5722 if Overflow_Check_Mode in Minimized_Or_Eliminated 5723 and then Is_Signed_Integer_Type (Ltyp) 5724 and then not No_Minimize_Eliminate (N) 5725 then 5726 Expand_Membership_Minimize_Eliminate_Overflow (N); 5727 return; 5728 end if; 5729 5730 -- Check case of explicit test for an expression in range of its 5731 -- subtype. This is suspicious usage and we replace it with a 'Valid 5732 -- test and give a warning for scalar types. 5733 5734 if Is_Scalar_Type (Ltyp) 5735 5736 -- Only relevant for source comparisons 5737 5738 and then Comes_From_Source (N) 5739 5740 -- In floating-point this is a standard way to check for finite values 5741 -- and using 'Valid would typically be a pessimization. 5742 5743 and then not Is_Floating_Point_Type (Ltyp) 5744 5745 -- Don't give the message unless right operand is a type entity and 5746 -- the type of the left operand matches this type. Note that this 5747 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow 5748 -- checks have changed the type of the left operand. 5749 5750 and then Nkind (Rop) in N_Has_Entity 5751 and then Ltyp = Entity (Rop) 5752 5753 -- Skip in VM mode, where we have no sense of invalid values. The 5754 -- warning still seems relevant, but not important enough to worry. 5755 5756 and then VM_Target = No_VM 5757 5758 -- Skip this for predicated types, where such expressions are a 5759 -- reasonable way of testing if something meets the predicate. 5760 5761 and then not Present (Predicate_Function (Ltyp)) 5762 then 5763 Substitute_Valid_Check; 5764 return; 5765 end if; 5766 5767 -- Do validity check on operands 5768 5769 if Validity_Checks_On and Validity_Check_Operands then 5770 Ensure_Valid (Left_Opnd (N)); 5771 Validity_Check_Range (Right_Opnd (N)); 5772 end if; 5773 5774 -- Case of explicit range 5775 5776 if Nkind (Rop) = N_Range then 5777 declare 5778 Lo : constant Node_Id := Low_Bound (Rop); 5779 Hi : constant Node_Id := High_Bound (Rop); 5780 5781 Lo_Orig : constant Node_Id := Original_Node (Lo); 5782 Hi_Orig : constant Node_Id := Original_Node (Hi); 5783 5784 Lcheck : Compare_Result; 5785 Ucheck : Compare_Result; 5786 5787 Warn1 : constant Boolean := 5788 Constant_Condition_Warnings 5789 and then Comes_From_Source (N) 5790 and then not In_Instance; 5791 -- This must be true for any of the optimization warnings, we 5792 -- clearly want to give them only for source with the flag on. We 5793 -- also skip these warnings in an instance since it may be the 5794 -- case that different instantiations have different ranges. 5795 5796 Warn2 : constant Boolean := 5797 Warn1 5798 and then Nkind (Original_Node (Rop)) = N_Range 5799 and then Is_Integer_Type (Etype (Lo)); 5800 -- For the case where only one bound warning is elided, we also 5801 -- insist on an explicit range and an integer type. The reason is 5802 -- that the use of enumeration ranges including an end point is 5803 -- common, as is the use of a subtype name, one of whose bounds is 5804 -- the same as the type of the expression. 5805 5806 begin 5807 -- If test is explicit x'First .. x'Last, replace by valid check 5808 5809 -- Could use some individual comments for this complex test ??? 5810 5811 if Is_Scalar_Type (Ltyp) 5812 5813 -- And left operand is X'First where X matches left operand 5814 -- type (this eliminates cases of type mismatch, including 5815 -- the cases where ELIMINATED/MINIMIZED mode has changed the 5816 -- type of the left operand. 5817 5818 and then Nkind (Lo_Orig) = N_Attribute_Reference 5819 and then Attribute_Name (Lo_Orig) = Name_First 5820 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity 5821 and then Entity (Prefix (Lo_Orig)) = Ltyp 5822 5823 -- Same tests for right operand 5824 5825 and then Nkind (Hi_Orig) = N_Attribute_Reference 5826 and then Attribute_Name (Hi_Orig) = Name_Last 5827 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity 5828 and then Entity (Prefix (Hi_Orig)) = Ltyp 5829 5830 -- Relevant only for source cases 5831 5832 and then Comes_From_Source (N) 5833 5834 -- Omit for VM cases, where we don't have invalid values 5835 5836 and then VM_Target = No_VM 5837 then 5838 Substitute_Valid_Check; 5839 goto Leave; 5840 end if; 5841 5842 -- If bounds of type are known at compile time, and the end points 5843 -- are known at compile time and identical, this is another case 5844 -- for substituting a valid test. We only do this for discrete 5845 -- types, since it won't arise in practice for float types. 5846 5847 if Comes_From_Source (N) 5848 and then Is_Discrete_Type (Ltyp) 5849 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) 5850 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) 5851 and then Compile_Time_Known_Value (Lo) 5852 and then Compile_Time_Known_Value (Hi) 5853 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) 5854 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) 5855 5856 -- Kill warnings in instances, since they may be cases where we 5857 -- have a test in the generic that makes sense with some types 5858 -- and not with other types. 5859 5860 and then not In_Instance 5861 then 5862 Substitute_Valid_Check; 5863 goto Leave; 5864 end if; 5865 5866 -- If we have an explicit range, do a bit of optimization based on 5867 -- range analysis (we may be able to kill one or both checks). 5868 5869 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); 5870 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); 5871 5872 -- If either check is known to fail, replace result by False since 5873 -- the other check does not matter. Preserve the static flag for 5874 -- legality checks, because we are constant-folding beyond RM 4.9. 5875 5876 if Lcheck = LT or else Ucheck = GT then 5877 if Warn1 then 5878 Error_Msg_N ("?c?range test optimized away", N); 5879 Error_Msg_N ("\?c?value is known to be out of range", N); 5880 end if; 5881 5882 Rewrite (N, New_Reference_To (Standard_False, Loc)); 5883 Analyze_And_Resolve (N, Restyp); 5884 Set_Is_Static_Expression (N, Static); 5885 goto Leave; 5886 5887 -- If both checks are known to succeed, replace result by True, 5888 -- since we know we are in range. 5889 5890 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 5891 if Warn1 then 5892 Error_Msg_N ("?c?range test optimized away", N); 5893 Error_Msg_N ("\?c?value is known to be in range", N); 5894 end if; 5895 5896 Rewrite (N, New_Reference_To (Standard_True, Loc)); 5897 Analyze_And_Resolve (N, Restyp); 5898 Set_Is_Static_Expression (N, Static); 5899 goto Leave; 5900 5901 -- If lower bound check succeeds and upper bound check is not 5902 -- known to succeed or fail, then replace the range check with 5903 -- a comparison against the upper bound. 5904 5905 elsif Lcheck in Compare_GE then 5906 if Warn2 and then not In_Instance then 5907 Error_Msg_N ("??lower bound test optimized away", Lo); 5908 Error_Msg_N ("\??value is known to be in range", Lo); 5909 end if; 5910 5911 Rewrite (N, 5912 Make_Op_Le (Loc, 5913 Left_Opnd => Lop, 5914 Right_Opnd => High_Bound (Rop))); 5915 Analyze_And_Resolve (N, Restyp); 5916 goto Leave; 5917 5918 -- If upper bound check succeeds and lower bound check is not 5919 -- known to succeed or fail, then replace the range check with 5920 -- a comparison against the lower bound. 5921 5922 elsif Ucheck in Compare_LE then 5923 if Warn2 and then not In_Instance then 5924 Error_Msg_N ("??upper bound test optimized away", Hi); 5925 Error_Msg_N ("\??value is known to be in range", Hi); 5926 end if; 5927 5928 Rewrite (N, 5929 Make_Op_Ge (Loc, 5930 Left_Opnd => Lop, 5931 Right_Opnd => Low_Bound (Rop))); 5932 Analyze_And_Resolve (N, Restyp); 5933 goto Leave; 5934 end if; 5935 5936 -- We couldn't optimize away the range check, but there is one 5937 -- more issue. If we are checking constant conditionals, then we 5938 -- see if we can determine the outcome assuming everything is 5939 -- valid, and if so give an appropriate warning. 5940 5941 if Warn1 and then not Assume_No_Invalid_Values then 5942 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True); 5943 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True); 5944 5945 -- Result is out of range for valid value 5946 5947 if Lcheck = LT or else Ucheck = GT then 5948 Error_Msg_N 5949 ("?c?value can only be in range if it is invalid", N); 5950 5951 -- Result is in range for valid value 5952 5953 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 5954 Error_Msg_N 5955 ("?c?value can only be out of range if it is invalid", N); 5956 5957 -- Lower bound check succeeds if value is valid 5958 5959 elsif Warn2 and then Lcheck in Compare_GE then 5960 Error_Msg_N 5961 ("?c?lower bound check only fails if it is invalid", Lo); 5962 5963 -- Upper bound check succeeds if value is valid 5964 5965 elsif Warn2 and then Ucheck in Compare_LE then 5966 Error_Msg_N 5967 ("?c?upper bound check only fails for invalid values", Hi); 5968 end if; 5969 end if; 5970 end; 5971 5972 -- For all other cases of an explicit range, nothing to be done 5973 5974 goto Leave; 5975 5976 -- Here right operand is a subtype mark 5977 5978 else 5979 declare 5980 Typ : Entity_Id := Etype (Rop); 5981 Is_Acc : constant Boolean := Is_Access_Type (Typ); 5982 Cond : Node_Id := Empty; 5983 New_N : Node_Id; 5984 Obj : Node_Id := Lop; 5985 SCIL_Node : Node_Id; 5986 5987 begin 5988 Remove_Side_Effects (Obj); 5989 5990 -- For tagged type, do tagged membership operation 5991 5992 if Is_Tagged_Type (Typ) then 5993 5994 -- No expansion will be performed when VM_Target, as the VM 5995 -- back-ends will handle the membership tests directly (tags 5996 -- are not explicitly represented in Java objects, so the 5997 -- normal tagged membership expansion is not what we want). 5998 5999 if Tagged_Type_Expansion then 6000 Tagged_Membership (N, SCIL_Node, New_N); 6001 Rewrite (N, New_N); 6002 Analyze_And_Resolve (N, Restyp); 6003 6004 -- Update decoration of relocated node referenced by the 6005 -- SCIL node. 6006 6007 if Generate_SCIL and then Present (SCIL_Node) then 6008 Set_SCIL_Node (N, SCIL_Node); 6009 end if; 6010 end if; 6011 6012 goto Leave; 6013 6014 -- If type is scalar type, rewrite as x in t'First .. t'Last. 6015 -- This reason we do this is that the bounds may have the wrong 6016 -- type if they come from the original type definition. Also this 6017 -- way we get all the processing above for an explicit range. 6018 6019 -- Don't do this for predicated types, since in this case we 6020 -- want to check the predicate! 6021 6022 elsif Is_Scalar_Type (Typ) then 6023 if No (Predicate_Function (Typ)) then 6024 Rewrite (Rop, 6025 Make_Range (Loc, 6026 Low_Bound => 6027 Make_Attribute_Reference (Loc, 6028 Attribute_Name => Name_First, 6029 Prefix => New_Reference_To (Typ, Loc)), 6030 6031 High_Bound => 6032 Make_Attribute_Reference (Loc, 6033 Attribute_Name => Name_Last, 6034 Prefix => New_Reference_To (Typ, Loc)))); 6035 Analyze_And_Resolve (N, Restyp); 6036 end if; 6037 6038 goto Leave; 6039 6040 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 6041 -- a membership test if the subtype mark denotes a constrained 6042 -- Unchecked_Union subtype and the expression lacks inferable 6043 -- discriminants. 6044 6045 elsif Is_Unchecked_Union (Base_Type (Typ)) 6046 and then Is_Constrained (Typ) 6047 and then not Has_Inferable_Discriminants (Lop) 6048 then 6049 Insert_Action (N, 6050 Make_Raise_Program_Error (Loc, 6051 Reason => PE_Unchecked_Union_Restriction)); 6052 6053 -- Prevent Gigi from generating incorrect code by rewriting the 6054 -- test as False. What is this undocumented thing about ??? 6055 6056 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6057 goto Leave; 6058 end if; 6059 6060 -- Here we have a non-scalar type 6061 6062 if Is_Acc then 6063 Typ := Designated_Type (Typ); 6064 end if; 6065 6066 if not Is_Constrained (Typ) then 6067 Rewrite (N, New_Reference_To (Standard_True, Loc)); 6068 Analyze_And_Resolve (N, Restyp); 6069 6070 -- For the constrained array case, we have to check the subscripts 6071 -- for an exact match if the lengths are non-zero (the lengths 6072 -- must match in any case). 6073 6074 elsif Is_Array_Type (Typ) then 6075 Check_Subscripts : declare 6076 function Build_Attribute_Reference 6077 (E : Node_Id; 6078 Nam : Name_Id; 6079 Dim : Nat) return Node_Id; 6080 -- Build attribute reference E'Nam (Dim) 6081 6082 ------------------------------- 6083 -- Build_Attribute_Reference -- 6084 ------------------------------- 6085 6086 function Build_Attribute_Reference 6087 (E : Node_Id; 6088 Nam : Name_Id; 6089 Dim : Nat) return Node_Id 6090 is 6091 begin 6092 return 6093 Make_Attribute_Reference (Loc, 6094 Prefix => E, 6095 Attribute_Name => Nam, 6096 Expressions => New_List ( 6097 Make_Integer_Literal (Loc, Dim))); 6098 end Build_Attribute_Reference; 6099 6100 -- Start of processing for Check_Subscripts 6101 6102 begin 6103 for J in 1 .. Number_Dimensions (Typ) loop 6104 Evolve_And_Then (Cond, 6105 Make_Op_Eq (Loc, 6106 Left_Opnd => 6107 Build_Attribute_Reference 6108 (Duplicate_Subexpr_No_Checks (Obj), 6109 Name_First, J), 6110 Right_Opnd => 6111 Build_Attribute_Reference 6112 (New_Occurrence_Of (Typ, Loc), Name_First, J))); 6113 6114 Evolve_And_Then (Cond, 6115 Make_Op_Eq (Loc, 6116 Left_Opnd => 6117 Build_Attribute_Reference 6118 (Duplicate_Subexpr_No_Checks (Obj), 6119 Name_Last, J), 6120 Right_Opnd => 6121 Build_Attribute_Reference 6122 (New_Occurrence_Of (Typ, Loc), Name_Last, J))); 6123 end loop; 6124 6125 if Is_Acc then 6126 Cond := 6127 Make_Or_Else (Loc, 6128 Left_Opnd => 6129 Make_Op_Eq (Loc, 6130 Left_Opnd => Obj, 6131 Right_Opnd => Make_Null (Loc)), 6132 Right_Opnd => Cond); 6133 end if; 6134 6135 Rewrite (N, Cond); 6136 Analyze_And_Resolve (N, Restyp); 6137 end Check_Subscripts; 6138 6139 -- These are the cases where constraint checks may be required, 6140 -- e.g. records with possible discriminants 6141 6142 else 6143 -- Expand the test into a series of discriminant comparisons. 6144 -- The expression that is built is the negation of the one that 6145 -- is used for checking discriminant constraints. 6146 6147 Obj := Relocate_Node (Left_Opnd (N)); 6148 6149 if Has_Discriminants (Typ) then 6150 Cond := Make_Op_Not (Loc, 6151 Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); 6152 6153 if Is_Acc then 6154 Cond := Make_Or_Else (Loc, 6155 Left_Opnd => 6156 Make_Op_Eq (Loc, 6157 Left_Opnd => Obj, 6158 Right_Opnd => Make_Null (Loc)), 6159 Right_Opnd => Cond); 6160 end if; 6161 6162 else 6163 Cond := New_Occurrence_Of (Standard_True, Loc); 6164 end if; 6165 6166 Rewrite (N, Cond); 6167 Analyze_And_Resolve (N, Restyp); 6168 end if; 6169 6170 -- Ada 2012 (AI05-0149): Handle membership tests applied to an 6171 -- expression of an anonymous access type. This can involve an 6172 -- accessibility test and a tagged type membership test in the 6173 -- case of tagged designated types. 6174 6175 if Ada_Version >= Ada_2012 6176 and then Is_Acc 6177 and then Ekind (Ltyp) = E_Anonymous_Access_Type 6178 then 6179 declare 6180 Expr_Entity : Entity_Id := Empty; 6181 New_N : Node_Id; 6182 Param_Level : Node_Id; 6183 Type_Level : Node_Id; 6184 6185 begin 6186 if Is_Entity_Name (Lop) then 6187 Expr_Entity := Param_Entity (Lop); 6188 6189 if not Present (Expr_Entity) then 6190 Expr_Entity := Entity (Lop); 6191 end if; 6192 end if; 6193 6194 -- If a conversion of the anonymous access value to the 6195 -- tested type would be illegal, then the result is False. 6196 6197 if not Valid_Conversion 6198 (Lop, Rtyp, Lop, Report_Errs => False) 6199 then 6200 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6201 Analyze_And_Resolve (N, Restyp); 6202 6203 -- Apply an accessibility check if the access object has an 6204 -- associated access level and when the level of the type is 6205 -- less deep than the level of the access parameter. This 6206 -- only occur for access parameters and stand-alone objects 6207 -- of an anonymous access type. 6208 6209 else 6210 if Present (Expr_Entity) 6211 and then 6212 Present 6213 (Effective_Extra_Accessibility (Expr_Entity)) 6214 and then UI_Gt (Object_Access_Level (Lop), 6215 Type_Access_Level (Rtyp)) 6216 then 6217 Param_Level := 6218 New_Occurrence_Of 6219 (Effective_Extra_Accessibility (Expr_Entity), Loc); 6220 6221 Type_Level := 6222 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); 6223 6224 -- Return True only if the accessibility level of the 6225 -- expression entity is not deeper than the level of 6226 -- the tested access type. 6227 6228 Rewrite (N, 6229 Make_And_Then (Loc, 6230 Left_Opnd => Relocate_Node (N), 6231 Right_Opnd => Make_Op_Le (Loc, 6232 Left_Opnd => Param_Level, 6233 Right_Opnd => Type_Level))); 6234 6235 Analyze_And_Resolve (N); 6236 end if; 6237 6238 -- If the designated type is tagged, do tagged membership 6239 -- operation. 6240 6241 -- *** NOTE: we have to check not null before doing the 6242 -- tagged membership test (but maybe that can be done 6243 -- inside Tagged_Membership?). 6244 6245 if Is_Tagged_Type (Typ) then 6246 Rewrite (N, 6247 Make_And_Then (Loc, 6248 Left_Opnd => Relocate_Node (N), 6249 Right_Opnd => 6250 Make_Op_Ne (Loc, 6251 Left_Opnd => Obj, 6252 Right_Opnd => Make_Null (Loc)))); 6253 6254 -- No expansion will be performed when VM_Target, as 6255 -- the VM back-ends will handle the membership tests 6256 -- directly (tags are not explicitly represented in 6257 -- Java objects, so the normal tagged membership 6258 -- expansion is not what we want). 6259 6260 if Tagged_Type_Expansion then 6261 6262 -- Note that we have to pass Original_Node, because 6263 -- the membership test might already have been 6264 -- rewritten by earlier parts of membership test. 6265 6266 Tagged_Membership 6267 (Original_Node (N), SCIL_Node, New_N); 6268 6269 -- Update decoration of relocated node referenced 6270 -- by the SCIL node. 6271 6272 if Generate_SCIL and then Present (SCIL_Node) then 6273 Set_SCIL_Node (New_N, SCIL_Node); 6274 end if; 6275 6276 Rewrite (N, 6277 Make_And_Then (Loc, 6278 Left_Opnd => Relocate_Node (N), 6279 Right_Opnd => New_N)); 6280 6281 Analyze_And_Resolve (N, Restyp); 6282 end if; 6283 end if; 6284 end if; 6285 end; 6286 end if; 6287 end; 6288 end if; 6289 6290 -- At this point, we have done the processing required for the basic 6291 -- membership test, but not yet dealt with the predicate. 6292 6293 <<Leave>> 6294 6295 -- If a predicate is present, then we do the predicate test, but we 6296 -- most certainly want to omit this if we are within the predicate 6297 -- function itself, since otherwise we have an infinite recursion! 6298 -- The check should also not be emitted when testing against a range 6299 -- (the check is only done when the right operand is a subtype; see 6300 -- RM12-4.5.2 (28.1/3-30/3)). 6301 6302 declare 6303 PFunc : constant Entity_Id := Predicate_Function (Rtyp); 6304 6305 begin 6306 if Present (PFunc) 6307 and then Current_Scope /= PFunc 6308 and then Nkind (Rop) /= N_Range 6309 then 6310 Rewrite (N, 6311 Make_And_Then (Loc, 6312 Left_Opnd => Relocate_Node (N), 6313 Right_Opnd => Make_Predicate_Call (Rtyp, Lop))); 6314 6315 -- Analyze new expression, mark left operand as analyzed to 6316 -- avoid infinite recursion adding predicate calls. Similarly, 6317 -- suppress further range checks on the call. 6318 6319 Set_Analyzed (Left_Opnd (N)); 6320 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 6321 6322 -- All done, skip attempt at compile time determination of result 6323 6324 return; 6325 end if; 6326 end; 6327 end Expand_N_In; 6328 6329 -------------------------------- 6330 -- Expand_N_Indexed_Component -- 6331 -------------------------------- 6332 6333 procedure Expand_N_Indexed_Component (N : Node_Id) is 6334 Loc : constant Source_Ptr := Sloc (N); 6335 Typ : constant Entity_Id := Etype (N); 6336 P : constant Node_Id := Prefix (N); 6337 T : constant Entity_Id := Etype (P); 6338 Atp : Entity_Id; 6339 6340 begin 6341 -- A special optimization, if we have an indexed component that is 6342 -- selecting from a slice, then we can eliminate the slice, since, for 6343 -- example, x (i .. j)(k) is identical to x(k). The only difference is 6344 -- the range check required by the slice. The range check for the slice 6345 -- itself has already been generated. The range check for the 6346 -- subscripting operation is ensured by converting the subject to 6347 -- the subtype of the slice. 6348 6349 -- This optimization not only generates better code, avoiding slice 6350 -- messing especially in the packed case, but more importantly bypasses 6351 -- some problems in handling this peculiar case, for example, the issue 6352 -- of dealing specially with object renamings. 6353 6354 if Nkind (P) = N_Slice then 6355 Rewrite (N, 6356 Make_Indexed_Component (Loc, 6357 Prefix => Prefix (P), 6358 Expressions => New_List ( 6359 Convert_To 6360 (Etype (First_Index (Etype (P))), 6361 First (Expressions (N)))))); 6362 Analyze_And_Resolve (N, Typ); 6363 return; 6364 end if; 6365 6366 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 6367 -- function, then additional actuals must be passed. 6368 6369 if Ada_Version >= Ada_2005 6370 and then Is_Build_In_Place_Function_Call (P) 6371 then 6372 Make_Build_In_Place_Call_In_Anonymous_Context (P); 6373 end if; 6374 6375 -- If the prefix is an access type, then we unconditionally rewrite if 6376 -- as an explicit dereference. This simplifies processing for several 6377 -- cases, including packed array cases and certain cases in which checks 6378 -- must be generated. We used to try to do this only when it was 6379 -- necessary, but it cleans up the code to do it all the time. 6380 6381 if Is_Access_Type (T) then 6382 Insert_Explicit_Dereference (P); 6383 Analyze_And_Resolve (P, Designated_Type (T)); 6384 Atp := Designated_Type (T); 6385 else 6386 Atp := T; 6387 end if; 6388 6389 -- Generate index and validity checks 6390 6391 Generate_Index_Checks (N); 6392 6393 if Validity_Checks_On and then Validity_Check_Subscripts then 6394 Apply_Subscript_Validity_Checks (N); 6395 end if; 6396 6397 -- If selecting from an array with atomic components, and atomic sync 6398 -- is not suppressed for this array type, set atomic sync flag. 6399 6400 if (Has_Atomic_Components (Atp) 6401 and then not Atomic_Synchronization_Disabled (Atp)) 6402 or else (Is_Atomic (Typ) 6403 and then not Atomic_Synchronization_Disabled (Typ)) 6404 then 6405 Activate_Atomic_Synchronization (N); 6406 end if; 6407 6408 -- All done for the non-packed case 6409 6410 if not Is_Packed (Etype (Prefix (N))) then 6411 return; 6412 end if; 6413 6414 -- For packed arrays that are not bit-packed (i.e. the case of an array 6415 -- with one or more index types with a non-contiguous enumeration type), 6416 -- we can always use the normal packed element get circuit. 6417 6418 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then 6419 Expand_Packed_Element_Reference (N); 6420 return; 6421 end if; 6422 6423 -- For a reference to a component of a bit packed array, we have to 6424 -- convert it to a reference to the corresponding Packed_Array_Type. 6425 -- We only want to do this for simple references, and not for: 6426 6427 -- Left side of assignment, or prefix of left side of assignment, or 6428 -- prefix of the prefix, to handle packed arrays of packed arrays, 6429 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement 6430 6431 -- Renaming objects in renaming associations 6432 -- This case is handled when a use of the renamed variable occurs 6433 6434 -- Actual parameters for a procedure call 6435 -- This case is handled in Exp_Ch6.Expand_Actuals 6436 6437 -- The second expression in a 'Read attribute reference 6438 6439 -- The prefix of an address or bit or size attribute reference 6440 6441 -- The following circuit detects these exceptions 6442 6443 declare 6444 Child : Node_Id := N; 6445 Parnt : Node_Id := Parent (N); 6446 6447 begin 6448 loop 6449 if Nkind (Parnt) = N_Unchecked_Expression then 6450 null; 6451 6452 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration, 6453 N_Procedure_Call_Statement) 6454 or else (Nkind (Parnt) = N_Parameter_Association 6455 and then 6456 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) 6457 then 6458 return; 6459 6460 elsif Nkind (Parnt) = N_Attribute_Reference 6461 and then (Attribute_Name (Parnt) = Name_Address 6462 or else 6463 Attribute_Name (Parnt) = Name_Bit 6464 or else 6465 Attribute_Name (Parnt) = Name_Size) 6466 and then Prefix (Parnt) = Child 6467 then 6468 return; 6469 6470 elsif Nkind (Parnt) = N_Assignment_Statement 6471 and then Name (Parnt) = Child 6472 then 6473 return; 6474 6475 -- If the expression is an index of an indexed component, it must 6476 -- be expanded regardless of context. 6477 6478 elsif Nkind (Parnt) = N_Indexed_Component 6479 and then Child /= Prefix (Parnt) 6480 then 6481 Expand_Packed_Element_Reference (N); 6482 return; 6483 6484 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement 6485 and then Name (Parent (Parnt)) = Parnt 6486 then 6487 return; 6488 6489 elsif Nkind (Parnt) = N_Attribute_Reference 6490 and then Attribute_Name (Parnt) = Name_Read 6491 and then Next (First (Expressions (Parnt))) = Child 6492 then 6493 return; 6494 6495 elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component) 6496 and then Prefix (Parnt) = Child 6497 then 6498 null; 6499 6500 else 6501 Expand_Packed_Element_Reference (N); 6502 return; 6503 end if; 6504 6505 -- Keep looking up tree for unchecked expression, or if we are the 6506 -- prefix of a possible assignment left side. 6507 6508 Child := Parnt; 6509 Parnt := Parent (Child); 6510 end loop; 6511 end; 6512 end Expand_N_Indexed_Component; 6513 6514 --------------------- 6515 -- Expand_N_Not_In -- 6516 --------------------- 6517 6518 -- Replace a not in b by not (a in b) so that the expansions for (a in b) 6519 -- can be done. This avoids needing to duplicate this expansion code. 6520 6521 procedure Expand_N_Not_In (N : Node_Id) is 6522 Loc : constant Source_Ptr := Sloc (N); 6523 Typ : constant Entity_Id := Etype (N); 6524 Cfs : constant Boolean := Comes_From_Source (N); 6525 6526 begin 6527 Rewrite (N, 6528 Make_Op_Not (Loc, 6529 Right_Opnd => 6530 Make_In (Loc, 6531 Left_Opnd => Left_Opnd (N), 6532 Right_Opnd => Right_Opnd (N)))); 6533 6534 -- If this is a set membership, preserve list of alternatives 6535 6536 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); 6537 6538 -- We want this to appear as coming from source if original does (see 6539 -- transformations in Expand_N_In). 6540 6541 Set_Comes_From_Source (N, Cfs); 6542 Set_Comes_From_Source (Right_Opnd (N), Cfs); 6543 6544 -- Now analyze transformed node 6545 6546 Analyze_And_Resolve (N, Typ); 6547 end Expand_N_Not_In; 6548 6549 ------------------- 6550 -- Expand_N_Null -- 6551 ------------------- 6552 6553 -- The only replacement required is for the case of a null of a type that 6554 -- is an access to protected subprogram, or a subtype thereof. We represent 6555 -- such access values as a record, and so we must replace the occurrence of 6556 -- null by the equivalent record (with a null address and a null pointer in 6557 -- it), so that the backend creates the proper value. 6558 6559 procedure Expand_N_Null (N : Node_Id) is 6560 Loc : constant Source_Ptr := Sloc (N); 6561 Typ : constant Entity_Id := Base_Type (Etype (N)); 6562 Agg : Node_Id; 6563 6564 begin 6565 if Is_Access_Protected_Subprogram_Type (Typ) then 6566 Agg := 6567 Make_Aggregate (Loc, 6568 Expressions => New_List ( 6569 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 6570 Make_Null (Loc))); 6571 6572 Rewrite (N, Agg); 6573 Analyze_And_Resolve (N, Equivalent_Type (Typ)); 6574 6575 -- For subsequent semantic analysis, the node must retain its type. 6576 -- Gigi in any case replaces this type by the corresponding record 6577 -- type before processing the node. 6578 6579 Set_Etype (N, Typ); 6580 end if; 6581 6582 exception 6583 when RE_Not_Available => 6584 return; 6585 end Expand_N_Null; 6586 6587 --------------------- 6588 -- Expand_N_Op_Abs -- 6589 --------------------- 6590 6591 procedure Expand_N_Op_Abs (N : Node_Id) is 6592 Loc : constant Source_Ptr := Sloc (N); 6593 Expr : constant Node_Id := Right_Opnd (N); 6594 6595 begin 6596 Unary_Op_Validity_Checks (N); 6597 6598 -- Check for MINIMIZED/ELIMINATED overflow mode 6599 6600 if Minimized_Eliminated_Overflow_Check (N) then 6601 Apply_Arithmetic_Overflow_Check (N); 6602 return; 6603 end if; 6604 6605 -- Deal with software overflow checking 6606 6607 if not Backend_Overflow_Checks_On_Target 6608 and then Is_Signed_Integer_Type (Etype (N)) 6609 and then Do_Overflow_Check (N) 6610 then 6611 -- The only case to worry about is when the argument is equal to the 6612 -- largest negative number, so what we do is to insert the check: 6613 6614 -- [constraint_error when Expr = typ'Base'First] 6615 6616 -- with the usual Duplicate_Subexpr use coding for expr 6617 6618 Insert_Action (N, 6619 Make_Raise_Constraint_Error (Loc, 6620 Condition => 6621 Make_Op_Eq (Loc, 6622 Left_Opnd => Duplicate_Subexpr (Expr), 6623 Right_Opnd => 6624 Make_Attribute_Reference (Loc, 6625 Prefix => 6626 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), 6627 Attribute_Name => Name_First)), 6628 Reason => CE_Overflow_Check_Failed)); 6629 end if; 6630 6631 -- Vax floating-point types case 6632 6633 if Vax_Float (Etype (N)) then 6634 Expand_Vax_Arith (N); 6635 end if; 6636 end Expand_N_Op_Abs; 6637 6638 --------------------- 6639 -- Expand_N_Op_Add -- 6640 --------------------- 6641 6642 procedure Expand_N_Op_Add (N : Node_Id) is 6643 Typ : constant Entity_Id := Etype (N); 6644 6645 begin 6646 Binary_Op_Validity_Checks (N); 6647 6648 -- Check for MINIMIZED/ELIMINATED overflow mode 6649 6650 if Minimized_Eliminated_Overflow_Check (N) then 6651 Apply_Arithmetic_Overflow_Check (N); 6652 return; 6653 end if; 6654 6655 -- N + 0 = 0 + N = N for integer types 6656 6657 if Is_Integer_Type (Typ) then 6658 if Compile_Time_Known_Value (Right_Opnd (N)) 6659 and then Expr_Value (Right_Opnd (N)) = Uint_0 6660 then 6661 Rewrite (N, Left_Opnd (N)); 6662 return; 6663 6664 elsif Compile_Time_Known_Value (Left_Opnd (N)) 6665 and then Expr_Value (Left_Opnd (N)) = Uint_0 6666 then 6667 Rewrite (N, Right_Opnd (N)); 6668 return; 6669 end if; 6670 end if; 6671 6672 -- Arithmetic overflow checks for signed integer/fixed point types 6673 6674 if Is_Signed_Integer_Type (Typ) 6675 or else Is_Fixed_Point_Type (Typ) 6676 then 6677 Apply_Arithmetic_Overflow_Check (N); 6678 return; 6679 6680 -- Vax floating-point types case 6681 6682 elsif Vax_Float (Typ) then 6683 Expand_Vax_Arith (N); 6684 end if; 6685 end Expand_N_Op_Add; 6686 6687 --------------------- 6688 -- Expand_N_Op_And -- 6689 --------------------- 6690 6691 procedure Expand_N_Op_And (N : Node_Id) is 6692 Typ : constant Entity_Id := Etype (N); 6693 6694 begin 6695 Binary_Op_Validity_Checks (N); 6696 6697 if Is_Array_Type (Etype (N)) then 6698 Expand_Boolean_Operator (N); 6699 6700 elsif Is_Boolean_Type (Etype (N)) then 6701 Adjust_Condition (Left_Opnd (N)); 6702 Adjust_Condition (Right_Opnd (N)); 6703 Set_Etype (N, Standard_Boolean); 6704 Adjust_Result_Type (N, Typ); 6705 6706 elsif Is_Intrinsic_Subprogram (Entity (N)) then 6707 Expand_Intrinsic_Call (N, Entity (N)); 6708 6709 end if; 6710 end Expand_N_Op_And; 6711 6712 ------------------------ 6713 -- Expand_N_Op_Concat -- 6714 ------------------------ 6715 6716 procedure Expand_N_Op_Concat (N : Node_Id) is 6717 Opnds : List_Id; 6718 -- List of operands to be concatenated 6719 6720 Cnode : Node_Id; 6721 -- Node which is to be replaced by the result of concatenating the nodes 6722 -- in the list Opnds. 6723 6724 begin 6725 -- Ensure validity of both operands 6726 6727 Binary_Op_Validity_Checks (N); 6728 6729 -- If we are the left operand of a concatenation higher up the tree, 6730 -- then do nothing for now, since we want to deal with a series of 6731 -- concatenations as a unit. 6732 6733 if Nkind (Parent (N)) = N_Op_Concat 6734 and then N = Left_Opnd (Parent (N)) 6735 then 6736 return; 6737 end if; 6738 6739 -- We get here with a concatenation whose left operand may be a 6740 -- concatenation itself with a consistent type. We need to process 6741 -- these concatenation operands from left to right, which means 6742 -- from the deepest node in the tree to the highest node. 6743 6744 Cnode := N; 6745 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop 6746 Cnode := Left_Opnd (Cnode); 6747 end loop; 6748 6749 -- Now Cnode is the deepest concatenation, and its parents are the 6750 -- concatenation nodes above, so now we process bottom up, doing the 6751 -- operations. We gather a string that is as long as possible up to five 6752 -- operands. 6753 6754 -- The outer loop runs more than once if more than one concatenation 6755 -- type is involved. 6756 6757 Outer : loop 6758 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); 6759 Set_Parent (Opnds, N); 6760 6761 -- The inner loop gathers concatenation operands 6762 6763 Inner : while Cnode /= N 6764 and then Base_Type (Etype (Cnode)) = 6765 Base_Type (Etype (Parent (Cnode))) 6766 loop 6767 Cnode := Parent (Cnode); 6768 Append (Right_Opnd (Cnode), Opnds); 6769 end loop Inner; 6770 6771 Expand_Concatenate (Cnode, Opnds); 6772 6773 exit Outer when Cnode = N; 6774 Cnode := Parent (Cnode); 6775 end loop Outer; 6776 end Expand_N_Op_Concat; 6777 6778 ------------------------ 6779 -- Expand_N_Op_Divide -- 6780 ------------------------ 6781 6782 procedure Expand_N_Op_Divide (N : Node_Id) is 6783 Loc : constant Source_Ptr := Sloc (N); 6784 Lopnd : constant Node_Id := Left_Opnd (N); 6785 Ropnd : constant Node_Id := Right_Opnd (N); 6786 Ltyp : constant Entity_Id := Etype (Lopnd); 6787 Rtyp : constant Entity_Id := Etype (Ropnd); 6788 Typ : Entity_Id := Etype (N); 6789 Rknow : constant Boolean := Is_Integer_Type (Typ) 6790 and then 6791 Compile_Time_Known_Value (Ropnd); 6792 Rval : Uint; 6793 6794 begin 6795 Binary_Op_Validity_Checks (N); 6796 6797 -- Check for MINIMIZED/ELIMINATED overflow mode 6798 6799 if Minimized_Eliminated_Overflow_Check (N) then 6800 Apply_Arithmetic_Overflow_Check (N); 6801 return; 6802 end if; 6803 6804 -- Otherwise proceed with expansion of division 6805 6806 if Rknow then 6807 Rval := Expr_Value (Ropnd); 6808 end if; 6809 6810 -- N / 1 = N for integer types 6811 6812 if Rknow and then Rval = Uint_1 then 6813 Rewrite (N, Lopnd); 6814 return; 6815 end if; 6816 6817 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that 6818 -- Is_Power_Of_2_For_Shift is set means that we know that our left 6819 -- operand is an unsigned integer, as required for this to work. 6820 6821 if Nkind (Ropnd) = N_Op_Expon 6822 and then Is_Power_Of_2_For_Shift (Ropnd) 6823 6824 -- We cannot do this transformation in configurable run time mode if we 6825 -- have 64-bit integers and long shifts are not available. 6826 6827 and then 6828 (Esize (Ltyp) <= 32 6829 or else Support_Long_Shifts_On_Target) 6830 then 6831 Rewrite (N, 6832 Make_Op_Shift_Right (Loc, 6833 Left_Opnd => Lopnd, 6834 Right_Opnd => 6835 Convert_To (Standard_Natural, Right_Opnd (Ropnd)))); 6836 Analyze_And_Resolve (N, Typ); 6837 return; 6838 end if; 6839 6840 -- Do required fixup of universal fixed operation 6841 6842 if Typ = Universal_Fixed then 6843 Fixup_Universal_Fixed_Operation (N); 6844 Typ := Etype (N); 6845 end if; 6846 6847 -- Divisions with fixed-point results 6848 6849 if Is_Fixed_Point_Type (Typ) then 6850 6851 -- No special processing if Treat_Fixed_As_Integer is set, since 6852 -- from a semantic point of view such operations are simply integer 6853 -- operations and will be treated that way. 6854 6855 if not Treat_Fixed_As_Integer (N) then 6856 if Is_Integer_Type (Rtyp) then 6857 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); 6858 else 6859 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); 6860 end if; 6861 end if; 6862 6863 -- Other cases of division of fixed-point operands. Again we exclude the 6864 -- case where Treat_Fixed_As_Integer is set. 6865 6866 elsif (Is_Fixed_Point_Type (Ltyp) or else 6867 Is_Fixed_Point_Type (Rtyp)) 6868 and then not Treat_Fixed_As_Integer (N) 6869 then 6870 if Is_Integer_Type (Typ) then 6871 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); 6872 else 6873 pragma Assert (Is_Floating_Point_Type (Typ)); 6874 Expand_Divide_Fixed_By_Fixed_Giving_Float (N); 6875 end if; 6876 6877 -- Mixed-mode operations can appear in a non-static universal context, 6878 -- in which case the integer argument must be converted explicitly. 6879 6880 elsif Typ = Universal_Real 6881 and then Is_Integer_Type (Rtyp) 6882 then 6883 Rewrite (Ropnd, 6884 Convert_To (Universal_Real, Relocate_Node (Ropnd))); 6885 6886 Analyze_And_Resolve (Ropnd, Universal_Real); 6887 6888 elsif Typ = Universal_Real 6889 and then Is_Integer_Type (Ltyp) 6890 then 6891 Rewrite (Lopnd, 6892 Convert_To (Universal_Real, Relocate_Node (Lopnd))); 6893 6894 Analyze_And_Resolve (Lopnd, Universal_Real); 6895 6896 -- Non-fixed point cases, do integer zero divide and overflow checks 6897 6898 elsif Is_Integer_Type (Typ) then 6899 Apply_Divide_Checks (N); 6900 6901 -- Deal with Vax_Float 6902 6903 elsif Vax_Float (Typ) then 6904 Expand_Vax_Arith (N); 6905 return; 6906 end if; 6907 end Expand_N_Op_Divide; 6908 6909 -------------------- 6910 -- Expand_N_Op_Eq -- 6911 -------------------- 6912 6913 procedure Expand_N_Op_Eq (N : Node_Id) is 6914 Loc : constant Source_Ptr := Sloc (N); 6915 Typ : constant Entity_Id := Etype (N); 6916 Lhs : constant Node_Id := Left_Opnd (N); 6917 Rhs : constant Node_Id := Right_Opnd (N); 6918 Bodies : constant List_Id := New_List; 6919 A_Typ : constant Entity_Id := Etype (Lhs); 6920 6921 Typl : Entity_Id := A_Typ; 6922 Op_Name : Entity_Id; 6923 Prim : Elmt_Id; 6924 6925 procedure Build_Equality_Call (Eq : Entity_Id); 6926 -- If a constructed equality exists for the type or for its parent, 6927 -- build and analyze call, adding conversions if the operation is 6928 -- inherited. 6929 6930 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; 6931 -- Determines whether a type has a subcomponent of an unconstrained 6932 -- Unchecked_Union subtype. Typ is a record type. 6933 6934 ------------------------- 6935 -- Build_Equality_Call -- 6936 ------------------------- 6937 6938 procedure Build_Equality_Call (Eq : Entity_Id) is 6939 Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); 6940 L_Exp : Node_Id := Relocate_Node (Lhs); 6941 R_Exp : Node_Id := Relocate_Node (Rhs); 6942 6943 begin 6944 if Base_Type (Op_Type) /= Base_Type (A_Typ) 6945 and then not Is_Class_Wide_Type (A_Typ) 6946 then 6947 L_Exp := OK_Convert_To (Op_Type, L_Exp); 6948 R_Exp := OK_Convert_To (Op_Type, R_Exp); 6949 end if; 6950 6951 -- If we have an Unchecked_Union, we need to add the inferred 6952 -- discriminant values as actuals in the function call. At this 6953 -- point, the expansion has determined that both operands have 6954 -- inferable discriminants. 6955 6956 if Is_Unchecked_Union (Op_Type) then 6957 declare 6958 Lhs_Type : constant Node_Id := Etype (L_Exp); 6959 Rhs_Type : constant Node_Id := Etype (R_Exp); 6960 Lhs_Discr_Val : Node_Id; 6961 Rhs_Discr_Val : Node_Id; 6962 6963 begin 6964 -- Per-object constrained selected components require special 6965 -- attention. If the enclosing scope of the component is an 6966 -- Unchecked_Union, we cannot reference its discriminants 6967 -- directly. This is why we use the two extra parameters of 6968 -- the equality function of the enclosing Unchecked_Union. 6969 6970 -- type UU_Type (Discr : Integer := 0) is 6971 -- . . . 6972 -- end record; 6973 -- pragma Unchecked_Union (UU_Type); 6974 6975 -- 1. Unchecked_Union enclosing record: 6976 6977 -- type Enclosing_UU_Type (Discr : Integer := 0) is record 6978 -- . . . 6979 -- Comp : UU_Type (Discr); 6980 -- . . . 6981 -- end Enclosing_UU_Type; 6982 -- pragma Unchecked_Union (Enclosing_UU_Type); 6983 6984 -- Obj1 : Enclosing_UU_Type; 6985 -- Obj2 : Enclosing_UU_Type (1); 6986 6987 -- [. . .] Obj1 = Obj2 [. . .] 6988 6989 -- Generated code: 6990 6991 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then 6992 6993 -- A and B are the formal parameters of the equality function 6994 -- of Enclosing_UU_Type. The function always has two extra 6995 -- formals to capture the inferred discriminant values. 6996 6997 -- 2. Non-Unchecked_Union enclosing record: 6998 6999 -- type 7000 -- Enclosing_Non_UU_Type (Discr : Integer := 0) 7001 -- is record 7002 -- . . . 7003 -- Comp : UU_Type (Discr); 7004 -- . . . 7005 -- end Enclosing_Non_UU_Type; 7006 7007 -- Obj1 : Enclosing_Non_UU_Type; 7008 -- Obj2 : Enclosing_Non_UU_Type (1); 7009 7010 -- ... Obj1 = Obj2 ... 7011 7012 -- Generated code: 7013 7014 -- if not (uu_typeEQ (obj1.comp, obj2.comp, 7015 -- obj1.discr, obj2.discr)) then 7016 7017 -- In this case we can directly reference the discriminants of 7018 -- the enclosing record. 7019 7020 -- Lhs of equality 7021 7022 if Nkind (Lhs) = N_Selected_Component 7023 and then Has_Per_Object_Constraint 7024 (Entity (Selector_Name (Lhs))) 7025 then 7026 -- Enclosing record is an Unchecked_Union, use formal A 7027 7028 if Is_Unchecked_Union 7029 (Scope (Entity (Selector_Name (Lhs)))) 7030 then 7031 Lhs_Discr_Val := Make_Identifier (Loc, Name_A); 7032 7033 -- Enclosing record is of a non-Unchecked_Union type, it is 7034 -- possible to reference the discriminant. 7035 7036 else 7037 Lhs_Discr_Val := 7038 Make_Selected_Component (Loc, 7039 Prefix => Prefix (Lhs), 7040 Selector_Name => 7041 New_Copy 7042 (Get_Discriminant_Value 7043 (First_Discriminant (Lhs_Type), 7044 Lhs_Type, 7045 Stored_Constraint (Lhs_Type)))); 7046 end if; 7047 7048 -- Comment needed here ??? 7049 7050 else 7051 -- Infer the discriminant value 7052 7053 Lhs_Discr_Val := 7054 New_Copy 7055 (Get_Discriminant_Value 7056 (First_Discriminant (Lhs_Type), 7057 Lhs_Type, 7058 Stored_Constraint (Lhs_Type))); 7059 end if; 7060 7061 -- Rhs of equality 7062 7063 if Nkind (Rhs) = N_Selected_Component 7064 and then Has_Per_Object_Constraint 7065 (Entity (Selector_Name (Rhs))) 7066 then 7067 if Is_Unchecked_Union 7068 (Scope (Entity (Selector_Name (Rhs)))) 7069 then 7070 Rhs_Discr_Val := Make_Identifier (Loc, Name_B); 7071 7072 else 7073 Rhs_Discr_Val := 7074 Make_Selected_Component (Loc, 7075 Prefix => Prefix (Rhs), 7076 Selector_Name => 7077 New_Copy (Get_Discriminant_Value ( 7078 First_Discriminant (Rhs_Type), 7079 Rhs_Type, 7080 Stored_Constraint (Rhs_Type)))); 7081 7082 end if; 7083 else 7084 Rhs_Discr_Val := 7085 New_Copy (Get_Discriminant_Value ( 7086 First_Discriminant (Rhs_Type), 7087 Rhs_Type, 7088 Stored_Constraint (Rhs_Type))); 7089 7090 end if; 7091 7092 Rewrite (N, 7093 Make_Function_Call (Loc, 7094 Name => New_Reference_To (Eq, Loc), 7095 Parameter_Associations => New_List ( 7096 L_Exp, 7097 R_Exp, 7098 Lhs_Discr_Val, 7099 Rhs_Discr_Val))); 7100 end; 7101 7102 -- Normal case, not an unchecked union 7103 7104 else 7105 Rewrite (N, 7106 Make_Function_Call (Loc, 7107 Name => New_Reference_To (Eq, Loc), 7108 Parameter_Associations => New_List (L_Exp, R_Exp))); 7109 end if; 7110 7111 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7112 end Build_Equality_Call; 7113 7114 ------------------------------------ 7115 -- Has_Unconstrained_UU_Component -- 7116 ------------------------------------ 7117 7118 function Has_Unconstrained_UU_Component 7119 (Typ : Node_Id) return Boolean 7120 is 7121 Tdef : constant Node_Id := 7122 Type_Definition (Declaration_Node (Base_Type (Typ))); 7123 Clist : Node_Id; 7124 Vpart : Node_Id; 7125 7126 function Component_Is_Unconstrained_UU 7127 (Comp : Node_Id) return Boolean; 7128 -- Determines whether the subtype of the component is an 7129 -- unconstrained Unchecked_Union. 7130 7131 function Variant_Is_Unconstrained_UU 7132 (Variant : Node_Id) return Boolean; 7133 -- Determines whether a component of the variant has an unconstrained 7134 -- Unchecked_Union subtype. 7135 7136 ----------------------------------- 7137 -- Component_Is_Unconstrained_UU -- 7138 ----------------------------------- 7139 7140 function Component_Is_Unconstrained_UU 7141 (Comp : Node_Id) return Boolean 7142 is 7143 begin 7144 if Nkind (Comp) /= N_Component_Declaration then 7145 return False; 7146 end if; 7147 7148 declare 7149 Sindic : constant Node_Id := 7150 Subtype_Indication (Component_Definition (Comp)); 7151 7152 begin 7153 -- Unconstrained nominal type. In the case of a constraint 7154 -- present, the node kind would have been N_Subtype_Indication. 7155 7156 if Nkind (Sindic) = N_Identifier then 7157 return Is_Unchecked_Union (Base_Type (Etype (Sindic))); 7158 end if; 7159 7160 return False; 7161 end; 7162 end Component_Is_Unconstrained_UU; 7163 7164 --------------------------------- 7165 -- Variant_Is_Unconstrained_UU -- 7166 --------------------------------- 7167 7168 function Variant_Is_Unconstrained_UU 7169 (Variant : Node_Id) return Boolean 7170 is 7171 Clist : constant Node_Id := Component_List (Variant); 7172 7173 begin 7174 if Is_Empty_List (Component_Items (Clist)) then 7175 return False; 7176 end if; 7177 7178 -- We only need to test one component 7179 7180 declare 7181 Comp : Node_Id := First (Component_Items (Clist)); 7182 7183 begin 7184 while Present (Comp) loop 7185 if Component_Is_Unconstrained_UU (Comp) then 7186 return True; 7187 end if; 7188 7189 Next (Comp); 7190 end loop; 7191 end; 7192 7193 -- None of the components withing the variant were of 7194 -- unconstrained Unchecked_Union type. 7195 7196 return False; 7197 end Variant_Is_Unconstrained_UU; 7198 7199 -- Start of processing for Has_Unconstrained_UU_Component 7200 7201 begin 7202 if Null_Present (Tdef) then 7203 return False; 7204 end if; 7205 7206 Clist := Component_List (Tdef); 7207 Vpart := Variant_Part (Clist); 7208 7209 -- Inspect available components 7210 7211 if Present (Component_Items (Clist)) then 7212 declare 7213 Comp : Node_Id := First (Component_Items (Clist)); 7214 7215 begin 7216 while Present (Comp) loop 7217 7218 -- One component is sufficient 7219 7220 if Component_Is_Unconstrained_UU (Comp) then 7221 return True; 7222 end if; 7223 7224 Next (Comp); 7225 end loop; 7226 end; 7227 end if; 7228 7229 -- Inspect available components withing variants 7230 7231 if Present (Vpart) then 7232 declare 7233 Variant : Node_Id := First (Variants (Vpart)); 7234 7235 begin 7236 while Present (Variant) loop 7237 7238 -- One component within a variant is sufficient 7239 7240 if Variant_Is_Unconstrained_UU (Variant) then 7241 return True; 7242 end if; 7243 7244 Next (Variant); 7245 end loop; 7246 end; 7247 end if; 7248 7249 -- Neither the available components, nor the components inside the 7250 -- variant parts were of an unconstrained Unchecked_Union subtype. 7251 7252 return False; 7253 end Has_Unconstrained_UU_Component; 7254 7255 -- Start of processing for Expand_N_Op_Eq 7256 7257 begin 7258 Binary_Op_Validity_Checks (N); 7259 7260 -- Deal with private types 7261 7262 if Ekind (Typl) = E_Private_Type then 7263 Typl := Underlying_Type (Typl); 7264 elsif Ekind (Typl) = E_Private_Subtype then 7265 Typl := Underlying_Type (Base_Type (Typl)); 7266 else 7267 null; 7268 end if; 7269 7270 -- It may happen in error situations that the underlying type is not 7271 -- set. The error will be detected later, here we just defend the 7272 -- expander code. 7273 7274 if No (Typl) then 7275 return; 7276 end if; 7277 7278 Typl := Base_Type (Typl); 7279 7280 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 7281 -- means we no longer have a comparison operation, we are all done. 7282 7283 Expand_Compare_Minimize_Eliminate_Overflow (N); 7284 7285 if Nkind (N) /= N_Op_Eq then 7286 return; 7287 end if; 7288 7289 -- Boolean types (requiring handling of non-standard case) 7290 7291 if Is_Boolean_Type (Typl) then 7292 Adjust_Condition (Left_Opnd (N)); 7293 Adjust_Condition (Right_Opnd (N)); 7294 Set_Etype (N, Standard_Boolean); 7295 Adjust_Result_Type (N, Typ); 7296 7297 -- Array types 7298 7299 elsif Is_Array_Type (Typl) then 7300 7301 -- If we are doing full validity checking, and it is possible for the 7302 -- array elements to be invalid then expand out array comparisons to 7303 -- make sure that we check the array elements. 7304 7305 if Validity_Check_Operands 7306 and then not Is_Known_Valid (Component_Type (Typl)) 7307 then 7308 declare 7309 Save_Force_Validity_Checks : constant Boolean := 7310 Force_Validity_Checks; 7311 begin 7312 Force_Validity_Checks := True; 7313 Rewrite (N, 7314 Expand_Array_Equality 7315 (N, 7316 Relocate_Node (Lhs), 7317 Relocate_Node (Rhs), 7318 Bodies, 7319 Typl)); 7320 Insert_Actions (N, Bodies); 7321 Analyze_And_Resolve (N, Standard_Boolean); 7322 Force_Validity_Checks := Save_Force_Validity_Checks; 7323 end; 7324 7325 -- Packed case where both operands are known aligned 7326 7327 elsif Is_Bit_Packed_Array (Typl) 7328 and then not Is_Possibly_Unaligned_Object (Lhs) 7329 and then not Is_Possibly_Unaligned_Object (Rhs) 7330 then 7331 Expand_Packed_Eq (N); 7332 7333 -- Where the component type is elementary we can use a block bit 7334 -- comparison (if supported on the target) exception in the case 7335 -- of floating-point (negative zero issues require element by 7336 -- element comparison), and atomic types (where we must be sure 7337 -- to load elements independently) and possibly unaligned arrays. 7338 7339 elsif Is_Elementary_Type (Component_Type (Typl)) 7340 and then not Is_Floating_Point_Type (Component_Type (Typl)) 7341 and then not Is_Atomic (Component_Type (Typl)) 7342 and then not Is_Possibly_Unaligned_Object (Lhs) 7343 and then not Is_Possibly_Unaligned_Object (Rhs) 7344 and then Support_Composite_Compare_On_Target 7345 then 7346 null; 7347 7348 -- For composite and floating-point cases, expand equality loop to 7349 -- make sure of using proper comparisons for tagged types, and 7350 -- correctly handling the floating-point case. 7351 7352 else 7353 Rewrite (N, 7354 Expand_Array_Equality 7355 (N, 7356 Relocate_Node (Lhs), 7357 Relocate_Node (Rhs), 7358 Bodies, 7359 Typl)); 7360 Insert_Actions (N, Bodies, Suppress => All_Checks); 7361 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7362 end if; 7363 7364 -- Record Types 7365 7366 elsif Is_Record_Type (Typl) then 7367 7368 -- For tagged types, use the primitive "=" 7369 7370 if Is_Tagged_Type (Typl) then 7371 7372 -- No need to do anything else compiling under restriction 7373 -- No_Dispatching_Calls. During the semantic analysis we 7374 -- already notified such violation. 7375 7376 if Restriction_Active (No_Dispatching_Calls) then 7377 return; 7378 end if; 7379 7380 -- If this is derived from an untagged private type completed with 7381 -- a tagged type, it does not have a full view, so we use the 7382 -- primitive operations of the private type. This check should no 7383 -- longer be necessary when these types get their full views??? 7384 7385 if Is_Private_Type (A_Typ) 7386 and then not Is_Tagged_Type (A_Typ) 7387 and then Is_Derived_Type (A_Typ) 7388 and then No (Full_View (A_Typ)) 7389 then 7390 -- Search for equality operation, checking that the operands 7391 -- have the same type. Note that we must find a matching entry, 7392 -- or something is very wrong! 7393 7394 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); 7395 7396 while Present (Prim) loop 7397 exit when Chars (Node (Prim)) = Name_Op_Eq 7398 and then Etype (First_Formal (Node (Prim))) = 7399 Etype (Next_Formal (First_Formal (Node (Prim)))) 7400 and then 7401 Base_Type (Etype (Node (Prim))) = Standard_Boolean; 7402 7403 Next_Elmt (Prim); 7404 end loop; 7405 7406 pragma Assert (Present (Prim)); 7407 Op_Name := Node (Prim); 7408 7409 -- Find the type's predefined equality or an overriding 7410 -- user- defined equality. The reason for not simply calling 7411 -- Find_Prim_Op here is that there may be a user-defined 7412 -- overloaded equality op that precedes the equality that we want, 7413 -- so we have to explicitly search (e.g., there could be an 7414 -- equality with two different parameter types). 7415 7416 else 7417 if Is_Class_Wide_Type (Typl) then 7418 Typl := Root_Type (Typl); 7419 end if; 7420 7421 Prim := First_Elmt (Primitive_Operations (Typl)); 7422 while Present (Prim) loop 7423 exit when Chars (Node (Prim)) = Name_Op_Eq 7424 and then Etype (First_Formal (Node (Prim))) = 7425 Etype (Next_Formal (First_Formal (Node (Prim)))) 7426 and then 7427 Base_Type (Etype (Node (Prim))) = Standard_Boolean; 7428 7429 Next_Elmt (Prim); 7430 end loop; 7431 7432 pragma Assert (Present (Prim)); 7433 Op_Name := Node (Prim); 7434 end if; 7435 7436 Build_Equality_Call (Op_Name); 7437 7438 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the 7439 -- predefined equality operator for a type which has a subcomponent 7440 -- of an Unchecked_Union type whose nominal subtype is unconstrained. 7441 7442 elsif Has_Unconstrained_UU_Component (Typl) then 7443 Insert_Action (N, 7444 Make_Raise_Program_Error (Loc, 7445 Reason => PE_Unchecked_Union_Restriction)); 7446 7447 -- Prevent Gigi from generating incorrect code by rewriting the 7448 -- equality as a standard False. (is this documented somewhere???) 7449 7450 Rewrite (N, 7451 New_Occurrence_Of (Standard_False, Loc)); 7452 7453 elsif Is_Unchecked_Union (Typl) then 7454 7455 -- If we can infer the discriminants of the operands, we make a 7456 -- call to the TSS equality function. 7457 7458 if Has_Inferable_Discriminants (Lhs) 7459 and then 7460 Has_Inferable_Discriminants (Rhs) 7461 then 7462 Build_Equality_Call 7463 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 7464 7465 else 7466 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 7467 -- the predefined equality operator for an Unchecked_Union type 7468 -- if either of the operands lack inferable discriminants. 7469 7470 Insert_Action (N, 7471 Make_Raise_Program_Error (Loc, 7472 Reason => PE_Unchecked_Union_Restriction)); 7473 7474 -- Prevent Gigi from generating incorrect code by rewriting 7475 -- the equality as a standard False (documented where???). 7476 7477 Rewrite (N, 7478 New_Occurrence_Of (Standard_False, Loc)); 7479 7480 end if; 7481 7482 -- If a type support function is present (for complex cases), use it 7483 7484 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then 7485 Build_Equality_Call 7486 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 7487 7488 -- Otherwise expand the component by component equality. Note that 7489 -- we never use block-bit comparisons for records, because of the 7490 -- problems with gaps. The backend will often be able to recombine 7491 -- the separate comparisons that we generate here. 7492 7493 else 7494 Remove_Side_Effects (Lhs); 7495 Remove_Side_Effects (Rhs); 7496 Rewrite (N, 7497 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); 7498 7499 Insert_Actions (N, Bodies, Suppress => All_Checks); 7500 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7501 end if; 7502 end if; 7503 7504 -- Test if result is known at compile time 7505 7506 Rewrite_Comparison (N); 7507 7508 -- If we still have comparison for Vax_Float, process it 7509 7510 if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then 7511 Expand_Vax_Comparison (N); 7512 return; 7513 end if; 7514 7515 Optimize_Length_Comparison (N); 7516 end Expand_N_Op_Eq; 7517 7518 ----------------------- 7519 -- Expand_N_Op_Expon -- 7520 ----------------------- 7521 7522 procedure Expand_N_Op_Expon (N : Node_Id) is 7523 Loc : constant Source_Ptr := Sloc (N); 7524 Typ : constant Entity_Id := Etype (N); 7525 Rtyp : constant Entity_Id := Root_Type (Typ); 7526 Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); 7527 Bastyp : constant Node_Id := Etype (Base); 7528 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); 7529 Exptyp : constant Entity_Id := Etype (Exp); 7530 Ovflo : constant Boolean := Do_Overflow_Check (N); 7531 Expv : Uint; 7532 Temp : Node_Id; 7533 Rent : RE_Id; 7534 Ent : Entity_Id; 7535 Etyp : Entity_Id; 7536 Xnode : Node_Id; 7537 7538 begin 7539 Binary_Op_Validity_Checks (N); 7540 7541 -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node 7542 7543 if CodePeer_Mode or Alfa_Mode then 7544 return; 7545 end if; 7546 7547 -- If either operand is of a private type, then we have the use of an 7548 -- intrinsic operator, and we get rid of the privateness, by using root 7549 -- types of underlying types for the actual operation. Otherwise the 7550 -- private types will cause trouble if we expand multiplications or 7551 -- shifts etc. We also do this transformation if the result type is 7552 -- different from the base type. 7553 7554 if Is_Private_Type (Etype (Base)) 7555 or else Is_Private_Type (Typ) 7556 or else Is_Private_Type (Exptyp) 7557 or else Rtyp /= Root_Type (Bastyp) 7558 then 7559 declare 7560 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); 7561 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); 7562 7563 begin 7564 Rewrite (N, 7565 Unchecked_Convert_To (Typ, 7566 Make_Op_Expon (Loc, 7567 Left_Opnd => Unchecked_Convert_To (Bt, Base), 7568 Right_Opnd => Unchecked_Convert_To (Et, Exp)))); 7569 Analyze_And_Resolve (N, Typ); 7570 return; 7571 end; 7572 end if; 7573 7574 -- Check for MINIMIZED/ELIMINATED overflow mode 7575 7576 if Minimized_Eliminated_Overflow_Check (N) then 7577 Apply_Arithmetic_Overflow_Check (N); 7578 return; 7579 end if; 7580 7581 -- Test for case of known right argument where we can replace the 7582 -- exponentiation by an equivalent expression using multiplication. 7583 7584 if Compile_Time_Known_Value (Exp) then 7585 Expv := Expr_Value (Exp); 7586 7587 -- We only fold small non-negative exponents. You might think we 7588 -- could fold small negative exponents for the real case, but we 7589 -- can't because we are required to raise Constraint_Error for 7590 -- the case of 0.0 ** (negative) even if Machine_Overflows = False. 7591 -- See ACVC test C4A012B. 7592 7593 if Expv >= 0 and then Expv <= 4 then 7594 7595 -- X ** 0 = 1 (or 1.0) 7596 7597 if Expv = 0 then 7598 7599 -- Call Remove_Side_Effects to ensure that any side effects 7600 -- in the ignored left operand (in particular function calls 7601 -- to user defined functions) are properly executed. 7602 7603 Remove_Side_Effects (Base); 7604 7605 if Ekind (Typ) in Integer_Kind then 7606 Xnode := Make_Integer_Literal (Loc, Intval => 1); 7607 else 7608 Xnode := Make_Real_Literal (Loc, Ureal_1); 7609 end if; 7610 7611 -- X ** 1 = X 7612 7613 elsif Expv = 1 then 7614 Xnode := Base; 7615 7616 -- X ** 2 = X * X 7617 7618 elsif Expv = 2 then 7619 Xnode := 7620 Make_Op_Multiply (Loc, 7621 Left_Opnd => Duplicate_Subexpr (Base), 7622 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)); 7623 7624 -- X ** 3 = X * X * X 7625 7626 elsif Expv = 3 then 7627 Xnode := 7628 Make_Op_Multiply (Loc, 7629 Left_Opnd => 7630 Make_Op_Multiply (Loc, 7631 Left_Opnd => Duplicate_Subexpr (Base), 7632 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)), 7633 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)); 7634 7635 -- X ** 4 -> 7636 7637 -- do 7638 -- En : constant base'type := base * base; 7639 -- in 7640 -- En * En 7641 7642 else 7643 pragma Assert (Expv = 4); 7644 Temp := Make_Temporary (Loc, 'E', Base); 7645 7646 Xnode := 7647 Make_Expression_With_Actions (Loc, 7648 Actions => New_List ( 7649 Make_Object_Declaration (Loc, 7650 Defining_Identifier => Temp, 7651 Constant_Present => True, 7652 Object_Definition => New_Reference_To (Typ, Loc), 7653 Expression => 7654 Make_Op_Multiply (Loc, 7655 Left_Opnd => 7656 Duplicate_Subexpr (Base), 7657 Right_Opnd => 7658 Duplicate_Subexpr_No_Checks (Base)))), 7659 7660 Expression => 7661 Make_Op_Multiply (Loc, 7662 Left_Opnd => New_Reference_To (Temp, Loc), 7663 Right_Opnd => New_Reference_To (Temp, Loc))); 7664 end if; 7665 7666 Rewrite (N, Xnode); 7667 Analyze_And_Resolve (N, Typ); 7668 return; 7669 end if; 7670 end if; 7671 7672 -- Case of (2 ** expression) appearing as an argument of an integer 7673 -- multiplication, or as the right argument of a division of a non- 7674 -- negative integer. In such cases we leave the node untouched, setting 7675 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion 7676 -- of the higher level node converts it into a shift. 7677 7678 -- Another case is 2 ** N in any other context. We simply convert 7679 -- this to 1 * 2 ** N, and then the above transformation applies. 7680 7681 -- Note: this transformation is not applicable for a modular type with 7682 -- a non-binary modulus in the multiplication case, since we get a wrong 7683 -- result if the shift causes an overflow before the modular reduction. 7684 7685 if Nkind (Base) = N_Integer_Literal 7686 and then Intval (Base) = 2 7687 and then Is_Integer_Type (Root_Type (Exptyp)) 7688 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) 7689 and then Is_Unsigned_Type (Exptyp) 7690 and then not Ovflo 7691 then 7692 -- First the multiply and divide cases 7693 7694 if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then 7695 declare 7696 P : constant Node_Id := Parent (N); 7697 L : constant Node_Id := Left_Opnd (P); 7698 R : constant Node_Id := Right_Opnd (P); 7699 7700 begin 7701 if (Nkind (P) = N_Op_Multiply 7702 and then not Non_Binary_Modulus (Typ) 7703 and then 7704 ((Is_Integer_Type (Etype (L)) and then R = N) 7705 or else 7706 (Is_Integer_Type (Etype (R)) and then L = N)) 7707 and then not Do_Overflow_Check (P)) 7708 or else 7709 (Nkind (P) = N_Op_Divide 7710 and then Is_Integer_Type (Etype (L)) 7711 and then Is_Unsigned_Type (Etype (L)) 7712 and then R = N 7713 and then not Do_Overflow_Check (P)) 7714 then 7715 Set_Is_Power_Of_2_For_Shift (N); 7716 return; 7717 end if; 7718 end; 7719 7720 -- Now the other cases 7721 7722 elsif not Non_Binary_Modulus (Typ) then 7723 Rewrite (N, 7724 Make_Op_Multiply (Loc, 7725 Left_Opnd => Make_Integer_Literal (Loc, 1), 7726 Right_Opnd => Relocate_Node (N))); 7727 Analyze_And_Resolve (N, Typ); 7728 return; 7729 end if; 7730 end if; 7731 7732 -- Fall through if exponentiation must be done using a runtime routine 7733 7734 -- First deal with modular case 7735 7736 if Is_Modular_Integer_Type (Rtyp) then 7737 7738 -- Non-binary case, we call the special exponentiation routine for 7739 -- the non-binary case, converting the argument to Long_Long_Integer 7740 -- and passing the modulus value. Then the result is converted back 7741 -- to the base type. 7742 7743 if Non_Binary_Modulus (Rtyp) then 7744 Rewrite (N, 7745 Convert_To (Typ, 7746 Make_Function_Call (Loc, 7747 Name => New_Reference_To (RTE (RE_Exp_Modular), Loc), 7748 Parameter_Associations => New_List ( 7749 Convert_To (Standard_Integer, Base), 7750 Make_Integer_Literal (Loc, Modulus (Rtyp)), 7751 Exp)))); 7752 7753 -- Binary case, in this case, we call one of two routines, either the 7754 -- unsigned integer case, or the unsigned long long integer case, 7755 -- with a final "and" operation to do the required mod. 7756 7757 else 7758 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 7759 Ent := RTE (RE_Exp_Unsigned); 7760 else 7761 Ent := RTE (RE_Exp_Long_Long_Unsigned); 7762 end if; 7763 7764 Rewrite (N, 7765 Convert_To (Typ, 7766 Make_Op_And (Loc, 7767 Left_Opnd => 7768 Make_Function_Call (Loc, 7769 Name => New_Reference_To (Ent, Loc), 7770 Parameter_Associations => New_List ( 7771 Convert_To (Etype (First_Formal (Ent)), Base), 7772 Exp)), 7773 Right_Opnd => 7774 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); 7775 7776 end if; 7777 7778 -- Common exit point for modular type case 7779 7780 Analyze_And_Resolve (N, Typ); 7781 return; 7782 7783 -- Signed integer cases, done using either Integer or Long_Long_Integer. 7784 -- It is not worth having routines for Short_[Short_]Integer, since for 7785 -- most machines it would not help, and it would generate more code that 7786 -- might need certification when a certified run time is required. 7787 7788 -- In the integer cases, we have two routines, one for when overflow 7789 -- checks are required, and one when they are not required, since there 7790 -- is a real gain in omitting checks on many machines. 7791 7792 elsif Rtyp = Base_Type (Standard_Long_Long_Integer) 7793 or else (Rtyp = Base_Type (Standard_Long_Integer) 7794 and then 7795 Esize (Standard_Long_Integer) > Esize (Standard_Integer)) 7796 or else (Rtyp = Universal_Integer) 7797 then 7798 Etyp := Standard_Long_Long_Integer; 7799 7800 if Ovflo then 7801 Rent := RE_Exp_Long_Long_Integer; 7802 else 7803 Rent := RE_Exn_Long_Long_Integer; 7804 end if; 7805 7806 elsif Is_Signed_Integer_Type (Rtyp) then 7807 Etyp := Standard_Integer; 7808 7809 if Ovflo then 7810 Rent := RE_Exp_Integer; 7811 else 7812 Rent := RE_Exn_Integer; 7813 end if; 7814 7815 -- Floating-point cases, always done using Long_Long_Float. We do not 7816 -- need separate routines for the overflow case here, since in the case 7817 -- of floating-point, we generate infinities anyway as a rule (either 7818 -- that or we automatically trap overflow), and if there is an infinity 7819 -- generated and a range check is required, the check will fail anyway. 7820 7821 else 7822 pragma Assert (Is_Floating_Point_Type (Rtyp)); 7823 Etyp := Standard_Long_Long_Float; 7824 Rent := RE_Exn_Long_Long_Float; 7825 end if; 7826 7827 -- Common processing for integer cases and floating-point cases. 7828 -- If we are in the right type, we can call runtime routine directly 7829 7830 if Typ = Etyp 7831 and then Rtyp /= Universal_Integer 7832 and then Rtyp /= Universal_Real 7833 then 7834 Rewrite (N, 7835 Make_Function_Call (Loc, 7836 Name => New_Reference_To (RTE (Rent), Loc), 7837 Parameter_Associations => New_List (Base, Exp))); 7838 7839 -- Otherwise we have to introduce conversions (conversions are also 7840 -- required in the universal cases, since the runtime routine is 7841 -- typed using one of the standard types). 7842 7843 else 7844 Rewrite (N, 7845 Convert_To (Typ, 7846 Make_Function_Call (Loc, 7847 Name => New_Reference_To (RTE (Rent), Loc), 7848 Parameter_Associations => New_List ( 7849 Convert_To (Etyp, Base), 7850 Exp)))); 7851 end if; 7852 7853 Analyze_And_Resolve (N, Typ); 7854 return; 7855 7856 exception 7857 when RE_Not_Available => 7858 return; 7859 end Expand_N_Op_Expon; 7860 7861 -------------------- 7862 -- Expand_N_Op_Ge -- 7863 -------------------- 7864 7865 procedure Expand_N_Op_Ge (N : Node_Id) is 7866 Typ : constant Entity_Id := Etype (N); 7867 Op1 : constant Node_Id := Left_Opnd (N); 7868 Op2 : constant Node_Id := Right_Opnd (N); 7869 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 7870 7871 begin 7872 Binary_Op_Validity_Checks (N); 7873 7874 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 7875 -- means we no longer have a comparison operation, we are all done. 7876 7877 Expand_Compare_Minimize_Eliminate_Overflow (N); 7878 7879 if Nkind (N) /= N_Op_Ge then 7880 return; 7881 end if; 7882 7883 -- Array type case 7884 7885 if Is_Array_Type (Typ1) then 7886 Expand_Array_Comparison (N); 7887 return; 7888 end if; 7889 7890 -- Deal with boolean operands 7891 7892 if Is_Boolean_Type (Typ1) then 7893 Adjust_Condition (Op1); 7894 Adjust_Condition (Op2); 7895 Set_Etype (N, Standard_Boolean); 7896 Adjust_Result_Type (N, Typ); 7897 end if; 7898 7899 Rewrite_Comparison (N); 7900 7901 -- If we still have comparison, and Vax_Float type, process it 7902 7903 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then 7904 Expand_Vax_Comparison (N); 7905 return; 7906 end if; 7907 7908 Optimize_Length_Comparison (N); 7909 end Expand_N_Op_Ge; 7910 7911 -------------------- 7912 -- Expand_N_Op_Gt -- 7913 -------------------- 7914 7915 procedure Expand_N_Op_Gt (N : Node_Id) is 7916 Typ : constant Entity_Id := Etype (N); 7917 Op1 : constant Node_Id := Left_Opnd (N); 7918 Op2 : constant Node_Id := Right_Opnd (N); 7919 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 7920 7921 begin 7922 Binary_Op_Validity_Checks (N); 7923 7924 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 7925 -- means we no longer have a comparison operation, we are all done. 7926 7927 Expand_Compare_Minimize_Eliminate_Overflow (N); 7928 7929 if Nkind (N) /= N_Op_Gt then 7930 return; 7931 end if; 7932 7933 -- Deal with array type operands 7934 7935 if Is_Array_Type (Typ1) then 7936 Expand_Array_Comparison (N); 7937 return; 7938 end if; 7939 7940 -- Deal with boolean type operands 7941 7942 if Is_Boolean_Type (Typ1) then 7943 Adjust_Condition (Op1); 7944 Adjust_Condition (Op2); 7945 Set_Etype (N, Standard_Boolean); 7946 Adjust_Result_Type (N, Typ); 7947 end if; 7948 7949 Rewrite_Comparison (N); 7950 7951 -- If we still have comparison, and Vax_Float type, process it 7952 7953 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then 7954 Expand_Vax_Comparison (N); 7955 return; 7956 end if; 7957 7958 Optimize_Length_Comparison (N); 7959 end Expand_N_Op_Gt; 7960 7961 -------------------- 7962 -- Expand_N_Op_Le -- 7963 -------------------- 7964 7965 procedure Expand_N_Op_Le (N : Node_Id) is 7966 Typ : constant Entity_Id := Etype (N); 7967 Op1 : constant Node_Id := Left_Opnd (N); 7968 Op2 : constant Node_Id := Right_Opnd (N); 7969 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 7970 7971 begin 7972 Binary_Op_Validity_Checks (N); 7973 7974 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 7975 -- means we no longer have a comparison operation, we are all done. 7976 7977 Expand_Compare_Minimize_Eliminate_Overflow (N); 7978 7979 if Nkind (N) /= N_Op_Le then 7980 return; 7981 end if; 7982 7983 -- Deal with array type operands 7984 7985 if Is_Array_Type (Typ1) then 7986 Expand_Array_Comparison (N); 7987 return; 7988 end if; 7989 7990 -- Deal with Boolean type operands 7991 7992 if Is_Boolean_Type (Typ1) then 7993 Adjust_Condition (Op1); 7994 Adjust_Condition (Op2); 7995 Set_Etype (N, Standard_Boolean); 7996 Adjust_Result_Type (N, Typ); 7997 end if; 7998 7999 Rewrite_Comparison (N); 8000 8001 -- If we still have comparison, and Vax_Float type, process it 8002 8003 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then 8004 Expand_Vax_Comparison (N); 8005 return; 8006 end if; 8007 8008 Optimize_Length_Comparison (N); 8009 end Expand_N_Op_Le; 8010 8011 -------------------- 8012 -- Expand_N_Op_Lt -- 8013 -------------------- 8014 8015 procedure Expand_N_Op_Lt (N : Node_Id) is 8016 Typ : constant Entity_Id := Etype (N); 8017 Op1 : constant Node_Id := Left_Opnd (N); 8018 Op2 : constant Node_Id := Right_Opnd (N); 8019 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 8020 8021 begin 8022 Binary_Op_Validity_Checks (N); 8023 8024 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8025 -- means we no longer have a comparison operation, we are all done. 8026 8027 Expand_Compare_Minimize_Eliminate_Overflow (N); 8028 8029 if Nkind (N) /= N_Op_Lt then 8030 return; 8031 end if; 8032 8033 -- Deal with array type operands 8034 8035 if Is_Array_Type (Typ1) then 8036 Expand_Array_Comparison (N); 8037 return; 8038 end if; 8039 8040 -- Deal with Boolean type operands 8041 8042 if Is_Boolean_Type (Typ1) then 8043 Adjust_Condition (Op1); 8044 Adjust_Condition (Op2); 8045 Set_Etype (N, Standard_Boolean); 8046 Adjust_Result_Type (N, Typ); 8047 end if; 8048 8049 Rewrite_Comparison (N); 8050 8051 -- If we still have comparison, and Vax_Float type, process it 8052 8053 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then 8054 Expand_Vax_Comparison (N); 8055 return; 8056 end if; 8057 8058 Optimize_Length_Comparison (N); 8059 end Expand_N_Op_Lt; 8060 8061 ----------------------- 8062 -- Expand_N_Op_Minus -- 8063 ----------------------- 8064 8065 procedure Expand_N_Op_Minus (N : Node_Id) is 8066 Loc : constant Source_Ptr := Sloc (N); 8067 Typ : constant Entity_Id := Etype (N); 8068 8069 begin 8070 Unary_Op_Validity_Checks (N); 8071 8072 -- Check for MINIMIZED/ELIMINATED overflow mode 8073 8074 if Minimized_Eliminated_Overflow_Check (N) then 8075 Apply_Arithmetic_Overflow_Check (N); 8076 return; 8077 end if; 8078 8079 if not Backend_Overflow_Checks_On_Target 8080 and then Is_Signed_Integer_Type (Etype (N)) 8081 and then Do_Overflow_Check (N) 8082 then 8083 -- Software overflow checking expands -expr into (0 - expr) 8084 8085 Rewrite (N, 8086 Make_Op_Subtract (Loc, 8087 Left_Opnd => Make_Integer_Literal (Loc, 0), 8088 Right_Opnd => Right_Opnd (N))); 8089 8090 Analyze_And_Resolve (N, Typ); 8091 8092 -- Vax floating-point types case 8093 8094 elsif Vax_Float (Etype (N)) then 8095 Expand_Vax_Arith (N); 8096 end if; 8097 end Expand_N_Op_Minus; 8098 8099 --------------------- 8100 -- Expand_N_Op_Mod -- 8101 --------------------- 8102 8103 procedure Expand_N_Op_Mod (N : Node_Id) is 8104 Loc : constant Source_Ptr := Sloc (N); 8105 Typ : constant Entity_Id := Etype (N); 8106 DDC : constant Boolean := Do_Division_Check (N); 8107 8108 Left : Node_Id; 8109 Right : Node_Id; 8110 8111 LLB : Uint; 8112 Llo : Uint; 8113 Lhi : Uint; 8114 LOK : Boolean; 8115 Rlo : Uint; 8116 Rhi : Uint; 8117 ROK : Boolean; 8118 8119 pragma Warnings (Off, Lhi); 8120 8121 begin 8122 Binary_Op_Validity_Checks (N); 8123 8124 -- Check for MINIMIZED/ELIMINATED overflow mode 8125 8126 if Minimized_Eliminated_Overflow_Check (N) then 8127 Apply_Arithmetic_Overflow_Check (N); 8128 return; 8129 end if; 8130 8131 if Is_Integer_Type (Etype (N)) then 8132 Apply_Divide_Checks (N); 8133 8134 -- All done if we don't have a MOD any more, which can happen as a 8135 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 8136 8137 if Nkind (N) /= N_Op_Mod then 8138 return; 8139 end if; 8140 end if; 8141 8142 -- Proceed with expansion of mod operator 8143 8144 Left := Left_Opnd (N); 8145 Right := Right_Opnd (N); 8146 8147 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); 8148 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); 8149 8150 -- Convert mod to rem if operands are known non-negative. We do this 8151 -- since it is quite likely that this will improve the quality of code, 8152 -- (the operation now corresponds to the hardware remainder), and it 8153 -- does not seem likely that it could be harmful. 8154 8155 if LOK and then Llo >= 0 8156 and then 8157 ROK and then Rlo >= 0 8158 then 8159 Rewrite (N, 8160 Make_Op_Rem (Sloc (N), 8161 Left_Opnd => Left_Opnd (N), 8162 Right_Opnd => Right_Opnd (N))); 8163 8164 -- Instead of reanalyzing the node we do the analysis manually. This 8165 -- avoids anomalies when the replacement is done in an instance and 8166 -- is epsilon more efficient. 8167 8168 Set_Entity (N, Standard_Entity (S_Op_Rem)); 8169 Set_Etype (N, Typ); 8170 Set_Do_Division_Check (N, DDC); 8171 Expand_N_Op_Rem (N); 8172 Set_Analyzed (N); 8173 8174 -- Otherwise, normal mod processing 8175 8176 else 8177 -- Apply optimization x mod 1 = 0. We don't really need that with 8178 -- gcc, but it is useful with other back ends (e.g. AAMP), and is 8179 -- certainly harmless. 8180 8181 if Is_Integer_Type (Etype (N)) 8182 and then Compile_Time_Known_Value (Right) 8183 and then Expr_Value (Right) = Uint_1 8184 then 8185 -- Call Remove_Side_Effects to ensure that any side effects in 8186 -- the ignored left operand (in particular function calls to 8187 -- user defined functions) are properly executed. 8188 8189 Remove_Side_Effects (Left); 8190 8191 Rewrite (N, Make_Integer_Literal (Loc, 0)); 8192 Analyze_And_Resolve (N, Typ); 8193 return; 8194 end if; 8195 8196 -- Deal with annoying case of largest negative number remainder 8197 -- minus one. Gigi may not handle this case correctly, because 8198 -- on some targets, the mod value is computed using a divide 8199 -- instruction which gives an overflow trap for this case. 8200 8201 -- It would be a bit more efficient to figure out which targets 8202 -- this is really needed for, but in practice it is reasonable 8203 -- to do the following special check in all cases, since it means 8204 -- we get a clearer message, and also the overhead is minimal given 8205 -- that division is expensive in any case. 8206 8207 -- In fact the check is quite easy, if the right operand is -1, then 8208 -- the mod value is always 0, and we can just ignore the left operand 8209 -- completely in this case. 8210 8211 -- This only applies if we still have a mod operator. Skip if we 8212 -- have already rewritten this (e.g. in the case of eliminated 8213 -- overflow checks which have driven us into bignum mode). 8214 8215 if Nkind (N) = N_Op_Mod then 8216 8217 -- The operand type may be private (e.g. in the expansion of an 8218 -- intrinsic operation) so we must use the underlying type to get 8219 -- the bounds, and convert the literals explicitly. 8220 8221 LLB := 8222 Expr_Value 8223 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); 8224 8225 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 8226 and then 8227 ((not LOK) or else (Llo = LLB)) 8228 then 8229 Rewrite (N, 8230 Make_If_Expression (Loc, 8231 Expressions => New_List ( 8232 Make_Op_Eq (Loc, 8233 Left_Opnd => Duplicate_Subexpr (Right), 8234 Right_Opnd => 8235 Unchecked_Convert_To (Typ, 8236 Make_Integer_Literal (Loc, -1))), 8237 Unchecked_Convert_To (Typ, 8238 Make_Integer_Literal (Loc, Uint_0)), 8239 Relocate_Node (N)))); 8240 8241 Set_Analyzed (Next (Next (First (Expressions (N))))); 8242 Analyze_And_Resolve (N, Typ); 8243 end if; 8244 end if; 8245 end if; 8246 end Expand_N_Op_Mod; 8247 8248 -------------------------- 8249 -- Expand_N_Op_Multiply -- 8250 -------------------------- 8251 8252 procedure Expand_N_Op_Multiply (N : Node_Id) is 8253 Loc : constant Source_Ptr := Sloc (N); 8254 Lop : constant Node_Id := Left_Opnd (N); 8255 Rop : constant Node_Id := Right_Opnd (N); 8256 8257 Lp2 : constant Boolean := 8258 Nkind (Lop) = N_Op_Expon 8259 and then Is_Power_Of_2_For_Shift (Lop); 8260 8261 Rp2 : constant Boolean := 8262 Nkind (Rop) = N_Op_Expon 8263 and then Is_Power_Of_2_For_Shift (Rop); 8264 8265 Ltyp : constant Entity_Id := Etype (Lop); 8266 Rtyp : constant Entity_Id := Etype (Rop); 8267 Typ : Entity_Id := Etype (N); 8268 8269 begin 8270 Binary_Op_Validity_Checks (N); 8271 8272 -- Check for MINIMIZED/ELIMINATED overflow mode 8273 8274 if Minimized_Eliminated_Overflow_Check (N) then 8275 Apply_Arithmetic_Overflow_Check (N); 8276 return; 8277 end if; 8278 8279 -- Special optimizations for integer types 8280 8281 if Is_Integer_Type (Typ) then 8282 8283 -- N * 0 = 0 for integer types 8284 8285 if Compile_Time_Known_Value (Rop) 8286 and then Expr_Value (Rop) = Uint_0 8287 then 8288 -- Call Remove_Side_Effects to ensure that any side effects in 8289 -- the ignored left operand (in particular function calls to 8290 -- user defined functions) are properly executed. 8291 8292 Remove_Side_Effects (Lop); 8293 8294 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 8295 Analyze_And_Resolve (N, Typ); 8296 return; 8297 end if; 8298 8299 -- Similar handling for 0 * N = 0 8300 8301 if Compile_Time_Known_Value (Lop) 8302 and then Expr_Value (Lop) = Uint_0 8303 then 8304 Remove_Side_Effects (Rop); 8305 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 8306 Analyze_And_Resolve (N, Typ); 8307 return; 8308 end if; 8309 8310 -- N * 1 = 1 * N = N for integer types 8311 8312 -- This optimisation is not done if we are going to 8313 -- rewrite the product 1 * 2 ** N to a shift. 8314 8315 if Compile_Time_Known_Value (Rop) 8316 and then Expr_Value (Rop) = Uint_1 8317 and then not Lp2 8318 then 8319 Rewrite (N, Lop); 8320 return; 8321 8322 elsif Compile_Time_Known_Value (Lop) 8323 and then Expr_Value (Lop) = Uint_1 8324 and then not Rp2 8325 then 8326 Rewrite (N, Rop); 8327 return; 8328 end if; 8329 end if; 8330 8331 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that 8332 -- Is_Power_Of_2_For_Shift is set means that we know that our left 8333 -- operand is an integer, as required for this to work. 8334 8335 if Rp2 then 8336 if Lp2 then 8337 8338 -- Convert 2 ** A * 2 ** B into 2 ** (A + B) 8339 8340 Rewrite (N, 8341 Make_Op_Expon (Loc, 8342 Left_Opnd => Make_Integer_Literal (Loc, 2), 8343 Right_Opnd => 8344 Make_Op_Add (Loc, 8345 Left_Opnd => Right_Opnd (Lop), 8346 Right_Opnd => Right_Opnd (Rop)))); 8347 Analyze_And_Resolve (N, Typ); 8348 return; 8349 8350 else 8351 Rewrite (N, 8352 Make_Op_Shift_Left (Loc, 8353 Left_Opnd => Lop, 8354 Right_Opnd => 8355 Convert_To (Standard_Natural, Right_Opnd (Rop)))); 8356 Analyze_And_Resolve (N, Typ); 8357 return; 8358 end if; 8359 8360 -- Same processing for the operands the other way round 8361 8362 elsif Lp2 then 8363 Rewrite (N, 8364 Make_Op_Shift_Left (Loc, 8365 Left_Opnd => Rop, 8366 Right_Opnd => 8367 Convert_To (Standard_Natural, Right_Opnd (Lop)))); 8368 Analyze_And_Resolve (N, Typ); 8369 return; 8370 end if; 8371 8372 -- Do required fixup of universal fixed operation 8373 8374 if Typ = Universal_Fixed then 8375 Fixup_Universal_Fixed_Operation (N); 8376 Typ := Etype (N); 8377 end if; 8378 8379 -- Multiplications with fixed-point results 8380 8381 if Is_Fixed_Point_Type (Typ) then 8382 8383 -- No special processing if Treat_Fixed_As_Integer is set, since from 8384 -- a semantic point of view such operations are simply integer 8385 -- operations and will be treated that way. 8386 8387 if not Treat_Fixed_As_Integer (N) then 8388 8389 -- Case of fixed * integer => fixed 8390 8391 if Is_Integer_Type (Rtyp) then 8392 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); 8393 8394 -- Case of integer * fixed => fixed 8395 8396 elsif Is_Integer_Type (Ltyp) then 8397 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); 8398 8399 -- Case of fixed * fixed => fixed 8400 8401 else 8402 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); 8403 end if; 8404 end if; 8405 8406 -- Other cases of multiplication of fixed-point operands. Again we 8407 -- exclude the cases where Treat_Fixed_As_Integer flag is set. 8408 8409 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) 8410 and then not Treat_Fixed_As_Integer (N) 8411 then 8412 if Is_Integer_Type (Typ) then 8413 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); 8414 else 8415 pragma Assert (Is_Floating_Point_Type (Typ)); 8416 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); 8417 end if; 8418 8419 -- Mixed-mode operations can appear in a non-static universal context, 8420 -- in which case the integer argument must be converted explicitly. 8421 8422 elsif Typ = Universal_Real 8423 and then Is_Integer_Type (Rtyp) 8424 then 8425 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); 8426 8427 Analyze_And_Resolve (Rop, Universal_Real); 8428 8429 elsif Typ = Universal_Real 8430 and then Is_Integer_Type (Ltyp) 8431 then 8432 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); 8433 8434 Analyze_And_Resolve (Lop, Universal_Real); 8435 8436 -- Non-fixed point cases, check software overflow checking required 8437 8438 elsif Is_Signed_Integer_Type (Etype (N)) then 8439 Apply_Arithmetic_Overflow_Check (N); 8440 8441 -- Deal with VAX float case 8442 8443 elsif Vax_Float (Typ) then 8444 Expand_Vax_Arith (N); 8445 return; 8446 end if; 8447 end Expand_N_Op_Multiply; 8448 8449 -------------------- 8450 -- Expand_N_Op_Ne -- 8451 -------------------- 8452 8453 procedure Expand_N_Op_Ne (N : Node_Id) is 8454 Typ : constant Entity_Id := Etype (Left_Opnd (N)); 8455 8456 begin 8457 -- Case of elementary type with standard operator 8458 8459 if Is_Elementary_Type (Typ) 8460 and then Sloc (Entity (N)) = Standard_Location 8461 then 8462 Binary_Op_Validity_Checks (N); 8463 8464 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if 8465 -- means we no longer have a /= operation, we are all done. 8466 8467 Expand_Compare_Minimize_Eliminate_Overflow (N); 8468 8469 if Nkind (N) /= N_Op_Ne then 8470 return; 8471 end if; 8472 8473 -- Boolean types (requiring handling of non-standard case) 8474 8475 if Is_Boolean_Type (Typ) then 8476 Adjust_Condition (Left_Opnd (N)); 8477 Adjust_Condition (Right_Opnd (N)); 8478 Set_Etype (N, Standard_Boolean); 8479 Adjust_Result_Type (N, Typ); 8480 end if; 8481 8482 Rewrite_Comparison (N); 8483 8484 -- If we still have comparison for Vax_Float, process it 8485 8486 if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then 8487 Expand_Vax_Comparison (N); 8488 return; 8489 end if; 8490 8491 -- For all cases other than elementary types, we rewrite node as the 8492 -- negation of an equality operation, and reanalyze. The equality to be 8493 -- used is defined in the same scope and has the same signature. This 8494 -- signature must be set explicitly since in an instance it may not have 8495 -- the same visibility as in the generic unit. This avoids duplicating 8496 -- or factoring the complex code for record/array equality tests etc. 8497 8498 else 8499 declare 8500 Loc : constant Source_Ptr := Sloc (N); 8501 Neg : Node_Id; 8502 Ne : constant Entity_Id := Entity (N); 8503 8504 begin 8505 Binary_Op_Validity_Checks (N); 8506 8507 Neg := 8508 Make_Op_Not (Loc, 8509 Right_Opnd => 8510 Make_Op_Eq (Loc, 8511 Left_Opnd => Left_Opnd (N), 8512 Right_Opnd => Right_Opnd (N))); 8513 Set_Paren_Count (Right_Opnd (Neg), 1); 8514 8515 if Scope (Ne) /= Standard_Standard then 8516 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); 8517 end if; 8518 8519 -- For navigation purposes, we want to treat the inequality as an 8520 -- implicit reference to the corresponding equality. Preserve the 8521 -- Comes_From_ source flag to generate proper Xref entries. 8522 8523 Preserve_Comes_From_Source (Neg, N); 8524 Preserve_Comes_From_Source (Right_Opnd (Neg), N); 8525 Rewrite (N, Neg); 8526 Analyze_And_Resolve (N, Standard_Boolean); 8527 end; 8528 end if; 8529 8530 Optimize_Length_Comparison (N); 8531 end Expand_N_Op_Ne; 8532 8533 --------------------- 8534 -- Expand_N_Op_Not -- 8535 --------------------- 8536 8537 -- If the argument is other than a Boolean array type, there is no special 8538 -- expansion required, except for VMS operations on signed integers. 8539 8540 -- For the packed case, we call the special routine in Exp_Pakd, except 8541 -- that if the component size is greater than one, we use the standard 8542 -- routine generating a gruesome loop (it is so peculiar to have packed 8543 -- arrays with non-standard Boolean representations anyway, so it does not 8544 -- matter that we do not handle this case efficiently). 8545 8546 -- For the unpacked case (and for the special packed case where we have non 8547 -- standard Booleans, as discussed above), we generate and insert into the 8548 -- tree the following function definition: 8549 8550 -- function Nnnn (A : arr) is 8551 -- B : arr; 8552 -- begin 8553 -- for J in a'range loop 8554 -- B (J) := not A (J); 8555 -- end loop; 8556 -- return B; 8557 -- end Nnnn; 8558 8559 -- Here arr is the actual subtype of the parameter (and hence always 8560 -- constrained). Then we replace the not with a call to this function. 8561 8562 procedure Expand_N_Op_Not (N : Node_Id) is 8563 Loc : constant Source_Ptr := Sloc (N); 8564 Typ : constant Entity_Id := Etype (N); 8565 Opnd : Node_Id; 8566 Arr : Entity_Id; 8567 A : Entity_Id; 8568 B : Entity_Id; 8569 J : Entity_Id; 8570 A_J : Node_Id; 8571 B_J : Node_Id; 8572 8573 Func_Name : Entity_Id; 8574 Loop_Statement : Node_Id; 8575 8576 begin 8577 Unary_Op_Validity_Checks (N); 8578 8579 -- For boolean operand, deal with non-standard booleans 8580 8581 if Is_Boolean_Type (Typ) then 8582 Adjust_Condition (Right_Opnd (N)); 8583 Set_Etype (N, Standard_Boolean); 8584 Adjust_Result_Type (N, Typ); 8585 return; 8586 end if; 8587 8588 -- For the VMS "not" on signed integer types, use conversion to and from 8589 -- a predefined modular type. 8590 8591 if Is_VMS_Operator (Entity (N)) then 8592 declare 8593 Rtyp : Entity_Id; 8594 Utyp : Entity_Id; 8595 8596 begin 8597 -- If this is a derived type, retrieve original VMS type so that 8598 -- the proper sized type is used for intermediate values. 8599 8600 if Is_Derived_Type (Typ) then 8601 Rtyp := First_Subtype (Etype (Typ)); 8602 else 8603 Rtyp := Typ; 8604 end if; 8605 8606 -- The proper unsigned type must have a size compatible with the 8607 -- operand, to prevent misalignment. 8608 8609 if RM_Size (Rtyp) <= 8 then 8610 Utyp := RTE (RE_Unsigned_8); 8611 8612 elsif RM_Size (Rtyp) <= 16 then 8613 Utyp := RTE (RE_Unsigned_16); 8614 8615 elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then 8616 Utyp := RTE (RE_Unsigned_32); 8617 8618 else 8619 Utyp := RTE (RE_Long_Long_Unsigned); 8620 end if; 8621 8622 Rewrite (N, 8623 Unchecked_Convert_To (Typ, 8624 Make_Op_Not (Loc, 8625 Unchecked_Convert_To (Utyp, Right_Opnd (N))))); 8626 Analyze_And_Resolve (N, Typ); 8627 return; 8628 end; 8629 end if; 8630 8631 -- Only array types need any other processing 8632 8633 if not Is_Array_Type (Typ) then 8634 return; 8635 end if; 8636 8637 -- Case of array operand. If bit packed with a component size of 1, 8638 -- handle it in Exp_Pakd if the operand is known to be aligned. 8639 8640 if Is_Bit_Packed_Array (Typ) 8641 and then Component_Size (Typ) = 1 8642 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 8643 then 8644 Expand_Packed_Not (N); 8645 return; 8646 end if; 8647 8648 -- Case of array operand which is not bit-packed. If the context is 8649 -- a safe assignment, call in-place operation, If context is a larger 8650 -- boolean expression in the context of a safe assignment, expansion is 8651 -- done by enclosing operation. 8652 8653 Opnd := Relocate_Node (Right_Opnd (N)); 8654 Convert_To_Actual_Subtype (Opnd); 8655 Arr := Etype (Opnd); 8656 Ensure_Defined (Arr, N); 8657 Silly_Boolean_Array_Not_Test (N, Arr); 8658 8659 if Nkind (Parent (N)) = N_Assignment_Statement then 8660 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then 8661 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 8662 return; 8663 8664 -- Special case the negation of a binary operation 8665 8666 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor) 8667 and then Safe_In_Place_Array_Op 8668 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) 8669 then 8670 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 8671 return; 8672 end if; 8673 8674 elsif Nkind (Parent (N)) in N_Binary_Op 8675 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 8676 then 8677 declare 8678 Op1 : constant Node_Id := Left_Opnd (Parent (N)); 8679 Op2 : constant Node_Id := Right_Opnd (Parent (N)); 8680 Lhs : constant Node_Id := Name (Parent (Parent (N))); 8681 8682 begin 8683 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then 8684 8685 -- (not A) op (not B) can be reduced to a single call 8686 8687 if N = Op1 and then Nkind (Op2) = N_Op_Not then 8688 return; 8689 8690 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then 8691 return; 8692 8693 -- A xor (not B) can also be special-cased 8694 8695 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then 8696 return; 8697 end if; 8698 end if; 8699 end; 8700 end if; 8701 8702 A := Make_Defining_Identifier (Loc, Name_uA); 8703 B := Make_Defining_Identifier (Loc, Name_uB); 8704 J := Make_Defining_Identifier (Loc, Name_uJ); 8705 8706 A_J := 8707 Make_Indexed_Component (Loc, 8708 Prefix => New_Reference_To (A, Loc), 8709 Expressions => New_List (New_Reference_To (J, Loc))); 8710 8711 B_J := 8712 Make_Indexed_Component (Loc, 8713 Prefix => New_Reference_To (B, Loc), 8714 Expressions => New_List (New_Reference_To (J, Loc))); 8715 8716 Loop_Statement := 8717 Make_Implicit_Loop_Statement (N, 8718 Identifier => Empty, 8719 8720 Iteration_Scheme => 8721 Make_Iteration_Scheme (Loc, 8722 Loop_Parameter_Specification => 8723 Make_Loop_Parameter_Specification (Loc, 8724 Defining_Identifier => J, 8725 Discrete_Subtype_Definition => 8726 Make_Attribute_Reference (Loc, 8727 Prefix => Make_Identifier (Loc, Chars (A)), 8728 Attribute_Name => Name_Range))), 8729 8730 Statements => New_List ( 8731 Make_Assignment_Statement (Loc, 8732 Name => B_J, 8733 Expression => Make_Op_Not (Loc, A_J)))); 8734 8735 Func_Name := Make_Temporary (Loc, 'N'); 8736 Set_Is_Inlined (Func_Name); 8737 8738 Insert_Action (N, 8739 Make_Subprogram_Body (Loc, 8740 Specification => 8741 Make_Function_Specification (Loc, 8742 Defining_Unit_Name => Func_Name, 8743 Parameter_Specifications => New_List ( 8744 Make_Parameter_Specification (Loc, 8745 Defining_Identifier => A, 8746 Parameter_Type => New_Reference_To (Typ, Loc))), 8747 Result_Definition => New_Reference_To (Typ, Loc)), 8748 8749 Declarations => New_List ( 8750 Make_Object_Declaration (Loc, 8751 Defining_Identifier => B, 8752 Object_Definition => New_Reference_To (Arr, Loc))), 8753 8754 Handled_Statement_Sequence => 8755 Make_Handled_Sequence_Of_Statements (Loc, 8756 Statements => New_List ( 8757 Loop_Statement, 8758 Make_Simple_Return_Statement (Loc, 8759 Expression => Make_Identifier (Loc, Chars (B))))))); 8760 8761 Rewrite (N, 8762 Make_Function_Call (Loc, 8763 Name => New_Reference_To (Func_Name, Loc), 8764 Parameter_Associations => New_List (Opnd))); 8765 8766 Analyze_And_Resolve (N, Typ); 8767 end Expand_N_Op_Not; 8768 8769 -------------------- 8770 -- Expand_N_Op_Or -- 8771 -------------------- 8772 8773 procedure Expand_N_Op_Or (N : Node_Id) is 8774 Typ : constant Entity_Id := Etype (N); 8775 8776 begin 8777 Binary_Op_Validity_Checks (N); 8778 8779 if Is_Array_Type (Etype (N)) then 8780 Expand_Boolean_Operator (N); 8781 8782 elsif Is_Boolean_Type (Etype (N)) then 8783 Adjust_Condition (Left_Opnd (N)); 8784 Adjust_Condition (Right_Opnd (N)); 8785 Set_Etype (N, Standard_Boolean); 8786 Adjust_Result_Type (N, Typ); 8787 8788 elsif Is_Intrinsic_Subprogram (Entity (N)) then 8789 Expand_Intrinsic_Call (N, Entity (N)); 8790 8791 end if; 8792 end Expand_N_Op_Or; 8793 8794 ---------------------- 8795 -- Expand_N_Op_Plus -- 8796 ---------------------- 8797 8798 procedure Expand_N_Op_Plus (N : Node_Id) is 8799 begin 8800 Unary_Op_Validity_Checks (N); 8801 8802 -- Check for MINIMIZED/ELIMINATED overflow mode 8803 8804 if Minimized_Eliminated_Overflow_Check (N) then 8805 Apply_Arithmetic_Overflow_Check (N); 8806 return; 8807 end if; 8808 end Expand_N_Op_Plus; 8809 8810 --------------------- 8811 -- Expand_N_Op_Rem -- 8812 --------------------- 8813 8814 procedure Expand_N_Op_Rem (N : Node_Id) is 8815 Loc : constant Source_Ptr := Sloc (N); 8816 Typ : constant Entity_Id := Etype (N); 8817 8818 Left : Node_Id; 8819 Right : Node_Id; 8820 8821 Lo : Uint; 8822 Hi : Uint; 8823 OK : Boolean; 8824 8825 Lneg : Boolean; 8826 Rneg : Boolean; 8827 -- Set if corresponding operand can be negative 8828 8829 pragma Unreferenced (Hi); 8830 8831 begin 8832 Binary_Op_Validity_Checks (N); 8833 8834 -- Check for MINIMIZED/ELIMINATED overflow mode 8835 8836 if Minimized_Eliminated_Overflow_Check (N) then 8837 Apply_Arithmetic_Overflow_Check (N); 8838 return; 8839 end if; 8840 8841 if Is_Integer_Type (Etype (N)) then 8842 Apply_Divide_Checks (N); 8843 8844 -- All done if we don't have a REM any more, which can happen as a 8845 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 8846 8847 if Nkind (N) /= N_Op_Rem then 8848 return; 8849 end if; 8850 end if; 8851 8852 -- Proceed with expansion of REM 8853 8854 Left := Left_Opnd (N); 8855 Right := Right_Opnd (N); 8856 8857 -- Apply optimization x rem 1 = 0. We don't really need that with gcc, 8858 -- but it is useful with other back ends (e.g. AAMP), and is certainly 8859 -- harmless. 8860 8861 if Is_Integer_Type (Etype (N)) 8862 and then Compile_Time_Known_Value (Right) 8863 and then Expr_Value (Right) = Uint_1 8864 then 8865 -- Call Remove_Side_Effects to ensure that any side effects in the 8866 -- ignored left operand (in particular function calls to user defined 8867 -- functions) are properly executed. 8868 8869 Remove_Side_Effects (Left); 8870 8871 Rewrite (N, Make_Integer_Literal (Loc, 0)); 8872 Analyze_And_Resolve (N, Typ); 8873 return; 8874 end if; 8875 8876 -- Deal with annoying case of largest negative number remainder minus 8877 -- one. Gigi may not handle this case correctly, because on some 8878 -- targets, the mod value is computed using a divide instruction 8879 -- which gives an overflow trap for this case. 8880 8881 -- It would be a bit more efficient to figure out which targets this 8882 -- is really needed for, but in practice it is reasonable to do the 8883 -- following special check in all cases, since it means we get a clearer 8884 -- message, and also the overhead is minimal given that division is 8885 -- expensive in any case. 8886 8887 -- In fact the check is quite easy, if the right operand is -1, then 8888 -- the remainder is always 0, and we can just ignore the left operand 8889 -- completely in this case. 8890 8891 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 8892 Lneg := (not OK) or else Lo < 0; 8893 8894 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True); 8895 Rneg := (not OK) or else Lo < 0; 8896 8897 -- We won't mess with trying to find out if the left operand can really 8898 -- be the largest negative number (that's a pain in the case of private 8899 -- types and this is really marginal). We will just assume that we need 8900 -- the test if the left operand can be negative at all. 8901 8902 if Lneg and Rneg then 8903 Rewrite (N, 8904 Make_If_Expression (Loc, 8905 Expressions => New_List ( 8906 Make_Op_Eq (Loc, 8907 Left_Opnd => Duplicate_Subexpr (Right), 8908 Right_Opnd => 8909 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))), 8910 8911 Unchecked_Convert_To (Typ, 8912 Make_Integer_Literal (Loc, Uint_0)), 8913 8914 Relocate_Node (N)))); 8915 8916 Set_Analyzed (Next (Next (First (Expressions (N))))); 8917 Analyze_And_Resolve (N, Typ); 8918 end if; 8919 end Expand_N_Op_Rem; 8920 8921 ----------------------------- 8922 -- Expand_N_Op_Rotate_Left -- 8923 ----------------------------- 8924 8925 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is 8926 begin 8927 Binary_Op_Validity_Checks (N); 8928 end Expand_N_Op_Rotate_Left; 8929 8930 ------------------------------ 8931 -- Expand_N_Op_Rotate_Right -- 8932 ------------------------------ 8933 8934 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is 8935 begin 8936 Binary_Op_Validity_Checks (N); 8937 end Expand_N_Op_Rotate_Right; 8938 8939 ---------------------------- 8940 -- Expand_N_Op_Shift_Left -- 8941 ---------------------------- 8942 8943 procedure Expand_N_Op_Shift_Left (N : Node_Id) is 8944 begin 8945 Binary_Op_Validity_Checks (N); 8946 end Expand_N_Op_Shift_Left; 8947 8948 ----------------------------- 8949 -- Expand_N_Op_Shift_Right -- 8950 ----------------------------- 8951 8952 procedure Expand_N_Op_Shift_Right (N : Node_Id) is 8953 begin 8954 Binary_Op_Validity_Checks (N); 8955 end Expand_N_Op_Shift_Right; 8956 8957 ---------------------------------------- 8958 -- Expand_N_Op_Shift_Right_Arithmetic -- 8959 ---------------------------------------- 8960 8961 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is 8962 begin 8963 Binary_Op_Validity_Checks (N); 8964 end Expand_N_Op_Shift_Right_Arithmetic; 8965 8966 -------------------------- 8967 -- Expand_N_Op_Subtract -- 8968 -------------------------- 8969 8970 procedure Expand_N_Op_Subtract (N : Node_Id) is 8971 Typ : constant Entity_Id := Etype (N); 8972 8973 begin 8974 Binary_Op_Validity_Checks (N); 8975 8976 -- Check for MINIMIZED/ELIMINATED overflow mode 8977 8978 if Minimized_Eliminated_Overflow_Check (N) then 8979 Apply_Arithmetic_Overflow_Check (N); 8980 return; 8981 end if; 8982 8983 -- N - 0 = N for integer types 8984 8985 if Is_Integer_Type (Typ) 8986 and then Compile_Time_Known_Value (Right_Opnd (N)) 8987 and then Expr_Value (Right_Opnd (N)) = 0 8988 then 8989 Rewrite (N, Left_Opnd (N)); 8990 return; 8991 end if; 8992 8993 -- Arithmetic overflow checks for signed integer/fixed point types 8994 8995 if Is_Signed_Integer_Type (Typ) 8996 or else 8997 Is_Fixed_Point_Type (Typ) 8998 then 8999 Apply_Arithmetic_Overflow_Check (N); 9000 9001 -- VAX floating-point types case 9002 9003 elsif Vax_Float (Typ) then 9004 Expand_Vax_Arith (N); 9005 end if; 9006 end Expand_N_Op_Subtract; 9007 9008 --------------------- 9009 -- Expand_N_Op_Xor -- 9010 --------------------- 9011 9012 procedure Expand_N_Op_Xor (N : Node_Id) is 9013 Typ : constant Entity_Id := Etype (N); 9014 9015 begin 9016 Binary_Op_Validity_Checks (N); 9017 9018 if Is_Array_Type (Etype (N)) then 9019 Expand_Boolean_Operator (N); 9020 9021 elsif Is_Boolean_Type (Etype (N)) then 9022 Adjust_Condition (Left_Opnd (N)); 9023 Adjust_Condition (Right_Opnd (N)); 9024 Set_Etype (N, Standard_Boolean); 9025 Adjust_Result_Type (N, Typ); 9026 9027 elsif Is_Intrinsic_Subprogram (Entity (N)) then 9028 Expand_Intrinsic_Call (N, Entity (N)); 9029 9030 end if; 9031 end Expand_N_Op_Xor; 9032 9033 ---------------------- 9034 -- Expand_N_Or_Else -- 9035 ---------------------- 9036 9037 procedure Expand_N_Or_Else (N : Node_Id) 9038 renames Expand_Short_Circuit_Operator; 9039 9040 ----------------------------------- 9041 -- Expand_N_Qualified_Expression -- 9042 ----------------------------------- 9043 9044 procedure Expand_N_Qualified_Expression (N : Node_Id) is 9045 Operand : constant Node_Id := Expression (N); 9046 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 9047 9048 begin 9049 -- Do validity check if validity checking operands 9050 9051 if Validity_Checks_On and then Validity_Check_Operands then 9052 Ensure_Valid (Operand); 9053 end if; 9054 9055 -- Apply possible constraint check 9056 9057 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); 9058 9059 if Do_Range_Check (Operand) then 9060 Set_Do_Range_Check (Operand, False); 9061 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed); 9062 end if; 9063 end Expand_N_Qualified_Expression; 9064 9065 ------------------------------------ 9066 -- Expand_N_Quantified_Expression -- 9067 ------------------------------------ 9068 9069 -- We expand: 9070 9071 -- for all X in range => Cond 9072 9073 -- into: 9074 9075 -- T := True; 9076 -- for X in range loop 9077 -- if not Cond then 9078 -- T := False; 9079 -- exit; 9080 -- end if; 9081 -- end loop; 9082 9083 -- Similarly, an existentially quantified expression: 9084 9085 -- for some X in range => Cond 9086 9087 -- becomes: 9088 9089 -- T := False; 9090 -- for X in range loop 9091 -- if Cond then 9092 -- T := True; 9093 -- exit; 9094 -- end if; 9095 -- end loop; 9096 9097 -- In both cases, the iteration may be over a container in which case it is 9098 -- given by an iterator specification, not a loop parameter specification. 9099 9100 procedure Expand_N_Quantified_Expression (N : Node_Id) is 9101 Actions : constant List_Id := New_List; 9102 For_All : constant Boolean := All_Present (N); 9103 Iter_Spec : constant Node_Id := Iterator_Specification (N); 9104 Loc : constant Source_Ptr := Sloc (N); 9105 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); 9106 Cond : Node_Id; 9107 Flag : Entity_Id; 9108 Scheme : Node_Id; 9109 Stmts : List_Id; 9110 9111 begin 9112 -- Create the declaration of the flag which tracks the status of the 9113 -- quantified expression. Generate: 9114 9115 -- Flag : Boolean := (True | False); 9116 9117 Flag := Make_Temporary (Loc, 'T', N); 9118 9119 Append_To (Actions, 9120 Make_Object_Declaration (Loc, 9121 Defining_Identifier => Flag, 9122 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 9123 Expression => 9124 New_Occurrence_Of (Boolean_Literals (For_All), Loc))); 9125 9126 -- Construct the circuitry which tracks the status of the quantified 9127 -- expression. Generate: 9128 9129 -- if [not] Cond then 9130 -- Flag := (False | True); 9131 -- exit; 9132 -- end if; 9133 9134 Cond := Relocate_Node (Condition (N)); 9135 9136 if For_All then 9137 Cond := Make_Op_Not (Loc, Cond); 9138 end if; 9139 9140 Stmts := New_List ( 9141 Make_Implicit_If_Statement (N, 9142 Condition => Cond, 9143 Then_Statements => New_List ( 9144 Make_Assignment_Statement (Loc, 9145 Name => New_Occurrence_Of (Flag, Loc), 9146 Expression => 9147 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), 9148 Make_Exit_Statement (Loc)))); 9149 9150 -- Build the loop equivalent of the quantified expression 9151 9152 if Present (Iter_Spec) then 9153 Scheme := 9154 Make_Iteration_Scheme (Loc, 9155 Iterator_Specification => Iter_Spec); 9156 else 9157 Scheme := 9158 Make_Iteration_Scheme (Loc, 9159 Loop_Parameter_Specification => Loop_Spec); 9160 end if; 9161 9162 Append_To (Actions, 9163 Make_Loop_Statement (Loc, 9164 Iteration_Scheme => Scheme, 9165 Statements => Stmts, 9166 End_Label => Empty)); 9167 9168 -- Transform the quantified expression 9169 9170 Rewrite (N, 9171 Make_Expression_With_Actions (Loc, 9172 Expression => New_Occurrence_Of (Flag, Loc), 9173 Actions => Actions)); 9174 Analyze_And_Resolve (N, Standard_Boolean); 9175 end Expand_N_Quantified_Expression; 9176 9177 --------------------------------- 9178 -- Expand_N_Selected_Component -- 9179 --------------------------------- 9180 9181 procedure Expand_N_Selected_Component (N : Node_Id) is 9182 Loc : constant Source_Ptr := Sloc (N); 9183 Par : constant Node_Id := Parent (N); 9184 P : constant Node_Id := Prefix (N); 9185 Ptyp : Entity_Id := Underlying_Type (Etype (P)); 9186 Disc : Entity_Id; 9187 New_N : Node_Id; 9188 Dcon : Elmt_Id; 9189 Dval : Node_Id; 9190 9191 function In_Left_Hand_Side (Comp : Node_Id) return Boolean; 9192 -- Gigi needs a temporary for prefixes that depend on a discriminant, 9193 -- unless the context of an assignment can provide size information. 9194 -- Don't we have a general routine that does this??? 9195 9196 function Is_Subtype_Declaration return Boolean; 9197 -- The replacement of a discriminant reference by its value is required 9198 -- if this is part of the initialization of an temporary generated by a 9199 -- change of representation. This shows up as the construction of a 9200 -- discriminant constraint for a subtype declared at the same point as 9201 -- the entity in the prefix of the selected component. We recognize this 9202 -- case when the context of the reference is: 9203 -- subtype ST is T(Obj.D); 9204 -- where the entity for Obj comes from source, and ST has the same sloc. 9205 9206 ----------------------- 9207 -- In_Left_Hand_Side -- 9208 ----------------------- 9209 9210 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is 9211 begin 9212 return (Nkind (Parent (Comp)) = N_Assignment_Statement 9213 and then Comp = Name (Parent (Comp))) 9214 or else (Present (Parent (Comp)) 9215 and then Nkind (Parent (Comp)) in N_Subexpr 9216 and then In_Left_Hand_Side (Parent (Comp))); 9217 end In_Left_Hand_Side; 9218 9219 ----------------------------- 9220 -- Is_Subtype_Declaration -- 9221 ----------------------------- 9222 9223 function Is_Subtype_Declaration return Boolean is 9224 Par : constant Node_Id := Parent (N); 9225 begin 9226 return 9227 Nkind (Par) = N_Index_Or_Discriminant_Constraint 9228 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration 9229 and then Comes_From_Source (Entity (Prefix (N))) 9230 and then Sloc (Par) = Sloc (Entity (Prefix (N))); 9231 end Is_Subtype_Declaration; 9232 9233 -- Start of processing for Expand_N_Selected_Component 9234 9235 begin 9236 -- Insert explicit dereference if required 9237 9238 if Is_Access_Type (Ptyp) then 9239 9240 -- First set prefix type to proper access type, in case it currently 9241 -- has a private (non-access) view of this type. 9242 9243 Set_Etype (P, Ptyp); 9244 9245 Insert_Explicit_Dereference (P); 9246 Analyze_And_Resolve (P, Designated_Type (Ptyp)); 9247 9248 if Ekind (Etype (P)) = E_Private_Subtype 9249 and then Is_For_Access_Subtype (Etype (P)) 9250 then 9251 Set_Etype (P, Base_Type (Etype (P))); 9252 end if; 9253 9254 Ptyp := Etype (P); 9255 end if; 9256 9257 -- Deal with discriminant check required 9258 9259 if Do_Discriminant_Check (N) then 9260 9261 -- Present the discriminant checking function to the backend, so that 9262 -- it can inline the call to the function. 9263 9264 Add_Inlined_Body 9265 (Discriminant_Checking_Func 9266 (Original_Record_Component (Entity (Selector_Name (N))))); 9267 9268 -- Now reset the flag and generate the call 9269 9270 Set_Do_Discriminant_Check (N, False); 9271 Generate_Discriminant_Check (N); 9272 end if; 9273 9274 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 9275 -- function, then additional actuals must be passed. 9276 9277 if Ada_Version >= Ada_2005 9278 and then Is_Build_In_Place_Function_Call (P) 9279 then 9280 Make_Build_In_Place_Call_In_Anonymous_Context (P); 9281 end if; 9282 9283 -- Gigi cannot handle unchecked conversions that are the prefix of a 9284 -- selected component with discriminants. This must be checked during 9285 -- expansion, because during analysis the type of the selector is not 9286 -- known at the point the prefix is analyzed. If the conversion is the 9287 -- target of an assignment, then we cannot force the evaluation. 9288 9289 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion 9290 and then Has_Discriminants (Etype (N)) 9291 and then not In_Left_Hand_Side (N) 9292 then 9293 Force_Evaluation (Prefix (N)); 9294 end if; 9295 9296 -- Remaining processing applies only if selector is a discriminant 9297 9298 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then 9299 9300 -- If the selector is a discriminant of a constrained record type, 9301 -- we may be able to rewrite the expression with the actual value 9302 -- of the discriminant, a useful optimization in some cases. 9303 9304 if Is_Record_Type (Ptyp) 9305 and then Has_Discriminants (Ptyp) 9306 and then Is_Constrained (Ptyp) 9307 then 9308 -- Do this optimization for discrete types only, and not for 9309 -- access types (access discriminants get us into trouble!) 9310 9311 if not Is_Discrete_Type (Etype (N)) then 9312 null; 9313 9314 -- Don't do this on the left hand of an assignment statement. 9315 -- Normally one would think that references like this would not 9316 -- occur, but they do in generated code, and mean that we really 9317 -- do want to assign the discriminant! 9318 9319 elsif Nkind (Par) = N_Assignment_Statement 9320 and then Name (Par) = N 9321 then 9322 null; 9323 9324 -- Don't do this optimization for the prefix of an attribute or 9325 -- the name of an object renaming declaration since these are 9326 -- contexts where we do not want the value anyway. 9327 9328 elsif (Nkind (Par) = N_Attribute_Reference 9329 and then Prefix (Par) = N) 9330 or else Is_Renamed_Object (N) 9331 then 9332 null; 9333 9334 -- Don't do this optimization if we are within the code for a 9335 -- discriminant check, since the whole point of such a check may 9336 -- be to verify the condition on which the code below depends! 9337 9338 elsif Is_In_Discriminant_Check (N) then 9339 null; 9340 9341 -- Green light to see if we can do the optimization. There is 9342 -- still one condition that inhibits the optimization below but 9343 -- now is the time to check the particular discriminant. 9344 9345 else 9346 -- Loop through discriminants to find the matching discriminant 9347 -- constraint to see if we can copy it. 9348 9349 Disc := First_Discriminant (Ptyp); 9350 Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); 9351 Discr_Loop : while Present (Dcon) loop 9352 Dval := Node (Dcon); 9353 9354 -- Check if this is the matching discriminant and if the 9355 -- discriminant value is simple enough to make sense to 9356 -- copy. We don't want to copy complex expressions, and 9357 -- indeed to do so can cause trouble (before we put in 9358 -- this guard, a discriminant expression containing an 9359 -- AND THEN was copied, causing problems for coverage 9360 -- analysis tools). 9361 9362 -- However, if the reference is part of the initialization 9363 -- code generated for an object declaration, we must use 9364 -- the discriminant value from the subtype constraint, 9365 -- because the selected component may be a reference to the 9366 -- object being initialized, whose discriminant is not yet 9367 -- set. This only happens in complex cases involving changes 9368 -- or representation. 9369 9370 if Disc = Entity (Selector_Name (N)) 9371 and then (Is_Entity_Name (Dval) 9372 or else Compile_Time_Known_Value (Dval) 9373 or else Is_Subtype_Declaration) 9374 then 9375 -- Here we have the matching discriminant. Check for 9376 -- the case of a discriminant of a component that is 9377 -- constrained by an outer discriminant, which cannot 9378 -- be optimized away. 9379 9380 if Denotes_Discriminant 9381 (Dval, Check_Concurrent => True) 9382 then 9383 exit Discr_Loop; 9384 9385 elsif Nkind (Original_Node (Dval)) = N_Selected_Component 9386 and then 9387 Denotes_Discriminant 9388 (Selector_Name (Original_Node (Dval)), True) 9389 then 9390 exit Discr_Loop; 9391 9392 -- Do not retrieve value if constraint is not static. It 9393 -- is generally not useful, and the constraint may be a 9394 -- rewritten outer discriminant in which case it is in 9395 -- fact incorrect. 9396 9397 elsif Is_Entity_Name (Dval) 9398 and then Nkind (Parent (Entity (Dval))) = 9399 N_Object_Declaration 9400 and then Present (Expression (Parent (Entity (Dval)))) 9401 and then 9402 not Is_Static_Expression 9403 (Expression (Parent (Entity (Dval)))) 9404 then 9405 exit Discr_Loop; 9406 9407 -- In the context of a case statement, the expression may 9408 -- have the base type of the discriminant, and we need to 9409 -- preserve the constraint to avoid spurious errors on 9410 -- missing cases. 9411 9412 elsif Nkind (Parent (N)) = N_Case_Statement 9413 and then Etype (Dval) /= Etype (Disc) 9414 then 9415 Rewrite (N, 9416 Make_Qualified_Expression (Loc, 9417 Subtype_Mark => 9418 New_Occurrence_Of (Etype (Disc), Loc), 9419 Expression => 9420 New_Copy_Tree (Dval))); 9421 Analyze_And_Resolve (N, Etype (Disc)); 9422 9423 -- In case that comes out as a static expression, 9424 -- reset it (a selected component is never static). 9425 9426 Set_Is_Static_Expression (N, False); 9427 return; 9428 9429 -- Otherwise we can just copy the constraint, but the 9430 -- result is certainly not static! In some cases the 9431 -- discriminant constraint has been analyzed in the 9432 -- context of the original subtype indication, but for 9433 -- itypes the constraint might not have been analyzed 9434 -- yet, and this must be done now. 9435 9436 else 9437 Rewrite (N, New_Copy_Tree (Dval)); 9438 Analyze_And_Resolve (N); 9439 Set_Is_Static_Expression (N, False); 9440 return; 9441 end if; 9442 end if; 9443 9444 Next_Elmt (Dcon); 9445 Next_Discriminant (Disc); 9446 end loop Discr_Loop; 9447 9448 -- Note: the above loop should always find a matching 9449 -- discriminant, but if it does not, we just missed an 9450 -- optimization due to some glitch (perhaps a previous 9451 -- error), so ignore. 9452 9453 end if; 9454 end if; 9455 9456 -- The only remaining processing is in the case of a discriminant of 9457 -- a concurrent object, where we rewrite the prefix to denote the 9458 -- corresponding record type. If the type is derived and has renamed 9459 -- discriminants, use corresponding discriminant, which is the one 9460 -- that appears in the corresponding record. 9461 9462 if not Is_Concurrent_Type (Ptyp) then 9463 return; 9464 end if; 9465 9466 Disc := Entity (Selector_Name (N)); 9467 9468 if Is_Derived_Type (Ptyp) 9469 and then Present (Corresponding_Discriminant (Disc)) 9470 then 9471 Disc := Corresponding_Discriminant (Disc); 9472 end if; 9473 9474 New_N := 9475 Make_Selected_Component (Loc, 9476 Prefix => 9477 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), 9478 New_Copy_Tree (P)), 9479 Selector_Name => Make_Identifier (Loc, Chars (Disc))); 9480 9481 Rewrite (N, New_N); 9482 Analyze (N); 9483 end if; 9484 9485 -- Set Atomic_Sync_Required if necessary for atomic component 9486 9487 if Nkind (N) = N_Selected_Component then 9488 declare 9489 E : constant Entity_Id := Entity (Selector_Name (N)); 9490 Set : Boolean; 9491 9492 begin 9493 -- If component is atomic, but type is not, setting depends on 9494 -- disable/enable state for the component. 9495 9496 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then 9497 Set := not Atomic_Synchronization_Disabled (E); 9498 9499 -- If component is not atomic, but its type is atomic, setting 9500 -- depends on disable/enable state for the type. 9501 9502 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then 9503 Set := not Atomic_Synchronization_Disabled (Etype (E)); 9504 9505 -- If both component and type are atomic, we disable if either 9506 -- component or its type have sync disabled. 9507 9508 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then 9509 Set := (not Atomic_Synchronization_Disabled (E)) 9510 and then 9511 (not Atomic_Synchronization_Disabled (Etype (E))); 9512 9513 else 9514 Set := False; 9515 end if; 9516 9517 -- Set flag if required 9518 9519 if Set then 9520 Activate_Atomic_Synchronization (N); 9521 end if; 9522 end; 9523 end if; 9524 end Expand_N_Selected_Component; 9525 9526 -------------------- 9527 -- Expand_N_Slice -- 9528 -------------------- 9529 9530 procedure Expand_N_Slice (N : Node_Id) is 9531 Loc : constant Source_Ptr := Sloc (N); 9532 Typ : constant Entity_Id := Etype (N); 9533 Pfx : constant Node_Id := Prefix (N); 9534 Ptp : Entity_Id := Etype (Pfx); 9535 9536 function Is_Procedure_Actual (N : Node_Id) return Boolean; 9537 -- Check whether the argument is an actual for a procedure call, in 9538 -- which case the expansion of a bit-packed slice is deferred until the 9539 -- call itself is expanded. The reason this is required is that we might 9540 -- have an IN OUT or OUT parameter, and the copy out is essential, and 9541 -- that copy out would be missed if we created a temporary here in 9542 -- Expand_N_Slice. Note that we don't bother to test specifically for an 9543 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it 9544 -- is harmless to defer expansion in the IN case, since the call 9545 -- processing will still generate the appropriate copy in operation, 9546 -- which will take care of the slice. 9547 9548 procedure Make_Temporary_For_Slice; 9549 -- Create a named variable for the value of the slice, in cases where 9550 -- the back-end cannot handle it properly, e.g. when packed types or 9551 -- unaligned slices are involved. 9552 9553 ------------------------- 9554 -- Is_Procedure_Actual -- 9555 ------------------------- 9556 9557 function Is_Procedure_Actual (N : Node_Id) return Boolean is 9558 Par : Node_Id := Parent (N); 9559 9560 begin 9561 loop 9562 -- If our parent is a procedure call we can return 9563 9564 if Nkind (Par) = N_Procedure_Call_Statement then 9565 return True; 9566 9567 -- If our parent is a type conversion, keep climbing the tree, 9568 -- since a type conversion can be a procedure actual. Also keep 9569 -- climbing if parameter association or a qualified expression, 9570 -- since these are additional cases that do can appear on 9571 -- procedure actuals. 9572 9573 elsif Nkind_In (Par, N_Type_Conversion, 9574 N_Parameter_Association, 9575 N_Qualified_Expression) 9576 then 9577 Par := Parent (Par); 9578 9579 -- Any other case is not what we are looking for 9580 9581 else 9582 return False; 9583 end if; 9584 end loop; 9585 end Is_Procedure_Actual; 9586 9587 ------------------------------ 9588 -- Make_Temporary_For_Slice -- 9589 ------------------------------ 9590 9591 procedure Make_Temporary_For_Slice is 9592 Decl : Node_Id; 9593 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); 9594 9595 begin 9596 Decl := 9597 Make_Object_Declaration (Loc, 9598 Defining_Identifier => Ent, 9599 Object_Definition => New_Occurrence_Of (Typ, Loc)); 9600 9601 Set_No_Initialization (Decl); 9602 9603 Insert_Actions (N, New_List ( 9604 Decl, 9605 Make_Assignment_Statement (Loc, 9606 Name => New_Occurrence_Of (Ent, Loc), 9607 Expression => Relocate_Node (N)))); 9608 9609 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 9610 Analyze_And_Resolve (N, Typ); 9611 end Make_Temporary_For_Slice; 9612 9613 -- Start of processing for Expand_N_Slice 9614 9615 begin 9616 -- Special handling for access types 9617 9618 if Is_Access_Type (Ptp) then 9619 9620 Ptp := Designated_Type (Ptp); 9621 9622 Rewrite (Pfx, 9623 Make_Explicit_Dereference (Sloc (N), 9624 Prefix => Relocate_Node (Pfx))); 9625 9626 Analyze_And_Resolve (Pfx, Ptp); 9627 end if; 9628 9629 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 9630 -- function, then additional actuals must be passed. 9631 9632 if Ada_Version >= Ada_2005 9633 and then Is_Build_In_Place_Function_Call (Pfx) 9634 then 9635 Make_Build_In_Place_Call_In_Anonymous_Context (Pfx); 9636 end if; 9637 9638 -- The remaining case to be handled is packed slices. We can leave 9639 -- packed slices as they are in the following situations: 9640 9641 -- 1. Right or left side of an assignment (we can handle this 9642 -- situation correctly in the assignment statement expansion). 9643 9644 -- 2. Prefix of indexed component (the slide is optimized away in this 9645 -- case, see the start of Expand_N_Slice.) 9646 9647 -- 3. Object renaming declaration, since we want the name of the 9648 -- slice, not the value. 9649 9650 -- 4. Argument to procedure call, since copy-in/copy-out handling may 9651 -- be required, and this is handled in the expansion of call 9652 -- itself. 9653 9654 -- 5. Prefix of an address attribute (this is an error which is caught 9655 -- elsewhere, and the expansion would interfere with generating the 9656 -- error message). 9657 9658 if not Is_Packed (Typ) then 9659 9660 -- Apply transformation for actuals of a function call, where 9661 -- Expand_Actuals is not used. 9662 9663 if Nkind (Parent (N)) = N_Function_Call 9664 and then Is_Possibly_Unaligned_Slice (N) 9665 then 9666 Make_Temporary_For_Slice; 9667 end if; 9668 9669 elsif Nkind (Parent (N)) = N_Assignment_Statement 9670 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement 9671 and then Parent (N) = Name (Parent (Parent (N)))) 9672 then 9673 return; 9674 9675 elsif Nkind (Parent (N)) = N_Indexed_Component 9676 or else Is_Renamed_Object (N) 9677 or else Is_Procedure_Actual (N) 9678 then 9679 return; 9680 9681 elsif Nkind (Parent (N)) = N_Attribute_Reference 9682 and then Attribute_Name (Parent (N)) = Name_Address 9683 then 9684 return; 9685 9686 else 9687 Make_Temporary_For_Slice; 9688 end if; 9689 end Expand_N_Slice; 9690 9691 ------------------------------ 9692 -- Expand_N_Type_Conversion -- 9693 ------------------------------ 9694 9695 procedure Expand_N_Type_Conversion (N : Node_Id) is 9696 Loc : constant Source_Ptr := Sloc (N); 9697 Operand : constant Node_Id := Expression (N); 9698 Target_Type : constant Entity_Id := Etype (N); 9699 Operand_Type : Entity_Id := Etype (Operand); 9700 9701 procedure Handle_Changed_Representation; 9702 -- This is called in the case of record and array type conversions to 9703 -- see if there is a change of representation to be handled. Change of 9704 -- representation is actually handled at the assignment statement level, 9705 -- and what this procedure does is rewrite node N conversion as an 9706 -- assignment to temporary. If there is no change of representation, 9707 -- then the conversion node is unchanged. 9708 9709 procedure Raise_Accessibility_Error; 9710 -- Called when we know that an accessibility check will fail. Rewrites 9711 -- node N to an appropriate raise statement and outputs warning msgs. 9712 -- The Etype of the raise node is set to Target_Type. 9713 9714 procedure Real_Range_Check; 9715 -- Handles generation of range check for real target value 9716 9717 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; 9718 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully 9719 -- evaluates to True. 9720 9721 ----------------------------------- 9722 -- Handle_Changed_Representation -- 9723 ----------------------------------- 9724 9725 procedure Handle_Changed_Representation is 9726 Temp : Entity_Id; 9727 Decl : Node_Id; 9728 Odef : Node_Id; 9729 Disc : Node_Id; 9730 N_Ix : Node_Id; 9731 Cons : List_Id; 9732 9733 begin 9734 -- Nothing else to do if no change of representation 9735 9736 if Same_Representation (Operand_Type, Target_Type) then 9737 return; 9738 9739 -- The real change of representation work is done by the assignment 9740 -- statement processing. So if this type conversion is appearing as 9741 -- the expression of an assignment statement, nothing needs to be 9742 -- done to the conversion. 9743 9744 elsif Nkind (Parent (N)) = N_Assignment_Statement then 9745 return; 9746 9747 -- Otherwise we need to generate a temporary variable, and do the 9748 -- change of representation assignment into that temporary variable. 9749 -- The conversion is then replaced by a reference to this variable. 9750 9751 else 9752 Cons := No_List; 9753 9754 -- If type is unconstrained we have to add a constraint, copied 9755 -- from the actual value of the left hand side. 9756 9757 if not Is_Constrained (Target_Type) then 9758 if Has_Discriminants (Operand_Type) then 9759 Disc := First_Discriminant (Operand_Type); 9760 9761 if Disc /= First_Stored_Discriminant (Operand_Type) then 9762 Disc := First_Stored_Discriminant (Operand_Type); 9763 end if; 9764 9765 Cons := New_List; 9766 while Present (Disc) loop 9767 Append_To (Cons, 9768 Make_Selected_Component (Loc, 9769 Prefix => 9770 Duplicate_Subexpr_Move_Checks (Operand), 9771 Selector_Name => 9772 Make_Identifier (Loc, Chars (Disc)))); 9773 Next_Discriminant (Disc); 9774 end loop; 9775 9776 elsif Is_Array_Type (Operand_Type) then 9777 N_Ix := First_Index (Target_Type); 9778 Cons := New_List; 9779 9780 for J in 1 .. Number_Dimensions (Operand_Type) loop 9781 9782 -- We convert the bounds explicitly. We use an unchecked 9783 -- conversion because bounds checks are done elsewhere. 9784 9785 Append_To (Cons, 9786 Make_Range (Loc, 9787 Low_Bound => 9788 Unchecked_Convert_To (Etype (N_Ix), 9789 Make_Attribute_Reference (Loc, 9790 Prefix => 9791 Duplicate_Subexpr_No_Checks 9792 (Operand, Name_Req => True), 9793 Attribute_Name => Name_First, 9794 Expressions => New_List ( 9795 Make_Integer_Literal (Loc, J)))), 9796 9797 High_Bound => 9798 Unchecked_Convert_To (Etype (N_Ix), 9799 Make_Attribute_Reference (Loc, 9800 Prefix => 9801 Duplicate_Subexpr_No_Checks 9802 (Operand, Name_Req => True), 9803 Attribute_Name => Name_Last, 9804 Expressions => New_List ( 9805 Make_Integer_Literal (Loc, J)))))); 9806 9807 Next_Index (N_Ix); 9808 end loop; 9809 end if; 9810 end if; 9811 9812 Odef := New_Occurrence_Of (Target_Type, Loc); 9813 9814 if Present (Cons) then 9815 Odef := 9816 Make_Subtype_Indication (Loc, 9817 Subtype_Mark => Odef, 9818 Constraint => 9819 Make_Index_Or_Discriminant_Constraint (Loc, 9820 Constraints => Cons)); 9821 end if; 9822 9823 Temp := Make_Temporary (Loc, 'C'); 9824 Decl := 9825 Make_Object_Declaration (Loc, 9826 Defining_Identifier => Temp, 9827 Object_Definition => Odef); 9828 9829 Set_No_Initialization (Decl, True); 9830 9831 -- Insert required actions. It is essential to suppress checks 9832 -- since we have suppressed default initialization, which means 9833 -- that the variable we create may have no discriminants. 9834 9835 Insert_Actions (N, 9836 New_List ( 9837 Decl, 9838 Make_Assignment_Statement (Loc, 9839 Name => New_Occurrence_Of (Temp, Loc), 9840 Expression => Relocate_Node (N))), 9841 Suppress => All_Checks); 9842 9843 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 9844 return; 9845 end if; 9846 end Handle_Changed_Representation; 9847 9848 ------------------------------- 9849 -- Raise_Accessibility_Error -- 9850 ------------------------------- 9851 9852 procedure Raise_Accessibility_Error is 9853 begin 9854 Rewrite (N, 9855 Make_Raise_Program_Error (Sloc (N), 9856 Reason => PE_Accessibility_Check_Failed)); 9857 Set_Etype (N, Target_Type); 9858 9859 Error_Msg_N 9860 ("??accessibility check failure", N); 9861 Error_Msg_NE 9862 ("\??& will be raised at run time", N, Standard_Program_Error); 9863 end Raise_Accessibility_Error; 9864 9865 ---------------------- 9866 -- Real_Range_Check -- 9867 ---------------------- 9868 9869 -- Case of conversions to floating-point or fixed-point. If range checks 9870 -- are enabled and the target type has a range constraint, we convert: 9871 9872 -- typ (x) 9873 9874 -- to 9875 9876 -- Tnn : typ'Base := typ'Base (x); 9877 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] 9878 -- Tnn 9879 9880 -- This is necessary when there is a conversion of integer to float or 9881 -- to fixed-point to ensure that the correct checks are made. It is not 9882 -- necessary for float to float where it is enough to simply set the 9883 -- Do_Range_Check flag. 9884 9885 procedure Real_Range_Check is 9886 Btyp : constant Entity_Id := Base_Type (Target_Type); 9887 Lo : constant Node_Id := Type_Low_Bound (Target_Type); 9888 Hi : constant Node_Id := Type_High_Bound (Target_Type); 9889 Xtyp : constant Entity_Id := Etype (Operand); 9890 Conv : Node_Id; 9891 Tnn : Entity_Id; 9892 9893 begin 9894 -- Nothing to do if conversion was rewritten 9895 9896 if Nkind (N) /= N_Type_Conversion then 9897 return; 9898 end if; 9899 9900 -- Nothing to do if range checks suppressed, or target has the same 9901 -- range as the base type (or is the base type). 9902 9903 if Range_Checks_Suppressed (Target_Type) 9904 or else (Lo = Type_Low_Bound (Btyp) 9905 and then 9906 Hi = Type_High_Bound (Btyp)) 9907 then 9908 return; 9909 end if; 9910 9911 -- Nothing to do if expression is an entity on which checks have been 9912 -- suppressed. 9913 9914 if Is_Entity_Name (Operand) 9915 and then Range_Checks_Suppressed (Entity (Operand)) 9916 then 9917 return; 9918 end if; 9919 9920 -- Nothing to do if bounds are all static and we can tell that the 9921 -- expression is within the bounds of the target. Note that if the 9922 -- operand is of an unconstrained floating-point type, then we do 9923 -- not trust it to be in range (might be infinite) 9924 9925 declare 9926 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); 9927 S_Hi : constant Node_Id := Type_High_Bound (Xtyp); 9928 9929 begin 9930 if (not Is_Floating_Point_Type (Xtyp) 9931 or else Is_Constrained (Xtyp)) 9932 and then Compile_Time_Known_Value (S_Lo) 9933 and then Compile_Time_Known_Value (S_Hi) 9934 and then Compile_Time_Known_Value (Hi) 9935 and then Compile_Time_Known_Value (Lo) 9936 then 9937 declare 9938 D_Lov : constant Ureal := Expr_Value_R (Lo); 9939 D_Hiv : constant Ureal := Expr_Value_R (Hi); 9940 S_Lov : Ureal; 9941 S_Hiv : Ureal; 9942 9943 begin 9944 if Is_Real_Type (Xtyp) then 9945 S_Lov := Expr_Value_R (S_Lo); 9946 S_Hiv := Expr_Value_R (S_Hi); 9947 else 9948 S_Lov := UR_From_Uint (Expr_Value (S_Lo)); 9949 S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); 9950 end if; 9951 9952 if D_Hiv > D_Lov 9953 and then S_Lov >= D_Lov 9954 and then S_Hiv <= D_Hiv 9955 then 9956 Set_Do_Range_Check (Operand, False); 9957 return; 9958 end if; 9959 end; 9960 end if; 9961 end; 9962 9963 -- For float to float conversions, we are done 9964 9965 if Is_Floating_Point_Type (Xtyp) 9966 and then 9967 Is_Floating_Point_Type (Btyp) 9968 then 9969 return; 9970 end if; 9971 9972 -- Otherwise rewrite the conversion as described above 9973 9974 Conv := Relocate_Node (N); 9975 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); 9976 Set_Etype (Conv, Btyp); 9977 9978 -- Enable overflow except for case of integer to float conversions, 9979 -- where it is never required, since we can never have overflow in 9980 -- this case. 9981 9982 if not Is_Integer_Type (Etype (Operand)) then 9983 Enable_Overflow_Check (Conv); 9984 end if; 9985 9986 Tnn := Make_Temporary (Loc, 'T', Conv); 9987 9988 Insert_Actions (N, New_List ( 9989 Make_Object_Declaration (Loc, 9990 Defining_Identifier => Tnn, 9991 Object_Definition => New_Occurrence_Of (Btyp, Loc), 9992 Constant_Present => True, 9993 Expression => Conv), 9994 9995 Make_Raise_Constraint_Error (Loc, 9996 Condition => 9997 Make_Or_Else (Loc, 9998 Left_Opnd => 9999 Make_Op_Lt (Loc, 10000 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 10001 Right_Opnd => 10002 Make_Attribute_Reference (Loc, 10003 Attribute_Name => Name_First, 10004 Prefix => 10005 New_Occurrence_Of (Target_Type, Loc))), 10006 10007 Right_Opnd => 10008 Make_Op_Gt (Loc, 10009 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 10010 Right_Opnd => 10011 Make_Attribute_Reference (Loc, 10012 Attribute_Name => Name_Last, 10013 Prefix => 10014 New_Occurrence_Of (Target_Type, Loc)))), 10015 Reason => CE_Range_Check_Failed))); 10016 10017 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 10018 Analyze_And_Resolve (N, Btyp); 10019 end Real_Range_Check; 10020 10021 ----------------------------- 10022 -- Has_Extra_Accessibility -- 10023 ----------------------------- 10024 10025 -- Returns true for a formal of an anonymous access type or for 10026 -- an Ada 2012-style stand-alone object of an anonymous access type. 10027 10028 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is 10029 begin 10030 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then 10031 return Present (Effective_Extra_Accessibility (Id)); 10032 else 10033 return False; 10034 end if; 10035 end Has_Extra_Accessibility; 10036 10037 -- Start of processing for Expand_N_Type_Conversion 10038 10039 begin 10040 -- Nothing at all to do if conversion is to the identical type so remove 10041 -- the conversion completely, it is useless, except that it may carry 10042 -- an Assignment_OK attribute, which must be propagated to the operand. 10043 10044 if Operand_Type = Target_Type then 10045 if Assignment_OK (N) then 10046 Set_Assignment_OK (Operand); 10047 end if; 10048 10049 Rewrite (N, Relocate_Node (Operand)); 10050 goto Done; 10051 end if; 10052 10053 -- Nothing to do if this is the second argument of read. This is a 10054 -- "backwards" conversion that will be handled by the specialized code 10055 -- in attribute processing. 10056 10057 if Nkind (Parent (N)) = N_Attribute_Reference 10058 and then Attribute_Name (Parent (N)) = Name_Read 10059 and then Next (First (Expressions (Parent (N)))) = N 10060 then 10061 goto Done; 10062 end if; 10063 10064 -- Check for case of converting to a type that has an invariant 10065 -- associated with it. This required an invariant check. We convert 10066 10067 -- typ (expr) 10068 10069 -- into 10070 10071 -- do invariant_check (typ (expr)) in typ (expr); 10072 10073 -- using Duplicate_Subexpr to avoid multiple side effects 10074 10075 -- Note: the Comes_From_Source check, and then the resetting of this 10076 -- flag prevents what would otherwise be an infinite recursion. 10077 10078 if Has_Invariants (Target_Type) 10079 and then Present (Invariant_Procedure (Target_Type)) 10080 and then Comes_From_Source (N) 10081 then 10082 Set_Comes_From_Source (N, False); 10083 Rewrite (N, 10084 Make_Expression_With_Actions (Loc, 10085 Actions => New_List ( 10086 Make_Invariant_Call (Duplicate_Subexpr (N))), 10087 Expression => Duplicate_Subexpr_No_Checks (N))); 10088 Analyze_And_Resolve (N, Target_Type); 10089 goto Done; 10090 end if; 10091 10092 -- Here if we may need to expand conversion 10093 10094 -- If the operand of the type conversion is an arithmetic operation on 10095 -- signed integers, and the based type of the signed integer type in 10096 -- question is smaller than Standard.Integer, we promote both of the 10097 -- operands to type Integer. 10098 10099 -- For example, if we have 10100 10101 -- target-type (opnd1 + opnd2) 10102 10103 -- and opnd1 and opnd2 are of type short integer, then we rewrite 10104 -- this as: 10105 10106 -- target-type (integer(opnd1) + integer(opnd2)) 10107 10108 -- We do this because we are always allowed to compute in a larger type 10109 -- if we do the right thing with the result, and in this case we are 10110 -- going to do a conversion which will do an appropriate check to make 10111 -- sure that things are in range of the target type in any case. This 10112 -- avoids some unnecessary intermediate overflows. 10113 10114 -- We might consider a similar transformation in the case where the 10115 -- target is a real type or a 64-bit integer type, and the operand 10116 -- is an arithmetic operation using a 32-bit integer type. However, 10117 -- we do not bother with this case, because it could cause significant 10118 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be 10119 -- much cheaper, but we don't want different behavior on 32-bit and 10120 -- 64-bit machines. Note that the exclusion of the 64-bit case also 10121 -- handles the configurable run-time cases where 64-bit arithmetic 10122 -- may simply be unavailable. 10123 10124 -- Note: this circuit is partially redundant with respect to the circuit 10125 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in 10126 -- the processing here. Also we still need the Checks circuit, since we 10127 -- have to be sure not to generate junk overflow checks in the first 10128 -- place, since it would be trick to remove them here! 10129 10130 if Integer_Promotion_Possible (N) then 10131 10132 -- All conditions met, go ahead with transformation 10133 10134 declare 10135 Opnd : Node_Id; 10136 L, R : Node_Id; 10137 10138 begin 10139 R := 10140 Make_Type_Conversion (Loc, 10141 Subtype_Mark => New_Reference_To (Standard_Integer, Loc), 10142 Expression => Relocate_Node (Right_Opnd (Operand))); 10143 10144 Opnd := New_Op_Node (Nkind (Operand), Loc); 10145 Set_Right_Opnd (Opnd, R); 10146 10147 if Nkind (Operand) in N_Binary_Op then 10148 L := 10149 Make_Type_Conversion (Loc, 10150 Subtype_Mark => New_Reference_To (Standard_Integer, Loc), 10151 Expression => Relocate_Node (Left_Opnd (Operand))); 10152 10153 Set_Left_Opnd (Opnd, L); 10154 end if; 10155 10156 Rewrite (N, 10157 Make_Type_Conversion (Loc, 10158 Subtype_Mark => Relocate_Node (Subtype_Mark (N)), 10159 Expression => Opnd)); 10160 10161 Analyze_And_Resolve (N, Target_Type); 10162 goto Done; 10163 end; 10164 end if; 10165 10166 -- Do validity check if validity checking operands 10167 10168 if Validity_Checks_On 10169 and then Validity_Check_Operands 10170 then 10171 Ensure_Valid (Operand); 10172 end if; 10173 10174 -- Special case of converting from non-standard boolean type 10175 10176 if Is_Boolean_Type (Operand_Type) 10177 and then (Nonzero_Is_True (Operand_Type)) 10178 then 10179 Adjust_Condition (Operand); 10180 Set_Etype (Operand, Standard_Boolean); 10181 Operand_Type := Standard_Boolean; 10182 end if; 10183 10184 -- Case of converting to an access type 10185 10186 if Is_Access_Type (Target_Type) then 10187 10188 -- Apply an accessibility check when the conversion operand is an 10189 -- access parameter (or a renaming thereof), unless conversion was 10190 -- expanded from an Unchecked_ or Unrestricted_Access attribute. 10191 -- Note that other checks may still need to be applied below (such 10192 -- as tagged type checks). 10193 10194 if Is_Entity_Name (Operand) 10195 and then Has_Extra_Accessibility (Entity (Operand)) 10196 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type 10197 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference 10198 or else Attribute_Name (Original_Node (N)) = Name_Access) 10199 then 10200 Apply_Accessibility_Check 10201 (Operand, Target_Type, Insert_Node => Operand); 10202 10203 -- If the level of the operand type is statically deeper than the 10204 -- level of the target type, then force Program_Error. Note that this 10205 -- can only occur for cases where the attribute is within the body of 10206 -- an instantiation (otherwise the conversion will already have been 10207 -- rejected as illegal). Note: warnings are issued by the analyzer 10208 -- for the instance cases. 10209 10210 elsif In_Instance_Body 10211 and then Type_Access_Level (Operand_Type) > 10212 Type_Access_Level (Target_Type) 10213 then 10214 Raise_Accessibility_Error; 10215 10216 -- When the operand is a selected access discriminant the check needs 10217 -- to be made against the level of the object denoted by the prefix 10218 -- of the selected name. Force Program_Error for this case as well 10219 -- (this accessibility violation can only happen if within the body 10220 -- of an instantiation). 10221 10222 elsif In_Instance_Body 10223 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 10224 and then Nkind (Operand) = N_Selected_Component 10225 and then Object_Access_Level (Operand) > 10226 Type_Access_Level (Target_Type) 10227 then 10228 Raise_Accessibility_Error; 10229 goto Done; 10230 end if; 10231 end if; 10232 10233 -- Case of conversions of tagged types and access to tagged types 10234 10235 -- When needed, that is to say when the expression is class-wide, Add 10236 -- runtime a tag check for (strict) downward conversion by using the 10237 -- membership test, generating: 10238 10239 -- [constraint_error when Operand not in Target_Type'Class] 10240 10241 -- or in the access type case 10242 10243 -- [constraint_error 10244 -- when Operand /= null 10245 -- and then Operand.all not in 10246 -- Designated_Type (Target_Type)'Class] 10247 10248 if (Is_Access_Type (Target_Type) 10249 and then Is_Tagged_Type (Designated_Type (Target_Type))) 10250 or else Is_Tagged_Type (Target_Type) 10251 then 10252 -- Do not do any expansion in the access type case if the parent is a 10253 -- renaming, since this is an error situation which will be caught by 10254 -- Sem_Ch8, and the expansion can interfere with this error check. 10255 10256 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then 10257 goto Done; 10258 end if; 10259 10260 -- Otherwise, proceed with processing tagged conversion 10261 10262 Tagged_Conversion : declare 10263 Actual_Op_Typ : Entity_Id; 10264 Actual_Targ_Typ : Entity_Id; 10265 Make_Conversion : Boolean := False; 10266 Root_Op_Typ : Entity_Id; 10267 10268 procedure Make_Tag_Check (Targ_Typ : Entity_Id); 10269 -- Create a membership check to test whether Operand is a member 10270 -- of Targ_Typ. If the original Target_Type is an access, include 10271 -- a test for null value. The check is inserted at N. 10272 10273 -------------------- 10274 -- Make_Tag_Check -- 10275 -------------------- 10276 10277 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is 10278 Cond : Node_Id; 10279 10280 begin 10281 -- Generate: 10282 -- [Constraint_Error 10283 -- when Operand /= null 10284 -- and then Operand.all not in Targ_Typ] 10285 10286 if Is_Access_Type (Target_Type) then 10287 Cond := 10288 Make_And_Then (Loc, 10289 Left_Opnd => 10290 Make_Op_Ne (Loc, 10291 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 10292 Right_Opnd => Make_Null (Loc)), 10293 10294 Right_Opnd => 10295 Make_Not_In (Loc, 10296 Left_Opnd => 10297 Make_Explicit_Dereference (Loc, 10298 Prefix => Duplicate_Subexpr_No_Checks (Operand)), 10299 Right_Opnd => New_Reference_To (Targ_Typ, Loc))); 10300 10301 -- Generate: 10302 -- [Constraint_Error when Operand not in Targ_Typ] 10303 10304 else 10305 Cond := 10306 Make_Not_In (Loc, 10307 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 10308 Right_Opnd => New_Reference_To (Targ_Typ, Loc)); 10309 end if; 10310 10311 Insert_Action (N, 10312 Make_Raise_Constraint_Error (Loc, 10313 Condition => Cond, 10314 Reason => CE_Tag_Check_Failed)); 10315 end Make_Tag_Check; 10316 10317 -- Start of processing for Tagged_Conversion 10318 10319 begin 10320 -- Handle entities from the limited view 10321 10322 if Is_Access_Type (Operand_Type) then 10323 Actual_Op_Typ := 10324 Available_View (Designated_Type (Operand_Type)); 10325 else 10326 Actual_Op_Typ := Operand_Type; 10327 end if; 10328 10329 if Is_Access_Type (Target_Type) then 10330 Actual_Targ_Typ := 10331 Available_View (Designated_Type (Target_Type)); 10332 else 10333 Actual_Targ_Typ := Target_Type; 10334 end if; 10335 10336 Root_Op_Typ := Root_Type (Actual_Op_Typ); 10337 10338 -- Ada 2005 (AI-251): Handle interface type conversion 10339 10340 if Is_Interface (Actual_Op_Typ) then 10341 Expand_Interface_Conversion (N, Is_Static => False); 10342 goto Done; 10343 end if; 10344 10345 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then 10346 10347 -- Create a runtime tag check for a downward class-wide type 10348 -- conversion. 10349 10350 if Is_Class_Wide_Type (Actual_Op_Typ) 10351 and then Actual_Op_Typ /= Actual_Targ_Typ 10352 and then Root_Op_Typ /= Actual_Targ_Typ 10353 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ, 10354 Use_Full_View => True) 10355 then 10356 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); 10357 Make_Conversion := True; 10358 end if; 10359 10360 -- AI05-0073: If the result subtype of the function is defined 10361 -- by an access_definition designating a specific tagged type 10362 -- T, a check is made that the result value is null or the tag 10363 -- of the object designated by the result value identifies T. 10364 -- Constraint_Error is raised if this check fails. 10365 10366 if Nkind (Parent (N)) = N_Simple_Return_Statement then 10367 declare 10368 Func : Entity_Id; 10369 Func_Typ : Entity_Id; 10370 10371 begin 10372 -- Climb scope stack looking for the enclosing function 10373 10374 Func := Current_Scope; 10375 while Present (Func) 10376 and then Ekind (Func) /= E_Function 10377 loop 10378 Func := Scope (Func); 10379 end loop; 10380 10381 -- The function's return subtype must be defined using 10382 -- an access definition. 10383 10384 if Nkind (Result_Definition (Parent (Func))) = 10385 N_Access_Definition 10386 then 10387 Func_Typ := Directly_Designated_Type (Etype (Func)); 10388 10389 -- The return subtype denotes a specific tagged type, 10390 -- in other words, a non class-wide type. 10391 10392 if Is_Tagged_Type (Func_Typ) 10393 and then not Is_Class_Wide_Type (Func_Typ) 10394 then 10395 Make_Tag_Check (Actual_Targ_Typ); 10396 Make_Conversion := True; 10397 end if; 10398 end if; 10399 end; 10400 end if; 10401 10402 -- We have generated a tag check for either a class-wide type 10403 -- conversion or for AI05-0073. 10404 10405 if Make_Conversion then 10406 declare 10407 Conv : Node_Id; 10408 begin 10409 Conv := 10410 Make_Unchecked_Type_Conversion (Loc, 10411 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 10412 Expression => Relocate_Node (Expression (N))); 10413 Rewrite (N, Conv); 10414 Analyze_And_Resolve (N, Target_Type); 10415 end; 10416 end if; 10417 end if; 10418 end Tagged_Conversion; 10419 10420 -- Case of other access type conversions 10421 10422 elsif Is_Access_Type (Target_Type) then 10423 Apply_Constraint_Check (Operand, Target_Type); 10424 10425 -- Case of conversions from a fixed-point type 10426 10427 -- These conversions require special expansion and processing, found in 10428 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, 10429 -- since from a semantic point of view, these are simple integer 10430 -- conversions, which do not need further processing. 10431 10432 elsif Is_Fixed_Point_Type (Operand_Type) 10433 and then not Conversion_OK (N) 10434 then 10435 -- We should never see universal fixed at this case, since the 10436 -- expansion of the constituent divide or multiply should have 10437 -- eliminated the explicit mention of universal fixed. 10438 10439 pragma Assert (Operand_Type /= Universal_Fixed); 10440 10441 -- Check for special case of the conversion to universal real that 10442 -- occurs as a result of the use of a round attribute. In this case, 10443 -- the real type for the conversion is taken from the target type of 10444 -- the Round attribute and the result must be marked as rounded. 10445 10446 if Target_Type = Universal_Real 10447 and then Nkind (Parent (N)) = N_Attribute_Reference 10448 and then Attribute_Name (Parent (N)) = Name_Round 10449 then 10450 Set_Rounded_Result (N); 10451 Set_Etype (N, Etype (Parent (N))); 10452 end if; 10453 10454 -- Otherwise do correct fixed-conversion, but skip these if the 10455 -- Conversion_OK flag is set, because from a semantic point of view 10456 -- these are simple integer conversions needing no further processing 10457 -- (the backend will simply treat them as integers). 10458 10459 if not Conversion_OK (N) then 10460 if Is_Fixed_Point_Type (Etype (N)) then 10461 Expand_Convert_Fixed_To_Fixed (N); 10462 Real_Range_Check; 10463 10464 elsif Is_Integer_Type (Etype (N)) then 10465 Expand_Convert_Fixed_To_Integer (N); 10466 10467 else 10468 pragma Assert (Is_Floating_Point_Type (Etype (N))); 10469 Expand_Convert_Fixed_To_Float (N); 10470 Real_Range_Check; 10471 end if; 10472 end if; 10473 10474 -- Case of conversions to a fixed-point type 10475 10476 -- These conversions require special expansion and processing, found in 10477 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, 10478 -- since from a semantic point of view, these are simple integer 10479 -- conversions, which do not need further processing. 10480 10481 elsif Is_Fixed_Point_Type (Target_Type) 10482 and then not Conversion_OK (N) 10483 then 10484 if Is_Integer_Type (Operand_Type) then 10485 Expand_Convert_Integer_To_Fixed (N); 10486 Real_Range_Check; 10487 else 10488 pragma Assert (Is_Floating_Point_Type (Operand_Type)); 10489 Expand_Convert_Float_To_Fixed (N); 10490 Real_Range_Check; 10491 end if; 10492 10493 -- Case of float-to-integer conversions 10494 10495 -- We also handle float-to-fixed conversions with Conversion_OK set 10496 -- since semantically the fixed-point target is treated as though it 10497 -- were an integer in such cases. 10498 10499 elsif Is_Floating_Point_Type (Operand_Type) 10500 and then 10501 (Is_Integer_Type (Target_Type) 10502 or else 10503 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N))) 10504 then 10505 -- One more check here, gcc is still not able to do conversions of 10506 -- this type with proper overflow checking, and so gigi is doing an 10507 -- approximation of what is required by doing floating-point compares 10508 -- with the end-point. But that can lose precision in some cases, and 10509 -- give a wrong result. Converting the operand to Universal_Real is 10510 -- helpful, but still does not catch all cases with 64-bit integers 10511 -- on targets with only 64-bit floats. 10512 10513 -- The above comment seems obsoleted by Apply_Float_Conversion_Check 10514 -- Can this code be removed ??? 10515 10516 if Do_Range_Check (Operand) then 10517 Rewrite (Operand, 10518 Make_Type_Conversion (Loc, 10519 Subtype_Mark => 10520 New_Occurrence_Of (Universal_Real, Loc), 10521 Expression => 10522 Relocate_Node (Operand))); 10523 10524 Set_Etype (Operand, Universal_Real); 10525 Enable_Range_Check (Operand); 10526 Set_Do_Range_Check (Expression (Operand), False); 10527 end if; 10528 10529 -- Case of array conversions 10530 10531 -- Expansion of array conversions, add required length/range checks but 10532 -- only do this if there is no change of representation. For handling of 10533 -- this case, see Handle_Changed_Representation. 10534 10535 elsif Is_Array_Type (Target_Type) then 10536 if Is_Constrained (Target_Type) then 10537 Apply_Length_Check (Operand, Target_Type); 10538 else 10539 Apply_Range_Check (Operand, Target_Type); 10540 end if; 10541 10542 Handle_Changed_Representation; 10543 10544 -- Case of conversions of discriminated types 10545 10546 -- Add required discriminant checks if target is constrained. Again this 10547 -- change is skipped if we have a change of representation. 10548 10549 elsif Has_Discriminants (Target_Type) 10550 and then Is_Constrained (Target_Type) 10551 then 10552 Apply_Discriminant_Check (Operand, Target_Type); 10553 Handle_Changed_Representation; 10554 10555 -- Case of all other record conversions. The only processing required 10556 -- is to check for a change of representation requiring the special 10557 -- assignment processing. 10558 10559 elsif Is_Record_Type (Target_Type) then 10560 10561 -- Ada 2005 (AI-216): Program_Error is raised when converting from 10562 -- a derived Unchecked_Union type to an unconstrained type that is 10563 -- not Unchecked_Union if the operand lacks inferable discriminants. 10564 10565 if Is_Derived_Type (Operand_Type) 10566 and then Is_Unchecked_Union (Base_Type (Operand_Type)) 10567 and then not Is_Constrained (Target_Type) 10568 and then not Is_Unchecked_Union (Base_Type (Target_Type)) 10569 and then not Has_Inferable_Discriminants (Operand) 10570 then 10571 -- To prevent Gigi from generating illegal code, we generate a 10572 -- Program_Error node, but we give it the target type of the 10573 -- conversion (is this requirement documented somewhere ???) 10574 10575 declare 10576 PE : constant Node_Id := Make_Raise_Program_Error (Loc, 10577 Reason => PE_Unchecked_Union_Restriction); 10578 10579 begin 10580 Set_Etype (PE, Target_Type); 10581 Rewrite (N, PE); 10582 10583 end; 10584 else 10585 Handle_Changed_Representation; 10586 end if; 10587 10588 -- Case of conversions of enumeration types 10589 10590 elsif Is_Enumeration_Type (Target_Type) then 10591 10592 -- Special processing is required if there is a change of 10593 -- representation (from enumeration representation clauses). 10594 10595 if not Same_Representation (Target_Type, Operand_Type) then 10596 10597 -- Convert: x(y) to x'val (ytyp'val (y)) 10598 10599 Rewrite (N, 10600 Make_Attribute_Reference (Loc, 10601 Prefix => New_Occurrence_Of (Target_Type, Loc), 10602 Attribute_Name => Name_Val, 10603 Expressions => New_List ( 10604 Make_Attribute_Reference (Loc, 10605 Prefix => New_Occurrence_Of (Operand_Type, Loc), 10606 Attribute_Name => Name_Pos, 10607 Expressions => New_List (Operand))))); 10608 10609 Analyze_And_Resolve (N, Target_Type); 10610 end if; 10611 10612 -- Case of conversions to floating-point 10613 10614 elsif Is_Floating_Point_Type (Target_Type) then 10615 Real_Range_Check; 10616 end if; 10617 10618 -- At this stage, either the conversion node has been transformed into 10619 -- some other equivalent expression, or left as a conversion that can be 10620 -- handled by Gigi, in the following cases: 10621 10622 -- Conversions with no change of representation or type 10623 10624 -- Numeric conversions involving integer, floating- and fixed-point 10625 -- values. Fixed-point values are allowed only if Conversion_OK is 10626 -- set, i.e. if the fixed-point values are to be treated as integers. 10627 10628 -- No other conversions should be passed to Gigi 10629 10630 -- Check: are these rules stated in sinfo??? if so, why restate here??? 10631 10632 -- The only remaining step is to generate a range check if we still have 10633 -- a type conversion at this stage and Do_Range_Check is set. For now we 10634 -- do this only for conversions of discrete types. 10635 10636 if Nkind (N) = N_Type_Conversion 10637 and then Is_Discrete_Type (Etype (N)) 10638 then 10639 declare 10640 Expr : constant Node_Id := Expression (N); 10641 Ftyp : Entity_Id; 10642 Ityp : Entity_Id; 10643 10644 begin 10645 if Do_Range_Check (Expr) 10646 and then Is_Discrete_Type (Etype (Expr)) 10647 then 10648 Set_Do_Range_Check (Expr, False); 10649 10650 -- Before we do a range check, we have to deal with treating a 10651 -- fixed-point operand as an integer. The way we do this is 10652 -- simply to do an unchecked conversion to an appropriate 10653 -- integer type large enough to hold the result. 10654 10655 -- This code is not active yet, because we are only dealing 10656 -- with discrete types so far ??? 10657 10658 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer 10659 and then Treat_Fixed_As_Integer (Expr) 10660 then 10661 Ftyp := Base_Type (Etype (Expr)); 10662 10663 if Esize (Ftyp) >= Esize (Standard_Integer) then 10664 Ityp := Standard_Long_Long_Integer; 10665 else 10666 Ityp := Standard_Integer; 10667 end if; 10668 10669 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); 10670 end if; 10671 10672 -- Reset overflow flag, since the range check will include 10673 -- dealing with possible overflow, and generate the check. If 10674 -- Address is either a source type or target type, suppress 10675 -- range check to avoid typing anomalies when it is a visible 10676 -- integer type. 10677 10678 Set_Do_Overflow_Check (N, False); 10679 if not Is_Descendent_Of_Address (Etype (Expr)) 10680 and then not Is_Descendent_Of_Address (Target_Type) 10681 then 10682 Generate_Range_Check 10683 (Expr, Target_Type, CE_Range_Check_Failed); 10684 end if; 10685 end if; 10686 end; 10687 end if; 10688 10689 -- Final step, if the result is a type conversion involving Vax_Float 10690 -- types, then it is subject for further special processing. 10691 10692 if Nkind (N) = N_Type_Conversion 10693 and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type)) 10694 then 10695 Expand_Vax_Conversion (N); 10696 goto Done; 10697 end if; 10698 10699 -- Here at end of processing 10700 10701 <<Done>> 10702 -- Apply predicate check if required. Note that we can't just call 10703 -- Apply_Predicate_Check here, because the type looks right after 10704 -- the conversion and it would omit the check. The Comes_From_Source 10705 -- guard is necessary to prevent infinite recursions when we generate 10706 -- internal conversions for the purpose of checking predicates. 10707 10708 if Present (Predicate_Function (Target_Type)) 10709 and then Target_Type /= Operand_Type 10710 and then Comes_From_Source (N) 10711 then 10712 declare 10713 New_Expr : constant Node_Id := Duplicate_Subexpr (N); 10714 10715 begin 10716 -- Avoid infinite recursion on the subsequent expansion of 10717 -- of the copy of the original type conversion. 10718 10719 Set_Comes_From_Source (New_Expr, False); 10720 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr)); 10721 end; 10722 end if; 10723 end Expand_N_Type_Conversion; 10724 10725 ----------------------------------- 10726 -- Expand_N_Unchecked_Expression -- 10727 ----------------------------------- 10728 10729 -- Remove the unchecked expression node from the tree. Its job was simply 10730 -- to make sure that its constituent expression was handled with checks 10731 -- off, and now that that is done, we can remove it from the tree, and 10732 -- indeed must, since Gigi does not expect to see these nodes. 10733 10734 procedure Expand_N_Unchecked_Expression (N : Node_Id) is 10735 Exp : constant Node_Id := Expression (N); 10736 begin 10737 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); 10738 Rewrite (N, Exp); 10739 end Expand_N_Unchecked_Expression; 10740 10741 ---------------------------------------- 10742 -- Expand_N_Unchecked_Type_Conversion -- 10743 ---------------------------------------- 10744 10745 -- If this cannot be handled by Gigi and we haven't already made a 10746 -- temporary for it, do it now. 10747 10748 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is 10749 Target_Type : constant Entity_Id := Etype (N); 10750 Operand : constant Node_Id := Expression (N); 10751 Operand_Type : constant Entity_Id := Etype (Operand); 10752 10753 begin 10754 -- Nothing at all to do if conversion is to the identical type so remove 10755 -- the conversion completely, it is useless, except that it may carry 10756 -- an Assignment_OK indication which must be propagated to the operand. 10757 10758 if Operand_Type = Target_Type then 10759 10760 -- Code duplicates Expand_N_Unchecked_Expression above, factor??? 10761 10762 if Assignment_OK (N) then 10763 Set_Assignment_OK (Operand); 10764 end if; 10765 10766 Rewrite (N, Relocate_Node (Operand)); 10767 return; 10768 end if; 10769 10770 -- If we have a conversion of a compile time known value to a target 10771 -- type and the value is in range of the target type, then we can simply 10772 -- replace the construct by an integer literal of the correct type. We 10773 -- only apply this to integer types being converted. Possibly it may 10774 -- apply in other cases, but it is too much trouble to worry about. 10775 10776 -- Note that we do not do this transformation if the Kill_Range_Check 10777 -- flag is set, since then the value may be outside the expected range. 10778 -- This happens in the Normalize_Scalars case. 10779 10780 -- We also skip this if either the target or operand type is biased 10781 -- because in this case, the unchecked conversion is supposed to 10782 -- preserve the bit pattern, not the integer value. 10783 10784 if Is_Integer_Type (Target_Type) 10785 and then not Has_Biased_Representation (Target_Type) 10786 and then Is_Integer_Type (Operand_Type) 10787 and then not Has_Biased_Representation (Operand_Type) 10788 and then Compile_Time_Known_Value (Operand) 10789 and then not Kill_Range_Check (N) 10790 then 10791 declare 10792 Val : constant Uint := Expr_Value (Operand); 10793 10794 begin 10795 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) 10796 and then 10797 Compile_Time_Known_Value (Type_High_Bound (Target_Type)) 10798 and then 10799 Val >= Expr_Value (Type_Low_Bound (Target_Type)) 10800 and then 10801 Val <= Expr_Value (Type_High_Bound (Target_Type)) 10802 then 10803 Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); 10804 10805 -- If Address is the target type, just set the type to avoid a 10806 -- spurious type error on the literal when Address is a visible 10807 -- integer type. 10808 10809 if Is_Descendent_Of_Address (Target_Type) then 10810 Set_Etype (N, Target_Type); 10811 else 10812 Analyze_And_Resolve (N, Target_Type); 10813 end if; 10814 10815 return; 10816 end if; 10817 end; 10818 end if; 10819 10820 -- Nothing to do if conversion is safe 10821 10822 if Safe_Unchecked_Type_Conversion (N) then 10823 return; 10824 end if; 10825 10826 -- Otherwise force evaluation unless Assignment_OK flag is set (this 10827 -- flag indicates ??? More comments needed here) 10828 10829 if Assignment_OK (N) then 10830 null; 10831 else 10832 Force_Evaluation (N); 10833 end if; 10834 end Expand_N_Unchecked_Type_Conversion; 10835 10836 ---------------------------- 10837 -- Expand_Record_Equality -- 10838 ---------------------------- 10839 10840 -- For non-variant records, Equality is expanded when needed into: 10841 10842 -- and then Lhs.Discr1 = Rhs.Discr1 10843 -- and then ... 10844 -- and then Lhs.Discrn = Rhs.Discrn 10845 -- and then Lhs.Cmp1 = Rhs.Cmp1 10846 -- and then ... 10847 -- and then Lhs.Cmpn = Rhs.Cmpn 10848 10849 -- The expression is folded by the back-end for adjacent fields. This 10850 -- function is called for tagged record in only one occasion: for imple- 10851 -- menting predefined primitive equality (see Predefined_Primitives_Bodies) 10852 -- otherwise the primitive "=" is used directly. 10853 10854 function Expand_Record_Equality 10855 (Nod : Node_Id; 10856 Typ : Entity_Id; 10857 Lhs : Node_Id; 10858 Rhs : Node_Id; 10859 Bodies : List_Id) return Node_Id 10860 is 10861 Loc : constant Source_Ptr := Sloc (Nod); 10862 10863 Result : Node_Id; 10864 C : Entity_Id; 10865 10866 First_Time : Boolean := True; 10867 10868 function Suitable_Element (C : Entity_Id) return Entity_Id; 10869 -- Return the first field to compare beginning with C, skipping the 10870 -- inherited components. 10871 10872 ---------------------- 10873 -- Suitable_Element -- 10874 ---------------------- 10875 10876 function Suitable_Element (C : Entity_Id) return Entity_Id is 10877 begin 10878 if No (C) then 10879 return Empty; 10880 10881 elsif Ekind (C) /= E_Discriminant 10882 and then Ekind (C) /= E_Component 10883 then 10884 return Suitable_Element (Next_Entity (C)); 10885 10886 -- Below test for C /= Original_Record_Component (C) is dubious 10887 -- if Typ is a constrained record subtype??? 10888 10889 elsif Is_Tagged_Type (Typ) 10890 and then C /= Original_Record_Component (C) 10891 then 10892 return Suitable_Element (Next_Entity (C)); 10893 10894 elsif Chars (C) = Name_uTag then 10895 return Suitable_Element (Next_Entity (C)); 10896 10897 -- The .NET/JVM version of type Root_Controlled contains two fields 10898 -- which should not be considered part of the object. To achieve 10899 -- proper equiality between two controlled objects on .NET/JVM, skip 10900 -- field _parent whenever it is of type Root_Controlled. 10901 10902 elsif Chars (C) = Name_uParent 10903 and then VM_Target /= No_VM 10904 and then Etype (C) = RTE (RE_Root_Controlled) 10905 then 10906 return Suitable_Element (Next_Entity (C)); 10907 10908 elsif Is_Interface (Etype (C)) then 10909 return Suitable_Element (Next_Entity (C)); 10910 10911 else 10912 return C; 10913 end if; 10914 end Suitable_Element; 10915 10916 -- Start of processing for Expand_Record_Equality 10917 10918 begin 10919 -- Generates the following code: (assuming that Typ has one Discr and 10920 -- component C2 is also a record) 10921 10922 -- True 10923 -- and then Lhs.Discr1 = Rhs.Discr1 10924 -- and then Lhs.C1 = Rhs.C1 10925 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn 10926 -- and then ... 10927 -- and then Lhs.Cmpn = Rhs.Cmpn 10928 10929 Result := New_Reference_To (Standard_True, Loc); 10930 C := Suitable_Element (First_Entity (Typ)); 10931 while Present (C) loop 10932 declare 10933 New_Lhs : Node_Id; 10934 New_Rhs : Node_Id; 10935 Check : Node_Id; 10936 10937 begin 10938 if First_Time then 10939 First_Time := False; 10940 New_Lhs := Lhs; 10941 New_Rhs := Rhs; 10942 else 10943 New_Lhs := New_Copy_Tree (Lhs); 10944 New_Rhs := New_Copy_Tree (Rhs); 10945 end if; 10946 10947 Check := 10948 Expand_Composite_Equality (Nod, Etype (C), 10949 Lhs => 10950 Make_Selected_Component (Loc, 10951 Prefix => New_Lhs, 10952 Selector_Name => New_Reference_To (C, Loc)), 10953 Rhs => 10954 Make_Selected_Component (Loc, 10955 Prefix => New_Rhs, 10956 Selector_Name => New_Reference_To (C, Loc)), 10957 Bodies => Bodies); 10958 10959 -- If some (sub)component is an unchecked_union, the whole 10960 -- operation will raise program error. 10961 10962 if Nkind (Check) = N_Raise_Program_Error then 10963 Result := Check; 10964 Set_Etype (Result, Standard_Boolean); 10965 exit; 10966 else 10967 Result := 10968 Make_And_Then (Loc, 10969 Left_Opnd => Result, 10970 Right_Opnd => Check); 10971 end if; 10972 end; 10973 10974 C := Suitable_Element (Next_Entity (C)); 10975 end loop; 10976 10977 return Result; 10978 end Expand_Record_Equality; 10979 10980 --------------------------- 10981 -- Expand_Set_Membership -- 10982 --------------------------- 10983 10984 procedure Expand_Set_Membership (N : Node_Id) is 10985 Lop : constant Node_Id := Left_Opnd (N); 10986 Alt : Node_Id; 10987 Res : Node_Id; 10988 10989 function Make_Cond (Alt : Node_Id) return Node_Id; 10990 -- If the alternative is a subtype mark, create a simple membership 10991 -- test. Otherwise create an equality test for it. 10992 10993 --------------- 10994 -- Make_Cond -- 10995 --------------- 10996 10997 function Make_Cond (Alt : Node_Id) return Node_Id is 10998 Cond : Node_Id; 10999 L : constant Node_Id := New_Copy (Lop); 11000 R : constant Node_Id := Relocate_Node (Alt); 11001 11002 begin 11003 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) 11004 or else Nkind (Alt) = N_Range 11005 then 11006 Cond := 11007 Make_In (Sloc (Alt), 11008 Left_Opnd => L, 11009 Right_Opnd => R); 11010 else 11011 Cond := 11012 Make_Op_Eq (Sloc (Alt), 11013 Left_Opnd => L, 11014 Right_Opnd => R); 11015 end if; 11016 11017 return Cond; 11018 end Make_Cond; 11019 11020 -- Start of processing for Expand_Set_Membership 11021 11022 begin 11023 Remove_Side_Effects (Lop); 11024 11025 Alt := Last (Alternatives (N)); 11026 Res := Make_Cond (Alt); 11027 11028 Prev (Alt); 11029 while Present (Alt) loop 11030 Res := 11031 Make_Or_Else (Sloc (Alt), 11032 Left_Opnd => Make_Cond (Alt), 11033 Right_Opnd => Res); 11034 Prev (Alt); 11035 end loop; 11036 11037 Rewrite (N, Res); 11038 Analyze_And_Resolve (N, Standard_Boolean); 11039 end Expand_Set_Membership; 11040 11041 ----------------------------------- 11042 -- Expand_Short_Circuit_Operator -- 11043 ----------------------------------- 11044 11045 -- Deal with special expansion if actions are present for the right operand 11046 -- and deal with optimizing case of arguments being True or False. We also 11047 -- deal with the special case of non-standard boolean values. 11048 11049 procedure Expand_Short_Circuit_Operator (N : Node_Id) is 11050 Loc : constant Source_Ptr := Sloc (N); 11051 Typ : constant Entity_Id := Etype (N); 11052 Left : constant Node_Id := Left_Opnd (N); 11053 Right : constant Node_Id := Right_Opnd (N); 11054 LocR : constant Source_Ptr := Sloc (Right); 11055 Actlist : List_Id; 11056 11057 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; 11058 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); 11059 -- If Left = Shortcut_Value then Right need not be evaluated 11060 11061 function Make_Test_Expr (Opnd : Node_Id) return Node_Id; 11062 -- For Opnd a boolean expression, return a Boolean expression equivalent 11063 -- to Opnd /= Shortcut_Value. 11064 11065 -------------------- 11066 -- Make_Test_Expr -- 11067 -------------------- 11068 11069 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is 11070 begin 11071 if Shortcut_Value then 11072 return Make_Op_Not (Sloc (Opnd), Opnd); 11073 else 11074 return Opnd; 11075 end if; 11076 end Make_Test_Expr; 11077 11078 Op_Var : Entity_Id; 11079 -- Entity for a temporary variable holding the value of the operator, 11080 -- used for expansion in the case where actions are present. 11081 11082 -- Start of processing for Expand_Short_Circuit_Operator 11083 11084 begin 11085 -- Deal with non-standard booleans 11086 11087 if Is_Boolean_Type (Typ) then 11088 Adjust_Condition (Left); 11089 Adjust_Condition (Right); 11090 Set_Etype (N, Standard_Boolean); 11091 end if; 11092 11093 -- Check for cases where left argument is known to be True or False 11094 11095 if Compile_Time_Known_Value (Left) then 11096 11097 -- Mark SCO for left condition as compile time known 11098 11099 if Generate_SCO and then Comes_From_Source (Left) then 11100 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); 11101 end if; 11102 11103 -- Rewrite True AND THEN Right / False OR ELSE Right to Right. 11104 -- Any actions associated with Right will be executed unconditionally 11105 -- and can thus be inserted into the tree unconditionally. 11106 11107 if Expr_Value_E (Left) /= Shortcut_Ent then 11108 if Present (Actions (N)) then 11109 Insert_Actions (N, Actions (N)); 11110 end if; 11111 11112 Rewrite (N, Right); 11113 11114 -- Rewrite False AND THEN Right / True OR ELSE Right to Left. 11115 -- In this case we can forget the actions associated with Right, 11116 -- since they will never be executed. 11117 11118 else 11119 Kill_Dead_Code (Right); 11120 Kill_Dead_Code (Actions (N)); 11121 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 11122 end if; 11123 11124 Adjust_Result_Type (N, Typ); 11125 return; 11126 end if; 11127 11128 -- If Actions are present for the right operand, we have to do some 11129 -- special processing. We can't just let these actions filter back into 11130 -- code preceding the short circuit (which is what would have happened 11131 -- if we had not trapped them in the short-circuit form), since they 11132 -- must only be executed if the right operand of the short circuit is 11133 -- executed and not otherwise. 11134 11135 -- the temporary variable C. 11136 11137 if Present (Actions (N)) then 11138 Actlist := Actions (N); 11139 11140 -- The old approach is to expand: 11141 11142 -- left AND THEN right 11143 11144 -- into 11145 11146 -- C : Boolean := False; 11147 -- IF left THEN 11148 -- Actions; 11149 -- IF right THEN 11150 -- C := True; 11151 -- END IF; 11152 -- END IF; 11153 11154 -- and finally rewrite the operator into a reference to C. Similarly 11155 -- for left OR ELSE right, with negated values. Note that this 11156 -- rewrite causes some difficulties for coverage analysis because 11157 -- of the introduction of the new variable C, which obscures the 11158 -- structure of the test. 11159 11160 -- We use this "old approach" if use of N_Expression_With_Actions 11161 -- is False (see description in Opt of when this is or is not set). 11162 11163 if not Use_Expression_With_Actions then 11164 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); 11165 11166 Insert_Action (N, 11167 Make_Object_Declaration (Loc, 11168 Defining_Identifier => 11169 Op_Var, 11170 Object_Definition => 11171 New_Occurrence_Of (Standard_Boolean, Loc), 11172 Expression => 11173 New_Occurrence_Of (Shortcut_Ent, Loc))); 11174 11175 Append_To (Actlist, 11176 Make_Implicit_If_Statement (Right, 11177 Condition => Make_Test_Expr (Right), 11178 Then_Statements => New_List ( 11179 Make_Assignment_Statement (LocR, 11180 Name => New_Occurrence_Of (Op_Var, LocR), 11181 Expression => 11182 New_Occurrence_Of 11183 (Boolean_Literals (not Shortcut_Value), LocR))))); 11184 11185 Insert_Action (N, 11186 Make_Implicit_If_Statement (Left, 11187 Condition => Make_Test_Expr (Left), 11188 Then_Statements => Actlist)); 11189 11190 Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); 11191 Analyze_And_Resolve (N, Standard_Boolean); 11192 11193 -- The new approach, activated for now by the use of debug flag 11194 -- -gnatd.X is to use the new Expression_With_Actions node for the 11195 -- right operand of the short-circuit form. This should solve the 11196 -- traceability problems for coverage analysis. 11197 11198 else 11199 Rewrite (Right, 11200 Make_Expression_With_Actions (LocR, 11201 Expression => Relocate_Node (Right), 11202 Actions => Actlist)); 11203 Set_Actions (N, No_List); 11204 Analyze_And_Resolve (Right, Standard_Boolean); 11205 end if; 11206 11207 Adjust_Result_Type (N, Typ); 11208 return; 11209 end if; 11210 11211 -- No actions present, check for cases of right argument True/False 11212 11213 if Compile_Time_Known_Value (Right) then 11214 11215 -- Mark SCO for left condition as compile time known 11216 11217 if Generate_SCO and then Comes_From_Source (Right) then 11218 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); 11219 end if; 11220 11221 -- Change (Left and then True), (Left or else False) to Left. 11222 -- Note that we know there are no actions associated with the right 11223 -- operand, since we just checked for this case above. 11224 11225 if Expr_Value_E (Right) /= Shortcut_Ent then 11226 Rewrite (N, Left); 11227 11228 -- Change (Left and then False), (Left or else True) to Right, 11229 -- making sure to preserve any side effects associated with the Left 11230 -- operand. 11231 11232 else 11233 Remove_Side_Effects (Left); 11234 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 11235 end if; 11236 end if; 11237 11238 Adjust_Result_Type (N, Typ); 11239 end Expand_Short_Circuit_Operator; 11240 11241 ------------------------------------- 11242 -- Fixup_Universal_Fixed_Operation -- 11243 ------------------------------------- 11244 11245 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is 11246 Conv : constant Node_Id := Parent (N); 11247 11248 begin 11249 -- We must have a type conversion immediately above us 11250 11251 pragma Assert (Nkind (Conv) = N_Type_Conversion); 11252 11253 -- Normally the type conversion gives our target type. The exception 11254 -- occurs in the case of the Round attribute, where the conversion 11255 -- will be to universal real, and our real type comes from the Round 11256 -- attribute (as well as an indication that we must round the result) 11257 11258 if Nkind (Parent (Conv)) = N_Attribute_Reference 11259 and then Attribute_Name (Parent (Conv)) = Name_Round 11260 then 11261 Set_Etype (N, Etype (Parent (Conv))); 11262 Set_Rounded_Result (N); 11263 11264 -- Normal case where type comes from conversion above us 11265 11266 else 11267 Set_Etype (N, Etype (Conv)); 11268 end if; 11269 end Fixup_Universal_Fixed_Operation; 11270 11271 --------------------------------- 11272 -- Has_Inferable_Discriminants -- 11273 --------------------------------- 11274 11275 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is 11276 11277 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; 11278 -- Determines whether the left-most prefix of a selected component is a 11279 -- formal parameter in a subprogram. Assumes N is a selected component. 11280 11281 -------------------------------- 11282 -- Prefix_Is_Formal_Parameter -- 11283 -------------------------------- 11284 11285 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is 11286 Sel_Comp : Node_Id; 11287 11288 begin 11289 -- Move to the left-most prefix by climbing up the tree 11290 11291 Sel_Comp := N; 11292 while Present (Parent (Sel_Comp)) 11293 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component 11294 loop 11295 Sel_Comp := Parent (Sel_Comp); 11296 end loop; 11297 11298 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; 11299 end Prefix_Is_Formal_Parameter; 11300 11301 -- Start of processing for Has_Inferable_Discriminants 11302 11303 begin 11304 -- For selected components, the subtype of the selector must be a 11305 -- constrained Unchecked_Union. If the component is subject to a 11306 -- per-object constraint, then the enclosing object must have inferable 11307 -- discriminants. 11308 11309 if Nkind (N) = N_Selected_Component then 11310 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then 11311 11312 -- A small hack. If we have a per-object constrained selected 11313 -- component of a formal parameter, return True since we do not 11314 -- know the actual parameter association yet. 11315 11316 if Prefix_Is_Formal_Parameter (N) then 11317 return True; 11318 11319 -- Otherwise, check the enclosing object and the selector 11320 11321 else 11322 return Has_Inferable_Discriminants (Prefix (N)) 11323 and then Has_Inferable_Discriminants (Selector_Name (N)); 11324 end if; 11325 11326 -- The call to Has_Inferable_Discriminants will determine whether 11327 -- the selector has a constrained Unchecked_Union nominal type. 11328 11329 else 11330 return Has_Inferable_Discriminants (Selector_Name (N)); 11331 end if; 11332 11333 -- A qualified expression has inferable discriminants if its subtype 11334 -- mark is a constrained Unchecked_Union subtype. 11335 11336 elsif Nkind (N) = N_Qualified_Expression then 11337 return Is_Unchecked_Union (Etype (Subtype_Mark (N))) 11338 and then Is_Constrained (Etype (Subtype_Mark (N))); 11339 11340 -- For all other names, it is sufficient to have a constrained 11341 -- Unchecked_Union nominal subtype. 11342 11343 else 11344 return Is_Unchecked_Union (Base_Type (Etype (N))) 11345 and then Is_Constrained (Etype (N)); 11346 end if; 11347 end Has_Inferable_Discriminants; 11348 11349 ------------------------------- 11350 -- Insert_Dereference_Action -- 11351 ------------------------------- 11352 11353 procedure Insert_Dereference_Action (N : Node_Id) is 11354 11355 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; 11356 -- Return true if type of P is derived from Checked_Pool; 11357 11358 ----------------------------- 11359 -- Is_Checked_Storage_Pool -- 11360 ----------------------------- 11361 11362 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is 11363 T : Entity_Id; 11364 11365 begin 11366 if No (P) then 11367 return False; 11368 end if; 11369 11370 T := Etype (P); 11371 while T /= Etype (T) loop 11372 if Is_RTE (T, RE_Checked_Pool) then 11373 return True; 11374 else 11375 T := Etype (T); 11376 end if; 11377 end loop; 11378 11379 return False; 11380 end Is_Checked_Storage_Pool; 11381 11382 -- Local variables 11383 11384 Typ : constant Entity_Id := Etype (N); 11385 Desig : constant Entity_Id := Available_View (Designated_Type (Typ)); 11386 Loc : constant Source_Ptr := Sloc (N); 11387 Pool : constant Entity_Id := Associated_Storage_Pool (Typ); 11388 Pnod : constant Node_Id := Parent (N); 11389 11390 Addr : Entity_Id; 11391 Alig : Entity_Id; 11392 Deref : Node_Id; 11393 Size : Entity_Id; 11394 Stmt : Node_Id; 11395 11396 -- Start of processing for Insert_Dereference_Action 11397 11398 begin 11399 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference); 11400 11401 -- Do not re-expand a dereference which has already been processed by 11402 -- this routine. 11403 11404 if Has_Dereference_Action (Pnod) then 11405 return; 11406 11407 -- Do not perform this type of expansion for internally-generated 11408 -- dereferences. 11409 11410 elsif not Comes_From_Source (Original_Node (Pnod)) then 11411 return; 11412 11413 -- A dereference action is only applicable to objects which have been 11414 -- allocated on a checked pool. 11415 11416 elsif not Is_Checked_Storage_Pool (Pool) then 11417 return; 11418 end if; 11419 11420 -- Extract the address of the dereferenced object. Generate: 11421 11422 -- Addr : System.Address := <N>'Pool_Address; 11423 11424 Addr := Make_Temporary (Loc, 'P'); 11425 11426 Insert_Action (N, 11427 Make_Object_Declaration (Loc, 11428 Defining_Identifier => Addr, 11429 Object_Definition => 11430 New_Reference_To (RTE (RE_Address), Loc), 11431 Expression => 11432 Make_Attribute_Reference (Loc, 11433 Prefix => Duplicate_Subexpr_Move_Checks (N), 11434 Attribute_Name => Name_Pool_Address))); 11435 11436 -- Calculate the size of the dereferenced object. Generate: 11437 11438 -- Size : Storage_Count := <N>.all'Size / Storage_Unit; 11439 11440 Deref := 11441 Make_Explicit_Dereference (Loc, 11442 Prefix => Duplicate_Subexpr_Move_Checks (N)); 11443 Set_Has_Dereference_Action (Deref); 11444 11445 Size := Make_Temporary (Loc, 'S'); 11446 11447 Insert_Action (N, 11448 Make_Object_Declaration (Loc, 11449 Defining_Identifier => Size, 11450 11451 Object_Definition => 11452 New_Reference_To (RTE (RE_Storage_Count), Loc), 11453 11454 Expression => 11455 Make_Op_Divide (Loc, 11456 Left_Opnd => 11457 Make_Attribute_Reference (Loc, 11458 Prefix => Deref, 11459 Attribute_Name => Name_Size), 11460 Right_Opnd => 11461 Make_Integer_Literal (Loc, System_Storage_Unit)))); 11462 11463 -- Calculate the alignment of the dereferenced object. Generate: 11464 -- Alig : constant Storage_Count := <N>.all'Alignment; 11465 11466 Deref := 11467 Make_Explicit_Dereference (Loc, 11468 Prefix => Duplicate_Subexpr_Move_Checks (N)); 11469 Set_Has_Dereference_Action (Deref); 11470 11471 Alig := Make_Temporary (Loc, 'A'); 11472 11473 Insert_Action (N, 11474 Make_Object_Declaration (Loc, 11475 Defining_Identifier => Alig, 11476 Object_Definition => 11477 New_Reference_To (RTE (RE_Storage_Count), Loc), 11478 Expression => 11479 Make_Attribute_Reference (Loc, 11480 Prefix => Deref, 11481 Attribute_Name => Name_Alignment))); 11482 11483 -- A dereference of a controlled object requires special processing. The 11484 -- finalization machinery requests additional space from the underlying 11485 -- pool to allocate and hide two pointers. As a result, a checked pool 11486 -- may mark the wrong memory as valid. Since checked pools do not have 11487 -- knowledge of hidden pointers, we have to bring the two pointers back 11488 -- in view in order to restore the original state of the object. 11489 11490 if Needs_Finalization (Desig) then 11491 11492 -- Adjust the address and size of the dereferenced object. Generate: 11493 -- Adjust_Controlled_Dereference (Addr, Size, Alig); 11494 11495 Stmt := 11496 Make_Procedure_Call_Statement (Loc, 11497 Name => 11498 New_Reference_To (RTE (RE_Adjust_Controlled_Dereference), Loc), 11499 Parameter_Associations => New_List ( 11500 New_Reference_To (Addr, Loc), 11501 New_Reference_To (Size, Loc), 11502 New_Reference_To (Alig, Loc))); 11503 11504 -- Class-wide types complicate things because we cannot determine 11505 -- statically whether the actual object is truly controlled. We must 11506 -- generate a runtime check to detect this property. Generate: 11507 -- 11508 -- if Needs_Finalization (<N>.all'Tag) then 11509 -- <Stmt>; 11510 -- end if; 11511 11512 if Is_Class_Wide_Type (Desig) then 11513 Deref := 11514 Make_Explicit_Dereference (Loc, 11515 Prefix => Duplicate_Subexpr_Move_Checks (N)); 11516 Set_Has_Dereference_Action (Deref); 11517 11518 Stmt := 11519 Make_If_Statement (Loc, 11520 Condition => 11521 Make_Function_Call (Loc, 11522 Name => 11523 New_Reference_To (RTE (RE_Needs_Finalization), Loc), 11524 Parameter_Associations => New_List ( 11525 Make_Attribute_Reference (Loc, 11526 Prefix => Deref, 11527 Attribute_Name => Name_Tag))), 11528 Then_Statements => New_List (Stmt)); 11529 end if; 11530 11531 Insert_Action (N, Stmt); 11532 end if; 11533 11534 -- Generate: 11535 -- Dereference (Pool, Addr, Size, Alig); 11536 11537 Insert_Action (N, 11538 Make_Procedure_Call_Statement (Loc, 11539 Name => 11540 New_Reference_To 11541 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), 11542 Parameter_Associations => New_List ( 11543 New_Reference_To (Pool, Loc), 11544 New_Reference_To (Addr, Loc), 11545 New_Reference_To (Size, Loc), 11546 New_Reference_To (Alig, Loc)))); 11547 11548 -- Mark the explicit dereference as processed to avoid potential 11549 -- infinite expansion. 11550 11551 Set_Has_Dereference_Action (Pnod); 11552 11553 exception 11554 when RE_Not_Available => 11555 return; 11556 end Insert_Dereference_Action; 11557 11558 -------------------------------- 11559 -- Integer_Promotion_Possible -- 11560 -------------------------------- 11561 11562 function Integer_Promotion_Possible (N : Node_Id) return Boolean is 11563 Operand : constant Node_Id := Expression (N); 11564 Operand_Type : constant Entity_Id := Etype (Operand); 11565 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); 11566 11567 begin 11568 pragma Assert (Nkind (N) = N_Type_Conversion); 11569 11570 return 11571 11572 -- We only do the transformation for source constructs. We assume 11573 -- that the expander knows what it is doing when it generates code. 11574 11575 Comes_From_Source (N) 11576 11577 -- If the operand type is Short_Integer or Short_Short_Integer, 11578 -- then we will promote to Integer, which is available on all 11579 -- targets, and is sufficient to ensure no intermediate overflow. 11580 -- Furthermore it is likely to be as efficient or more efficient 11581 -- than using the smaller type for the computation so we do this 11582 -- unconditionally. 11583 11584 and then 11585 (Root_Operand_Type = Base_Type (Standard_Short_Integer) 11586 or else 11587 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) 11588 11589 -- Test for interesting operation, which includes addition, 11590 -- division, exponentiation, multiplication, subtraction, absolute 11591 -- value and unary negation. Unary "+" is omitted since it is a 11592 -- no-op and thus can't overflow. 11593 11594 and then Nkind_In (Operand, N_Op_Abs, 11595 N_Op_Add, 11596 N_Op_Divide, 11597 N_Op_Expon, 11598 N_Op_Minus, 11599 N_Op_Multiply, 11600 N_Op_Subtract); 11601 end Integer_Promotion_Possible; 11602 11603 ------------------------------ 11604 -- Make_Array_Comparison_Op -- 11605 ------------------------------ 11606 11607 -- This is a hand-coded expansion of the following generic function: 11608 11609 -- generic 11610 -- type elem is (<>); 11611 -- type index is (<>); 11612 -- type a is array (index range <>) of elem; 11613 11614 -- function Gnnn (X : a; Y: a) return boolean is 11615 -- J : index := Y'first; 11616 11617 -- begin 11618 -- if X'length = 0 then 11619 -- return false; 11620 11621 -- elsif Y'length = 0 then 11622 -- return true; 11623 11624 -- else 11625 -- for I in X'range loop 11626 -- if X (I) = Y (J) then 11627 -- if J = Y'last then 11628 -- exit; 11629 -- else 11630 -- J := index'succ (J); 11631 -- end if; 11632 11633 -- else 11634 -- return X (I) > Y (J); 11635 -- end if; 11636 -- end loop; 11637 11638 -- return X'length > Y'length; 11639 -- end if; 11640 -- end Gnnn; 11641 11642 -- Note that since we are essentially doing this expansion by hand, we 11643 -- do not need to generate an actual or formal generic part, just the 11644 -- instantiated function itself. 11645 11646 function Make_Array_Comparison_Op 11647 (Typ : Entity_Id; 11648 Nod : Node_Id) return Node_Id 11649 is 11650 Loc : constant Source_Ptr := Sloc (Nod); 11651 11652 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); 11653 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); 11654 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); 11655 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 11656 11657 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); 11658 11659 Loop_Statement : Node_Id; 11660 Loop_Body : Node_Id; 11661 If_Stat : Node_Id; 11662 Inner_If : Node_Id; 11663 Final_Expr : Node_Id; 11664 Func_Body : Node_Id; 11665 Func_Name : Entity_Id; 11666 Formals : List_Id; 11667 Length1 : Node_Id; 11668 Length2 : Node_Id; 11669 11670 begin 11671 -- if J = Y'last then 11672 -- exit; 11673 -- else 11674 -- J := index'succ (J); 11675 -- end if; 11676 11677 Inner_If := 11678 Make_Implicit_If_Statement (Nod, 11679 Condition => 11680 Make_Op_Eq (Loc, 11681 Left_Opnd => New_Reference_To (J, Loc), 11682 Right_Opnd => 11683 Make_Attribute_Reference (Loc, 11684 Prefix => New_Reference_To (Y, Loc), 11685 Attribute_Name => Name_Last)), 11686 11687 Then_Statements => New_List ( 11688 Make_Exit_Statement (Loc)), 11689 11690 Else_Statements => 11691 New_List ( 11692 Make_Assignment_Statement (Loc, 11693 Name => New_Reference_To (J, Loc), 11694 Expression => 11695 Make_Attribute_Reference (Loc, 11696 Prefix => New_Reference_To (Index, Loc), 11697 Attribute_Name => Name_Succ, 11698 Expressions => New_List (New_Reference_To (J, Loc)))))); 11699 11700 -- if X (I) = Y (J) then 11701 -- if ... end if; 11702 -- else 11703 -- return X (I) > Y (J); 11704 -- end if; 11705 11706 Loop_Body := 11707 Make_Implicit_If_Statement (Nod, 11708 Condition => 11709 Make_Op_Eq (Loc, 11710 Left_Opnd => 11711 Make_Indexed_Component (Loc, 11712 Prefix => New_Reference_To (X, Loc), 11713 Expressions => New_List (New_Reference_To (I, Loc))), 11714 11715 Right_Opnd => 11716 Make_Indexed_Component (Loc, 11717 Prefix => New_Reference_To (Y, Loc), 11718 Expressions => New_List (New_Reference_To (J, Loc)))), 11719 11720 Then_Statements => New_List (Inner_If), 11721 11722 Else_Statements => New_List ( 11723 Make_Simple_Return_Statement (Loc, 11724 Expression => 11725 Make_Op_Gt (Loc, 11726 Left_Opnd => 11727 Make_Indexed_Component (Loc, 11728 Prefix => New_Reference_To (X, Loc), 11729 Expressions => New_List (New_Reference_To (I, Loc))), 11730 11731 Right_Opnd => 11732 Make_Indexed_Component (Loc, 11733 Prefix => New_Reference_To (Y, Loc), 11734 Expressions => New_List ( 11735 New_Reference_To (J, Loc))))))); 11736 11737 -- for I in X'range loop 11738 -- if ... end if; 11739 -- end loop; 11740 11741 Loop_Statement := 11742 Make_Implicit_Loop_Statement (Nod, 11743 Identifier => Empty, 11744 11745 Iteration_Scheme => 11746 Make_Iteration_Scheme (Loc, 11747 Loop_Parameter_Specification => 11748 Make_Loop_Parameter_Specification (Loc, 11749 Defining_Identifier => I, 11750 Discrete_Subtype_Definition => 11751 Make_Attribute_Reference (Loc, 11752 Prefix => New_Reference_To (X, Loc), 11753 Attribute_Name => Name_Range))), 11754 11755 Statements => New_List (Loop_Body)); 11756 11757 -- if X'length = 0 then 11758 -- return false; 11759 -- elsif Y'length = 0 then 11760 -- return true; 11761 -- else 11762 -- for ... loop ... end loop; 11763 -- return X'length > Y'length; 11764 -- end if; 11765 11766 Length1 := 11767 Make_Attribute_Reference (Loc, 11768 Prefix => New_Reference_To (X, Loc), 11769 Attribute_Name => Name_Length); 11770 11771 Length2 := 11772 Make_Attribute_Reference (Loc, 11773 Prefix => New_Reference_To (Y, Loc), 11774 Attribute_Name => Name_Length); 11775 11776 Final_Expr := 11777 Make_Op_Gt (Loc, 11778 Left_Opnd => Length1, 11779 Right_Opnd => Length2); 11780 11781 If_Stat := 11782 Make_Implicit_If_Statement (Nod, 11783 Condition => 11784 Make_Op_Eq (Loc, 11785 Left_Opnd => 11786 Make_Attribute_Reference (Loc, 11787 Prefix => New_Reference_To (X, Loc), 11788 Attribute_Name => Name_Length), 11789 Right_Opnd => 11790 Make_Integer_Literal (Loc, 0)), 11791 11792 Then_Statements => 11793 New_List ( 11794 Make_Simple_Return_Statement (Loc, 11795 Expression => New_Reference_To (Standard_False, Loc))), 11796 11797 Elsif_Parts => New_List ( 11798 Make_Elsif_Part (Loc, 11799 Condition => 11800 Make_Op_Eq (Loc, 11801 Left_Opnd => 11802 Make_Attribute_Reference (Loc, 11803 Prefix => New_Reference_To (Y, Loc), 11804 Attribute_Name => Name_Length), 11805 Right_Opnd => 11806 Make_Integer_Literal (Loc, 0)), 11807 11808 Then_Statements => 11809 New_List ( 11810 Make_Simple_Return_Statement (Loc, 11811 Expression => New_Reference_To (Standard_True, Loc))))), 11812 11813 Else_Statements => New_List ( 11814 Loop_Statement, 11815 Make_Simple_Return_Statement (Loc, 11816 Expression => Final_Expr))); 11817 11818 -- (X : a; Y: a) 11819 11820 Formals := New_List ( 11821 Make_Parameter_Specification (Loc, 11822 Defining_Identifier => X, 11823 Parameter_Type => New_Reference_To (Typ, Loc)), 11824 11825 Make_Parameter_Specification (Loc, 11826 Defining_Identifier => Y, 11827 Parameter_Type => New_Reference_To (Typ, Loc))); 11828 11829 -- function Gnnn (...) return boolean is 11830 -- J : index := Y'first; 11831 -- begin 11832 -- if ... end if; 11833 -- end Gnnn; 11834 11835 Func_Name := Make_Temporary (Loc, 'G'); 11836 11837 Func_Body := 11838 Make_Subprogram_Body (Loc, 11839 Specification => 11840 Make_Function_Specification (Loc, 11841 Defining_Unit_Name => Func_Name, 11842 Parameter_Specifications => Formals, 11843 Result_Definition => New_Reference_To (Standard_Boolean, Loc)), 11844 11845 Declarations => New_List ( 11846 Make_Object_Declaration (Loc, 11847 Defining_Identifier => J, 11848 Object_Definition => New_Reference_To (Index, Loc), 11849 Expression => 11850 Make_Attribute_Reference (Loc, 11851 Prefix => New_Reference_To (Y, Loc), 11852 Attribute_Name => Name_First))), 11853 11854 Handled_Statement_Sequence => 11855 Make_Handled_Sequence_Of_Statements (Loc, 11856 Statements => New_List (If_Stat))); 11857 11858 return Func_Body; 11859 end Make_Array_Comparison_Op; 11860 11861 --------------------------- 11862 -- Make_Boolean_Array_Op -- 11863 --------------------------- 11864 11865 -- For logical operations on boolean arrays, expand in line the following, 11866 -- replacing 'and' with 'or' or 'xor' where needed: 11867 11868 -- function Annn (A : typ; B: typ) return typ is 11869 -- C : typ; 11870 -- begin 11871 -- for J in A'range loop 11872 -- C (J) := A (J) op B (J); 11873 -- end loop; 11874 -- return C; 11875 -- end Annn; 11876 11877 -- Here typ is the boolean array type 11878 11879 function Make_Boolean_Array_Op 11880 (Typ : Entity_Id; 11881 N : Node_Id) return Node_Id 11882 is 11883 Loc : constant Source_Ptr := Sloc (N); 11884 11885 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 11886 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 11887 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); 11888 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 11889 11890 A_J : Node_Id; 11891 B_J : Node_Id; 11892 C_J : Node_Id; 11893 Op : Node_Id; 11894 11895 Formals : List_Id; 11896 Func_Name : Entity_Id; 11897 Func_Body : Node_Id; 11898 Loop_Statement : Node_Id; 11899 11900 begin 11901 A_J := 11902 Make_Indexed_Component (Loc, 11903 Prefix => New_Reference_To (A, Loc), 11904 Expressions => New_List (New_Reference_To (J, Loc))); 11905 11906 B_J := 11907 Make_Indexed_Component (Loc, 11908 Prefix => New_Reference_To (B, Loc), 11909 Expressions => New_List (New_Reference_To (J, Loc))); 11910 11911 C_J := 11912 Make_Indexed_Component (Loc, 11913 Prefix => New_Reference_To (C, Loc), 11914 Expressions => New_List (New_Reference_To (J, Loc))); 11915 11916 if Nkind (N) = N_Op_And then 11917 Op := 11918 Make_Op_And (Loc, 11919 Left_Opnd => A_J, 11920 Right_Opnd => B_J); 11921 11922 elsif Nkind (N) = N_Op_Or then 11923 Op := 11924 Make_Op_Or (Loc, 11925 Left_Opnd => A_J, 11926 Right_Opnd => B_J); 11927 11928 else 11929 Op := 11930 Make_Op_Xor (Loc, 11931 Left_Opnd => A_J, 11932 Right_Opnd => B_J); 11933 end if; 11934 11935 Loop_Statement := 11936 Make_Implicit_Loop_Statement (N, 11937 Identifier => Empty, 11938 11939 Iteration_Scheme => 11940 Make_Iteration_Scheme (Loc, 11941 Loop_Parameter_Specification => 11942 Make_Loop_Parameter_Specification (Loc, 11943 Defining_Identifier => J, 11944 Discrete_Subtype_Definition => 11945 Make_Attribute_Reference (Loc, 11946 Prefix => New_Reference_To (A, Loc), 11947 Attribute_Name => Name_Range))), 11948 11949 Statements => New_List ( 11950 Make_Assignment_Statement (Loc, 11951 Name => C_J, 11952 Expression => Op))); 11953 11954 Formals := New_List ( 11955 Make_Parameter_Specification (Loc, 11956 Defining_Identifier => A, 11957 Parameter_Type => New_Reference_To (Typ, Loc)), 11958 11959 Make_Parameter_Specification (Loc, 11960 Defining_Identifier => B, 11961 Parameter_Type => New_Reference_To (Typ, Loc))); 11962 11963 Func_Name := Make_Temporary (Loc, 'A'); 11964 Set_Is_Inlined (Func_Name); 11965 11966 Func_Body := 11967 Make_Subprogram_Body (Loc, 11968 Specification => 11969 Make_Function_Specification (Loc, 11970 Defining_Unit_Name => Func_Name, 11971 Parameter_Specifications => Formals, 11972 Result_Definition => New_Reference_To (Typ, Loc)), 11973 11974 Declarations => New_List ( 11975 Make_Object_Declaration (Loc, 11976 Defining_Identifier => C, 11977 Object_Definition => New_Reference_To (Typ, Loc))), 11978 11979 Handled_Statement_Sequence => 11980 Make_Handled_Sequence_Of_Statements (Loc, 11981 Statements => New_List ( 11982 Loop_Statement, 11983 Make_Simple_Return_Statement (Loc, 11984 Expression => New_Reference_To (C, Loc))))); 11985 11986 return Func_Body; 11987 end Make_Boolean_Array_Op; 11988 11989 ----------------------------------------- 11990 -- Minimized_Eliminated_Overflow_Check -- 11991 ----------------------------------------- 11992 11993 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is 11994 begin 11995 return 11996 Is_Signed_Integer_Type (Etype (N)) 11997 and then Overflow_Check_Mode in Minimized_Or_Eliminated; 11998 end Minimized_Eliminated_Overflow_Check; 11999 12000 -------------------------------- 12001 -- Optimize_Length_Comparison -- 12002 -------------------------------- 12003 12004 procedure Optimize_Length_Comparison (N : Node_Id) is 12005 Loc : constant Source_Ptr := Sloc (N); 12006 Typ : constant Entity_Id := Etype (N); 12007 Result : Node_Id; 12008 12009 Left : Node_Id; 12010 Right : Node_Id; 12011 -- First and Last attribute reference nodes, which end up as left and 12012 -- right operands of the optimized result. 12013 12014 Is_Zero : Boolean; 12015 -- True for comparison operand of zero 12016 12017 Comp : Node_Id; 12018 -- Comparison operand, set only if Is_Zero is false 12019 12020 Ent : Entity_Id; 12021 -- Entity whose length is being compared 12022 12023 Index : Node_Id; 12024 -- Integer_Literal node for length attribute expression, or Empty 12025 -- if there is no such expression present. 12026 12027 Ityp : Entity_Id; 12028 -- Type of array index to which 'Length is applied 12029 12030 Op : Node_Kind := Nkind (N); 12031 -- Kind of comparison operator, gets flipped if operands backwards 12032 12033 function Is_Optimizable (N : Node_Id) return Boolean; 12034 -- Tests N to see if it is an optimizable comparison value (defined as 12035 -- constant zero or one, or something else where the value is known to 12036 -- be positive and in the range of 32-bits, and where the corresponding 12037 -- Length value is also known to be 32-bits. If result is true, sets 12038 -- Is_Zero, Ityp, and Comp accordingly. 12039 12040 function Is_Entity_Length (N : Node_Id) return Boolean; 12041 -- Tests if N is a length attribute applied to a simple entity. If so, 12042 -- returns True, and sets Ent to the entity, and Index to the integer 12043 -- literal provided as an attribute expression, or to Empty if none. 12044 -- Also returns True if the expression is a generated type conversion 12045 -- whose expression is of the desired form. This latter case arises 12046 -- when Apply_Universal_Integer_Attribute_Check installs a conversion 12047 -- to check for being in range, which is not needed in this context. 12048 -- Returns False if neither condition holds. 12049 12050 function Prepare_64 (N : Node_Id) return Node_Id; 12051 -- Given a discrete expression, returns a Long_Long_Integer typed 12052 -- expression representing the underlying value of the expression. 12053 -- This is done with an unchecked conversion to the result type. We 12054 -- use unchecked conversion to handle the enumeration type case. 12055 12056 ---------------------- 12057 -- Is_Entity_Length -- 12058 ---------------------- 12059 12060 function Is_Entity_Length (N : Node_Id) return Boolean is 12061 begin 12062 if Nkind (N) = N_Attribute_Reference 12063 and then Attribute_Name (N) = Name_Length 12064 and then Is_Entity_Name (Prefix (N)) 12065 then 12066 Ent := Entity (Prefix (N)); 12067 12068 if Present (Expressions (N)) then 12069 Index := First (Expressions (N)); 12070 else 12071 Index := Empty; 12072 end if; 12073 12074 return True; 12075 12076 elsif Nkind (N) = N_Type_Conversion 12077 and then not Comes_From_Source (N) 12078 then 12079 return Is_Entity_Length (Expression (N)); 12080 12081 else 12082 return False; 12083 end if; 12084 end Is_Entity_Length; 12085 12086 -------------------- 12087 -- Is_Optimizable -- 12088 -------------------- 12089 12090 function Is_Optimizable (N : Node_Id) return Boolean is 12091 Val : Uint; 12092 OK : Boolean; 12093 Lo : Uint; 12094 Hi : Uint; 12095 Indx : Node_Id; 12096 12097 begin 12098 if Compile_Time_Known_Value (N) then 12099 Val := Expr_Value (N); 12100 12101 if Val = Uint_0 then 12102 Is_Zero := True; 12103 Comp := Empty; 12104 return True; 12105 12106 elsif Val = Uint_1 then 12107 Is_Zero := False; 12108 Comp := Empty; 12109 return True; 12110 end if; 12111 end if; 12112 12113 -- Here we have to make sure of being within 32-bits 12114 12115 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); 12116 12117 if not OK 12118 or else Lo < Uint_1 12119 or else Hi > UI_From_Int (Int'Last) 12120 then 12121 return False; 12122 end if; 12123 12124 -- Comparison value was within range, so now we must check the index 12125 -- value to make sure it is also within 32-bits. 12126 12127 Indx := First_Index (Etype (Ent)); 12128 12129 if Present (Index) then 12130 for J in 2 .. UI_To_Int (Intval (Index)) loop 12131 Next_Index (Indx); 12132 end loop; 12133 end if; 12134 12135 Ityp := Etype (Indx); 12136 12137 if Esize (Ityp) > 32 then 12138 return False; 12139 end if; 12140 12141 Is_Zero := False; 12142 Comp := N; 12143 return True; 12144 end Is_Optimizable; 12145 12146 ---------------- 12147 -- Prepare_64 -- 12148 ---------------- 12149 12150 function Prepare_64 (N : Node_Id) return Node_Id is 12151 begin 12152 return Unchecked_Convert_To (Standard_Long_Long_Integer, N); 12153 end Prepare_64; 12154 12155 -- Start of processing for Optimize_Length_Comparison 12156 12157 begin 12158 -- Nothing to do if not a comparison 12159 12160 if Op not in N_Op_Compare then 12161 return; 12162 end if; 12163 12164 -- Nothing to do if special -gnatd.P debug flag set 12165 12166 if Debug_Flag_Dot_PP then 12167 return; 12168 end if; 12169 12170 -- Ent'Length op 0/1 12171 12172 if Is_Entity_Length (Left_Opnd (N)) 12173 and then Is_Optimizable (Right_Opnd (N)) 12174 then 12175 null; 12176 12177 -- 0/1 op Ent'Length 12178 12179 elsif Is_Entity_Length (Right_Opnd (N)) 12180 and then Is_Optimizable (Left_Opnd (N)) 12181 then 12182 -- Flip comparison to opposite sense 12183 12184 case Op is 12185 when N_Op_Lt => Op := N_Op_Gt; 12186 when N_Op_Le => Op := N_Op_Ge; 12187 when N_Op_Gt => Op := N_Op_Lt; 12188 when N_Op_Ge => Op := N_Op_Le; 12189 when others => null; 12190 end case; 12191 12192 -- Else optimization not possible 12193 12194 else 12195 return; 12196 end if; 12197 12198 -- Fall through if we will do the optimization 12199 12200 -- Cases to handle: 12201 12202 -- X'Length = 0 => X'First > X'Last 12203 -- X'Length = 1 => X'First = X'Last 12204 -- X'Length = n => X'First + (n - 1) = X'Last 12205 12206 -- X'Length /= 0 => X'First <= X'Last 12207 -- X'Length /= 1 => X'First /= X'Last 12208 -- X'Length /= n => X'First + (n - 1) /= X'Last 12209 12210 -- X'Length >= 0 => always true, warn 12211 -- X'Length >= 1 => X'First <= X'Last 12212 -- X'Length >= n => X'First + (n - 1) <= X'Last 12213 12214 -- X'Length > 0 => X'First <= X'Last 12215 -- X'Length > 1 => X'First < X'Last 12216 -- X'Length > n => X'First + (n - 1) < X'Last 12217 12218 -- X'Length <= 0 => X'First > X'Last (warn, could be =) 12219 -- X'Length <= 1 => X'First >= X'Last 12220 -- X'Length <= n => X'First + (n - 1) >= X'Last 12221 12222 -- X'Length < 0 => always false (warn) 12223 -- X'Length < 1 => X'First > X'Last 12224 -- X'Length < n => X'First + (n - 1) > X'Last 12225 12226 -- Note: for the cases of n (not constant 0,1), we require that the 12227 -- corresponding index type be integer or shorter (i.e. not 64-bit), 12228 -- and the same for the comparison value. Then we do the comparison 12229 -- using 64-bit arithmetic (actually long long integer), so that we 12230 -- cannot have overflow intefering with the result. 12231 12232 -- First deal with warning cases 12233 12234 if Is_Zero then 12235 case Op is 12236 12237 -- X'Length >= 0 12238 12239 when N_Op_Ge => 12240 Rewrite (N, 12241 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc))); 12242 Analyze_And_Resolve (N, Typ); 12243 Warn_On_Known_Condition (N); 12244 return; 12245 12246 -- X'Length < 0 12247 12248 when N_Op_Lt => 12249 Rewrite (N, 12250 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc))); 12251 Analyze_And_Resolve (N, Typ); 12252 Warn_On_Known_Condition (N); 12253 return; 12254 12255 when N_Op_Le => 12256 if Constant_Condition_Warnings 12257 and then Comes_From_Source (Original_Node (N)) 12258 then 12259 Error_Msg_N ("could replace by ""'=""?c?", N); 12260 end if; 12261 12262 Op := N_Op_Eq; 12263 12264 when others => 12265 null; 12266 end case; 12267 end if; 12268 12269 -- Build the First reference we will use 12270 12271 Left := 12272 Make_Attribute_Reference (Loc, 12273 Prefix => New_Occurrence_Of (Ent, Loc), 12274 Attribute_Name => Name_First); 12275 12276 if Present (Index) then 12277 Set_Expressions (Left, New_List (New_Copy (Index))); 12278 end if; 12279 12280 -- If general value case, then do the addition of (n - 1), and 12281 -- also add the needed conversions to type Long_Long_Integer. 12282 12283 if Present (Comp) then 12284 Left := 12285 Make_Op_Add (Loc, 12286 Left_Opnd => Prepare_64 (Left), 12287 Right_Opnd => 12288 Make_Op_Subtract (Loc, 12289 Left_Opnd => Prepare_64 (Comp), 12290 Right_Opnd => Make_Integer_Literal (Loc, 1))); 12291 end if; 12292 12293 -- Build the Last reference we will use 12294 12295 Right := 12296 Make_Attribute_Reference (Loc, 12297 Prefix => New_Occurrence_Of (Ent, Loc), 12298 Attribute_Name => Name_Last); 12299 12300 if Present (Index) then 12301 Set_Expressions (Right, New_List (New_Copy (Index))); 12302 end if; 12303 12304 -- If general operand, convert Last reference to Long_Long_Integer 12305 12306 if Present (Comp) then 12307 Right := Prepare_64 (Right); 12308 end if; 12309 12310 -- Check for cases to optimize 12311 12312 -- X'Length = 0 => X'First > X'Last 12313 -- X'Length < 1 => X'First > X'Last 12314 -- X'Length < n => X'First + (n - 1) > X'Last 12315 12316 if (Is_Zero and then Op = N_Op_Eq) 12317 or else (not Is_Zero and then Op = N_Op_Lt) 12318 then 12319 Result := 12320 Make_Op_Gt (Loc, 12321 Left_Opnd => Left, 12322 Right_Opnd => Right); 12323 12324 -- X'Length = 1 => X'First = X'Last 12325 -- X'Length = n => X'First + (n - 1) = X'Last 12326 12327 elsif not Is_Zero and then Op = N_Op_Eq then 12328 Result := 12329 Make_Op_Eq (Loc, 12330 Left_Opnd => Left, 12331 Right_Opnd => Right); 12332 12333 -- X'Length /= 0 => X'First <= X'Last 12334 -- X'Length > 0 => X'First <= X'Last 12335 12336 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then 12337 Result := 12338 Make_Op_Le (Loc, 12339 Left_Opnd => Left, 12340 Right_Opnd => Right); 12341 12342 -- X'Length /= 1 => X'First /= X'Last 12343 -- X'Length /= n => X'First + (n - 1) /= X'Last 12344 12345 elsif not Is_Zero and then Op = N_Op_Ne then 12346 Result := 12347 Make_Op_Ne (Loc, 12348 Left_Opnd => Left, 12349 Right_Opnd => Right); 12350 12351 -- X'Length >= 1 => X'First <= X'Last 12352 -- X'Length >= n => X'First + (n - 1) <= X'Last 12353 12354 elsif not Is_Zero and then Op = N_Op_Ge then 12355 Result := 12356 Make_Op_Le (Loc, 12357 Left_Opnd => Left, 12358 Right_Opnd => Right); 12359 12360 -- X'Length > 1 => X'First < X'Last 12361 -- X'Length > n => X'First + (n = 1) < X'Last 12362 12363 elsif not Is_Zero and then Op = N_Op_Gt then 12364 Result := 12365 Make_Op_Lt (Loc, 12366 Left_Opnd => Left, 12367 Right_Opnd => Right); 12368 12369 -- X'Length <= 1 => X'First >= X'Last 12370 -- X'Length <= n => X'First + (n - 1) >= X'Last 12371 12372 elsif not Is_Zero and then Op = N_Op_Le then 12373 Result := 12374 Make_Op_Ge (Loc, 12375 Left_Opnd => Left, 12376 Right_Opnd => Right); 12377 12378 -- Should not happen at this stage 12379 12380 else 12381 raise Program_Error; 12382 end if; 12383 12384 -- Rewrite and finish up 12385 12386 Rewrite (N, Result); 12387 Analyze_And_Resolve (N, Typ); 12388 return; 12389 end Optimize_Length_Comparison; 12390 12391 ------------------------ 12392 -- Rewrite_Comparison -- 12393 ------------------------ 12394 12395 procedure Rewrite_Comparison (N : Node_Id) is 12396 Warning_Generated : Boolean := False; 12397 -- Set to True if first pass with Assume_Valid generates a warning in 12398 -- which case we skip the second pass to avoid warning overloaded. 12399 12400 Result : Node_Id; 12401 -- Set to Standard_True or Standard_False 12402 12403 begin 12404 if Nkind (N) = N_Type_Conversion then 12405 Rewrite_Comparison (Expression (N)); 12406 return; 12407 12408 elsif Nkind (N) not in N_Op_Compare then 12409 return; 12410 end if; 12411 12412 -- Now start looking at the comparison in detail. We potentially go 12413 -- through this loop twice. The first time, Assume_Valid is set False 12414 -- in the call to Compile_Time_Compare. If this call results in a 12415 -- clear result of always True or Always False, that's decisive and 12416 -- we are done. Otherwise we repeat the processing with Assume_Valid 12417 -- set to True to generate additional warnings. We can skip that step 12418 -- if Constant_Condition_Warnings is False. 12419 12420 for AV in False .. True loop 12421 declare 12422 Typ : constant Entity_Id := Etype (N); 12423 Op1 : constant Node_Id := Left_Opnd (N); 12424 Op2 : constant Node_Id := Right_Opnd (N); 12425 12426 Res : constant Compare_Result := 12427 Compile_Time_Compare (Op1, Op2, Assume_Valid => AV); 12428 -- Res indicates if compare outcome can be compile time determined 12429 12430 True_Result : Boolean; 12431 False_Result : Boolean; 12432 12433 begin 12434 case N_Op_Compare (Nkind (N)) is 12435 when N_Op_Eq => 12436 True_Result := Res = EQ; 12437 False_Result := Res = LT or else Res = GT or else Res = NE; 12438 12439 when N_Op_Ge => 12440 True_Result := Res in Compare_GE; 12441 False_Result := Res = LT; 12442 12443 if Res = LE 12444 and then Constant_Condition_Warnings 12445 and then Comes_From_Source (Original_Node (N)) 12446 and then Nkind (Original_Node (N)) = N_Op_Ge 12447 and then not In_Instance 12448 and then Is_Integer_Type (Etype (Left_Opnd (N))) 12449 and then not Has_Warnings_Off (Etype (Left_Opnd (N))) 12450 then 12451 Error_Msg_N 12452 ("can never be greater than, could replace by ""'=""?c?", 12453 N); 12454 Warning_Generated := True; 12455 end if; 12456 12457 when N_Op_Gt => 12458 True_Result := Res = GT; 12459 False_Result := Res in Compare_LE; 12460 12461 when N_Op_Lt => 12462 True_Result := Res = LT; 12463 False_Result := Res in Compare_GE; 12464 12465 when N_Op_Le => 12466 True_Result := Res in Compare_LE; 12467 False_Result := Res = GT; 12468 12469 if Res = GE 12470 and then Constant_Condition_Warnings 12471 and then Comes_From_Source (Original_Node (N)) 12472 and then Nkind (Original_Node (N)) = N_Op_Le 12473 and then not In_Instance 12474 and then Is_Integer_Type (Etype (Left_Opnd (N))) 12475 and then not Has_Warnings_Off (Etype (Left_Opnd (N))) 12476 then 12477 Error_Msg_N 12478 ("can never be less than, could replace by ""'=""?c?", N); 12479 Warning_Generated := True; 12480 end if; 12481 12482 when N_Op_Ne => 12483 True_Result := Res = NE or else Res = GT or else Res = LT; 12484 False_Result := Res = EQ; 12485 end case; 12486 12487 -- If this is the first iteration, then we actually convert the 12488 -- comparison into True or False, if the result is certain. 12489 12490 if AV = False then 12491 if True_Result or False_Result then 12492 Result := Boolean_Literals (True_Result); 12493 Rewrite (N, 12494 Convert_To (Typ, 12495 New_Occurrence_Of (Result, Sloc (N)))); 12496 Analyze_And_Resolve (N, Typ); 12497 Warn_On_Known_Condition (N); 12498 return; 12499 end if; 12500 12501 -- If this is the second iteration (AV = True), and the original 12502 -- node comes from source and we are not in an instance, then give 12503 -- a warning if we know result would be True or False. Note: we 12504 -- know Constant_Condition_Warnings is set if we get here. 12505 12506 elsif Comes_From_Source (Original_Node (N)) 12507 and then not In_Instance 12508 then 12509 if True_Result then 12510 Error_Msg_N 12511 ("condition can only be False if invalid values present??", 12512 N); 12513 elsif False_Result then 12514 Error_Msg_N 12515 ("condition can only be True if invalid values present??", 12516 N); 12517 end if; 12518 end if; 12519 end; 12520 12521 -- Skip second iteration if not warning on constant conditions or 12522 -- if the first iteration already generated a warning of some kind or 12523 -- if we are in any case assuming all values are valid (so that the 12524 -- first iteration took care of the valid case). 12525 12526 exit when not Constant_Condition_Warnings; 12527 exit when Warning_Generated; 12528 exit when Assume_No_Invalid_Values; 12529 end loop; 12530 end Rewrite_Comparison; 12531 12532 ---------------------------- 12533 -- Safe_In_Place_Array_Op -- 12534 ---------------------------- 12535 12536 function Safe_In_Place_Array_Op 12537 (Lhs : Node_Id; 12538 Op1 : Node_Id; 12539 Op2 : Node_Id) return Boolean 12540 is 12541 Target : Entity_Id; 12542 12543 function Is_Safe_Operand (Op : Node_Id) return Boolean; 12544 -- Operand is safe if it cannot overlap part of the target of the 12545 -- operation. If the operand and the target are identical, the operand 12546 -- is safe. The operand can be empty in the case of negation. 12547 12548 function Is_Unaliased (N : Node_Id) return Boolean; 12549 -- Check that N is a stand-alone entity 12550 12551 ------------------ 12552 -- Is_Unaliased -- 12553 ------------------ 12554 12555 function Is_Unaliased (N : Node_Id) return Boolean is 12556 begin 12557 return 12558 Is_Entity_Name (N) 12559 and then No (Address_Clause (Entity (N))) 12560 and then No (Renamed_Object (Entity (N))); 12561 end Is_Unaliased; 12562 12563 --------------------- 12564 -- Is_Safe_Operand -- 12565 --------------------- 12566 12567 function Is_Safe_Operand (Op : Node_Id) return Boolean is 12568 begin 12569 if No (Op) then 12570 return True; 12571 12572 elsif Is_Entity_Name (Op) then 12573 return Is_Unaliased (Op); 12574 12575 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then 12576 return Is_Unaliased (Prefix (Op)); 12577 12578 elsif Nkind (Op) = N_Slice then 12579 return 12580 Is_Unaliased (Prefix (Op)) 12581 and then Entity (Prefix (Op)) /= Target; 12582 12583 elsif Nkind (Op) = N_Op_Not then 12584 return Is_Safe_Operand (Right_Opnd (Op)); 12585 12586 else 12587 return False; 12588 end if; 12589 end Is_Safe_Operand; 12590 12591 -- Start of processing for Safe_In_Place_Array_Op 12592 12593 begin 12594 -- Skip this processing if the component size is different from system 12595 -- storage unit (since at least for NOT this would cause problems). 12596 12597 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then 12598 return False; 12599 12600 -- Cannot do in place stuff on VM_Target since cannot pass addresses 12601 12602 elsif VM_Target /= No_VM then 12603 return False; 12604 12605 -- Cannot do in place stuff if non-standard Boolean representation 12606 12607 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then 12608 return False; 12609 12610 elsif not Is_Unaliased (Lhs) then 12611 return False; 12612 12613 else 12614 Target := Entity (Lhs); 12615 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); 12616 end if; 12617 end Safe_In_Place_Array_Op; 12618 12619 ----------------------- 12620 -- Tagged_Membership -- 12621 ----------------------- 12622 12623 -- There are two different cases to consider depending on whether the right 12624 -- operand is a class-wide type or not. If not we just compare the actual 12625 -- tag of the left expr to the target type tag: 12626 -- 12627 -- Left_Expr.Tag = Right_Type'Tag; 12628 -- 12629 -- If it is a class-wide type we use the RT function CW_Membership which is 12630 -- usually implemented by looking in the ancestor tables contained in the 12631 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag 12632 12633 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT 12634 -- function IW_Membership which is usually implemented by looking in the 12635 -- table of abstract interface types plus the ancestor table contained in 12636 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag 12637 12638 procedure Tagged_Membership 12639 (N : Node_Id; 12640 SCIL_Node : out Node_Id; 12641 Result : out Node_Id) 12642 is 12643 Left : constant Node_Id := Left_Opnd (N); 12644 Right : constant Node_Id := Right_Opnd (N); 12645 Loc : constant Source_Ptr := Sloc (N); 12646 12647 Full_R_Typ : Entity_Id; 12648 Left_Type : Entity_Id; 12649 New_Node : Node_Id; 12650 Right_Type : Entity_Id; 12651 Obj_Tag : Node_Id; 12652 12653 begin 12654 SCIL_Node := Empty; 12655 12656 -- Handle entities from the limited view 12657 12658 Left_Type := Available_View (Etype (Left)); 12659 Right_Type := Available_View (Etype (Right)); 12660 12661 -- In the case where the type is an access type, the test is applied 12662 -- using the designated types (needed in Ada 2012 for implicit anonymous 12663 -- access conversions, for AI05-0149). 12664 12665 if Is_Access_Type (Right_Type) then 12666 Left_Type := Designated_Type (Left_Type); 12667 Right_Type := Designated_Type (Right_Type); 12668 end if; 12669 12670 if Is_Class_Wide_Type (Left_Type) then 12671 Left_Type := Root_Type (Left_Type); 12672 end if; 12673 12674 if Is_Class_Wide_Type (Right_Type) then 12675 Full_R_Typ := Underlying_Type (Root_Type (Right_Type)); 12676 else 12677 Full_R_Typ := Underlying_Type (Right_Type); 12678 end if; 12679 12680 Obj_Tag := 12681 Make_Selected_Component (Loc, 12682 Prefix => Relocate_Node (Left), 12683 Selector_Name => 12684 New_Reference_To (First_Tag_Component (Left_Type), Loc)); 12685 12686 if Is_Class_Wide_Type (Right_Type) then 12687 12688 -- No need to issue a run-time check if we statically know that the 12689 -- result of this membership test is always true. For example, 12690 -- considering the following declarations: 12691 12692 -- type Iface is interface; 12693 -- type T is tagged null record; 12694 -- type DT is new T and Iface with null record; 12695 12696 -- Obj1 : T; 12697 -- Obj2 : DT; 12698 12699 -- These membership tests are always true: 12700 12701 -- Obj1 in T'Class 12702 -- Obj2 in T'Class; 12703 -- Obj2 in Iface'Class; 12704 12705 -- We do not need to handle cases where the membership is illegal. 12706 -- For example: 12707 12708 -- Obj1 in DT'Class; -- Compile time error 12709 -- Obj1 in Iface'Class; -- Compile time error 12710 12711 if not Is_Class_Wide_Type (Left_Type) 12712 and then (Is_Ancestor (Etype (Right_Type), Left_Type, 12713 Use_Full_View => True) 12714 or else (Is_Interface (Etype (Right_Type)) 12715 and then Interface_Present_In_Ancestor 12716 (Typ => Left_Type, 12717 Iface => Etype (Right_Type)))) 12718 then 12719 Result := New_Reference_To (Standard_True, Loc); 12720 return; 12721 end if; 12722 12723 -- Ada 2005 (AI-251): Class-wide applied to interfaces 12724 12725 if Is_Interface (Etype (Class_Wide_Type (Right_Type))) 12726 12727 -- Support to: "Iface_CW_Typ in Typ'Class" 12728 12729 or else Is_Interface (Left_Type) 12730 then 12731 -- Issue error if IW_Membership operation not available in a 12732 -- configurable run time setting. 12733 12734 if not RTE_Available (RE_IW_Membership) then 12735 Error_Msg_CRT 12736 ("dynamic membership test on interface types", N); 12737 Result := Empty; 12738 return; 12739 end if; 12740 12741 Result := 12742 Make_Function_Call (Loc, 12743 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), 12744 Parameter_Associations => New_List ( 12745 Make_Attribute_Reference (Loc, 12746 Prefix => Obj_Tag, 12747 Attribute_Name => Name_Address), 12748 New_Reference_To ( 12749 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), 12750 Loc))); 12751 12752 -- Ada 95: Normal case 12753 12754 else 12755 Build_CW_Membership (Loc, 12756 Obj_Tag_Node => Obj_Tag, 12757 Typ_Tag_Node => 12758 New_Reference_To ( 12759 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc), 12760 Related_Nod => N, 12761 New_Node => New_Node); 12762 12763 -- Generate the SCIL node for this class-wide membership test. 12764 -- Done here because the previous call to Build_CW_Membership 12765 -- relocates Obj_Tag. 12766 12767 if Generate_SCIL then 12768 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); 12769 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); 12770 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); 12771 end if; 12772 12773 Result := New_Node; 12774 end if; 12775 12776 -- Right_Type is not a class-wide type 12777 12778 else 12779 -- No need to check the tag of the object if Right_Typ is abstract 12780 12781 if Is_Abstract_Type (Right_Type) then 12782 Result := New_Reference_To (Standard_False, Loc); 12783 12784 else 12785 Result := 12786 Make_Op_Eq (Loc, 12787 Left_Opnd => Obj_Tag, 12788 Right_Opnd => 12789 New_Reference_To 12790 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc)); 12791 end if; 12792 end if; 12793 end Tagged_Membership; 12794 12795 ------------------------------ 12796 -- Unary_Op_Validity_Checks -- 12797 ------------------------------ 12798 12799 procedure Unary_Op_Validity_Checks (N : Node_Id) is 12800 begin 12801 if Validity_Checks_On and Validity_Check_Operands then 12802 Ensure_Valid (Right_Opnd (N)); 12803 end if; 12804 end Unary_Op_Validity_Checks; 12805 12806end Exp_Ch4; 12807