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