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