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-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Aggr; use Exp_Aggr; 33with Exp_Atag; use Exp_Atag; 34with Exp_Ch2; use Exp_Ch2; 35with Exp_Ch3; use Exp_Ch3; 36with Exp_Ch6; use Exp_Ch6; 37with Exp_Ch7; use Exp_Ch7; 38with Exp_Ch9; use Exp_Ch9; 39with Exp_Disp; use Exp_Disp; 40with Exp_Fixd; use Exp_Fixd; 41with Exp_Intr; use Exp_Intr; 42with Exp_Pakd; use Exp_Pakd; 43with Exp_Tss; use Exp_Tss; 44with Exp_Util; use Exp_Util; 45with Freeze; use Freeze; 46with Inline; use Inline; 47with Namet; use Namet; 48with Nlists; use Nlists; 49with Nmake; use Nmake; 50with Opt; use Opt; 51with Par_SCO; use Par_SCO; 52with Restrict; use Restrict; 53with Rident; use Rident; 54with Rtsfind; use Rtsfind; 55with Sem; use Sem; 56with Sem_Aux; use Sem_Aux; 57with Sem_Cat; use Sem_Cat; 58with Sem_Ch3; use Sem_Ch3; 59with Sem_Ch13; use Sem_Ch13; 60with Sem_Eval; use Sem_Eval; 61with Sem_Res; use Sem_Res; 62with Sem_Type; use Sem_Type; 63with Sem_Util; use Sem_Util; 64with Sem_Warn; use Sem_Warn; 65with Sinfo; use Sinfo; 66with Snames; use Snames; 67with Stand; use Stand; 68with SCIL_LL; use SCIL_LL; 69with Targparm; use Targparm; 70with Tbuild; use Tbuild; 71with Ttypes; use Ttypes; 72with Uintp; use Uintp; 73with Urealp; use Urealp; 74with Validsw; use Validsw; 75 76package body Exp_Ch4 is 77 78 ----------------------- 79 -- Local Subprograms -- 80 ----------------------- 81 82 procedure Binary_Op_Validity_Checks (N : Node_Id); 83 pragma Inline (Binary_Op_Validity_Checks); 84 -- Performs validity checks for a binary operator 85 86 procedure Build_Boolean_Array_Proc_Call 87 (N : Node_Id; 88 Op1 : Node_Id; 89 Op2 : Node_Id); 90 -- If a boolean array assignment can be done in place, build call to 91 -- corresponding library procedure. 92 93 procedure Displace_Allocator_Pointer (N : Node_Id); 94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and 95 -- Expand_Allocator_Expression. Allocating class-wide interface objects 96 -- this routine displaces the pointer to the allocated object to reference 97 -- the component referencing the corresponding secondary dispatch table. 98 99 procedure Expand_Allocator_Expression (N : Node_Id); 100 -- Subsidiary to Expand_N_Allocator, for the case when the expression 101 -- is a qualified expression or an aggregate. 102 103 procedure Expand_Array_Comparison (N : Node_Id); 104 -- This routine handles expansion of the comparison operators (N_Op_Lt, 105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic 106 -- code for these operators is similar, differing only in the details of 107 -- the actual comparison call that is made. Special processing (call a 108 -- run-time routine) 109 110 function Expand_Array_Equality 111 (Nod : Node_Id; 112 Lhs : Node_Id; 113 Rhs : Node_Id; 114 Bodies : List_Id; 115 Typ : Entity_Id) return Node_Id; 116 -- Expand an array equality into a call to a function implementing this 117 -- equality, and a call to it. Loc is the location for the generated nodes. 118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list 119 -- on which to attach bodies of local functions that are created in the 120 -- process. It is the responsibility of the caller to insert those bodies 121 -- at the right place. Nod provides the Sloc value for the generated code. 122 -- Normally the types used for the generated equality routine are taken 123 -- from Lhs and Rhs. However, in some situations of generated code, the 124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies 125 -- the type to be used for the formal parameters. 126 127 procedure Expand_Boolean_Operator (N : Node_Id); 128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the 129 -- case of array type arguments. 130 131 procedure Expand_Nonbinary_Modular_Op (N : Node_Id); 132 -- When generating C code, convert nonbinary modular arithmetic operations 133 -- into code that relies on the front-end expansion of operator Mod. No 134 -- expansion is performed if N is not a nonbinary modular operand. 135 136 procedure Expand_Short_Circuit_Operator (N : Node_Id); 137 -- Common expansion processing for short-circuit boolean operators 138 139 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id); 140 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is 141 -- where we allow comparison of "out of range" values. 142 143 function Expand_Composite_Equality 144 (Nod : Node_Id; 145 Typ : Entity_Id; 146 Lhs : Node_Id; 147 Rhs : Node_Id; 148 Bodies : List_Id) return Node_Id; 149 -- Local recursive function used to expand equality for nested composite 150 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which 151 -- to attach bodies of local functions that are created in the process. It 152 -- is the responsibility of the caller to insert those bodies at the right 153 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are 154 -- the left and right sides for the comparison, and Typ is the type of the 155 -- objects to compare. 156 157 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); 158 -- Routine to expand concatenation of a sequence of two or more operands 159 -- (in the list Operands) and replace node Cnode with the result of the 160 -- concatenation. The operands can be of any appropriate type, and can 161 -- include both arrays and singleton elements. 162 163 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id); 164 -- N is an N_In membership test mode, with the overflow check mode set to 165 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed 166 -- integer type. This is a case where top level processing is required to 167 -- handle overflow checks in subtrees. 168 169 procedure Fixup_Universal_Fixed_Operation (N : Node_Id); 170 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal 171 -- fixed. We do not have such a type at runtime, so the purpose of this 172 -- routine is to find the real type by looking up the tree. We also 173 -- determine if the operation must be rounded. 174 175 function Has_Inferable_Discriminants (N : Node_Id) return Boolean; 176 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable 177 -- discriminants if it has a constrained nominal type, unless the object 178 -- is a component of an enclosing Unchecked_Union object that is subject 179 -- to a per-object constraint and the enclosing object lacks inferable 180 -- discriminants. 181 -- 182 -- An expression of an Unchecked_Union type has inferable discriminants 183 -- if it is either a name of an object with inferable discriminants or a 184 -- qualified expression whose subtype mark denotes a constrained subtype. 185 186 procedure Insert_Dereference_Action (N : Node_Id); 187 -- N is an expression whose type is an access. When the type of the 188 -- associated storage pool is derived from Checked_Pool, generate a 189 -- call to the 'Dereference' primitive operation. 190 191 function Make_Array_Comparison_Op 192 (Typ : Entity_Id; 193 Nod : Node_Id) return Node_Id; 194 -- Comparisons between arrays are expanded in line. This function produces 195 -- the body of the implementation of (a > b), where a and b are one- 196 -- dimensional arrays of some discrete type. The original node is then 197 -- expanded into the appropriate call to this function. Nod provides the 198 -- Sloc value for the generated code. 199 200 function Make_Boolean_Array_Op 201 (Typ : Entity_Id; 202 N : Node_Id) return Node_Id; 203 -- Boolean operations on boolean arrays are expanded in line. This function 204 -- produce the body for the node N, which is (a and b), (a or b), or (a xor 205 -- b). It is used only the normal case and not the packed case. The type 206 -- involved, Typ, is the Boolean array type, and the logical operations in 207 -- the body are simple boolean operations. Note that Typ is always a 208 -- constrained type (the caller has ensured this by using 209 -- Convert_To_Actual_Subtype if necessary). 210 211 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean; 212 -- For signed arithmetic operations when the current overflow mode is 213 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks 214 -- as the first thing we do. We then return. We count on the recursive 215 -- apparatus for overflow checks to call us back with an equivalent 216 -- operation that is in CHECKED mode, avoiding a recursive entry into this 217 -- routine, and that is when we will proceed with the expansion of the 218 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do 219 -- these optimizations without first making this check, since there may be 220 -- operands further down the tree that are relying on the recursive calls 221 -- triggered by the top level nodes to properly process overflow checking 222 -- and remaining expansion on these nodes. Note that this call back may be 223 -- skipped if the operation is done in Bignum mode but that's fine, since 224 -- the Bignum call takes care of everything. 225 226 procedure Optimize_Length_Comparison (N : Node_Id); 227 -- Given an expression, if it is of the form X'Length op N (or the other 228 -- way round), where N is known at compile time to be 0 or 1, and X is a 229 -- simple entity, and op is a comparison operator, optimizes it into a 230 -- comparison of First and Last. 231 232 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id); 233 -- Inspect and process statement list Stmt of if or case expression N for 234 -- transient objects. If such objects are found, the routine generates code 235 -- to clean them up when the context of the expression is evaluated. 236 237 procedure Process_Transient_In_Expression 238 (Obj_Decl : Node_Id; 239 Expr : Node_Id; 240 Stmts : List_Id); 241 -- Subsidiary routine to the expansion of expression_with_actions, if and 242 -- case expressions. Generate all necessary code to finalize a transient 243 -- object when the enclosing context is elaborated or evaluated. Obj_Decl 244 -- denotes the declaration of the transient object, which is usually the 245 -- result of a controlled function call. Expr denotes the expression with 246 -- actions, if expression, or case expression node. Stmts denotes the 247 -- statement list which contains Decl, either at the top level or within a 248 -- nested construct. 249 250 procedure Rewrite_Comparison (N : Node_Id); 251 -- If N is the node for a comparison whose outcome can be determined at 252 -- compile time, then the node N can be rewritten with True or False. If 253 -- the outcome cannot be determined at compile time, the call has no 254 -- effect. If N is a type conversion, then this processing is applied to 255 -- its expression. If N is neither comparison nor a type conversion, the 256 -- call has no effect. 257 258 procedure Tagged_Membership 259 (N : Node_Id; 260 SCIL_Node : out Node_Id; 261 Result : out Node_Id); 262 -- Construct the expression corresponding to the tagged membership test. 263 -- Deals with a second operand being (or not) a class-wide type. 264 265 function Safe_In_Place_Array_Op 266 (Lhs : Node_Id; 267 Op1 : Node_Id; 268 Op2 : Node_Id) return Boolean; 269 -- In the context of an assignment, where the right-hand side is a boolean 270 -- operation on arrays, check whether operation can be performed in place. 271 272 procedure Unary_Op_Validity_Checks (N : Node_Id); 273 pragma Inline (Unary_Op_Validity_Checks); 274 -- Performs validity checks for a unary operator 275 276 ------------------------------- 277 -- Binary_Op_Validity_Checks -- 278 ------------------------------- 279 280 procedure Binary_Op_Validity_Checks (N : Node_Id) is 281 begin 282 if Validity_Checks_On and Validity_Check_Operands then 283 Ensure_Valid (Left_Opnd (N)); 284 Ensure_Valid (Right_Opnd (N)); 285 end if; 286 end Binary_Op_Validity_Checks; 287 288 ------------------------------------ 289 -- Build_Boolean_Array_Proc_Call -- 290 ------------------------------------ 291 292 procedure Build_Boolean_Array_Proc_Call 293 (N : Node_Id; 294 Op1 : Node_Id; 295 Op2 : Node_Id) 296 is 297 Loc : constant Source_Ptr := Sloc (N); 298 Kind : constant Node_Kind := Nkind (Expression (N)); 299 Target : constant Node_Id := 300 Make_Attribute_Reference (Loc, 301 Prefix => Name (N), 302 Attribute_Name => Name_Address); 303 304 Arg1 : Node_Id := Op1; 305 Arg2 : Node_Id := Op2; 306 Call_Node : Node_Id; 307 Proc_Name : Entity_Id; 308 309 begin 310 if Kind = N_Op_Not then 311 if Nkind (Op1) in N_Binary_Op then 312 313 -- Use negated version of the binary operators 314 315 if Nkind (Op1) = N_Op_And then 316 Proc_Name := RTE (RE_Vector_Nand); 317 318 elsif Nkind (Op1) = N_Op_Or then 319 Proc_Name := RTE (RE_Vector_Nor); 320 321 else pragma Assert (Nkind (Op1) = N_Op_Xor); 322 Proc_Name := RTE (RE_Vector_Xor); 323 end if; 324 325 Call_Node := 326 Make_Procedure_Call_Statement (Loc, 327 Name => New_Occurrence_Of (Proc_Name, Loc), 328 329 Parameter_Associations => New_List ( 330 Target, 331 Make_Attribute_Reference (Loc, 332 Prefix => Left_Opnd (Op1), 333 Attribute_Name => Name_Address), 334 335 Make_Attribute_Reference (Loc, 336 Prefix => Right_Opnd (Op1), 337 Attribute_Name => Name_Address), 338 339 Make_Attribute_Reference (Loc, 340 Prefix => Left_Opnd (Op1), 341 Attribute_Name => Name_Length))); 342 343 else 344 Proc_Name := RTE (RE_Vector_Not); 345 346 Call_Node := 347 Make_Procedure_Call_Statement (Loc, 348 Name => New_Occurrence_Of (Proc_Name, Loc), 349 Parameter_Associations => New_List ( 350 Target, 351 352 Make_Attribute_Reference (Loc, 353 Prefix => Op1, 354 Attribute_Name => Name_Address), 355 356 Make_Attribute_Reference (Loc, 357 Prefix => Op1, 358 Attribute_Name => Name_Length))); 359 end if; 360 361 else 362 -- We use the following equivalences: 363 364 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) 365 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) 366 -- (not X) xor (not Y) = X xor Y 367 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) 368 369 if Nkind (Op1) = N_Op_Not then 370 Arg1 := Right_Opnd (Op1); 371 Arg2 := Right_Opnd (Op2); 372 373 if Kind = N_Op_And then 374 Proc_Name := RTE (RE_Vector_Nor); 375 elsif Kind = N_Op_Or then 376 Proc_Name := RTE (RE_Vector_Nand); 377 else 378 Proc_Name := RTE (RE_Vector_Xor); 379 end if; 380 381 else 382 if Kind = N_Op_And then 383 Proc_Name := RTE (RE_Vector_And); 384 elsif Kind = N_Op_Or then 385 Proc_Name := RTE (RE_Vector_Or); 386 elsif Nkind (Op2) = N_Op_Not then 387 Proc_Name := RTE (RE_Vector_Nxor); 388 Arg2 := Right_Opnd (Op2); 389 else 390 Proc_Name := RTE (RE_Vector_Xor); 391 end if; 392 end if; 393 394 Call_Node := 395 Make_Procedure_Call_Statement (Loc, 396 Name => New_Occurrence_Of (Proc_Name, Loc), 397 Parameter_Associations => New_List ( 398 Target, 399 Make_Attribute_Reference (Loc, 400 Prefix => Arg1, 401 Attribute_Name => Name_Address), 402 Make_Attribute_Reference (Loc, 403 Prefix => Arg2, 404 Attribute_Name => Name_Address), 405 Make_Attribute_Reference (Loc, 406 Prefix => Arg1, 407 Attribute_Name => Name_Length))); 408 end if; 409 410 Rewrite (N, Call_Node); 411 Analyze (N); 412 413 exception 414 when RE_Not_Available => 415 return; 416 end Build_Boolean_Array_Proc_Call; 417 418 -------------------------------- 419 -- Displace_Allocator_Pointer -- 420 -------------------------------- 421 422 procedure Displace_Allocator_Pointer (N : Node_Id) is 423 Loc : constant Source_Ptr := Sloc (N); 424 Orig_Node : constant Node_Id := Original_Node (N); 425 Dtyp : Entity_Id; 426 Etyp : Entity_Id; 427 PtrT : Entity_Id; 428 429 begin 430 -- Do nothing in case of VM targets: the virtual machine will handle 431 -- interfaces directly. 432 433 if not Tagged_Type_Expansion then 434 return; 435 end if; 436 437 pragma Assert (Nkind (N) = N_Identifier 438 and then Nkind (Orig_Node) = N_Allocator); 439 440 PtrT := Etype (Orig_Node); 441 Dtyp := Available_View (Designated_Type (PtrT)); 442 Etyp := Etype (Expression (Orig_Node)); 443 444 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then 445 446 -- If the type of the allocator expression is not an interface type 447 -- we can generate code to reference the record component containing 448 -- the pointer to the secondary dispatch table. 449 450 if not Is_Interface (Etyp) then 451 declare 452 Saved_Typ : constant Entity_Id := Etype (Orig_Node); 453 454 begin 455 -- 1) Get access to the allocated object 456 457 Rewrite (N, 458 Make_Explicit_Dereference (Loc, Relocate_Node (N))); 459 Set_Etype (N, Etyp); 460 Set_Analyzed (N); 461 462 -- 2) Add the conversion to displace the pointer to reference 463 -- the secondary dispatch table. 464 465 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N))); 466 Analyze_And_Resolve (N, Dtyp); 467 468 -- 3) The 'access to the secondary dispatch table will be used 469 -- as the value returned by the allocator. 470 471 Rewrite (N, 472 Make_Attribute_Reference (Loc, 473 Prefix => Relocate_Node (N), 474 Attribute_Name => Name_Access)); 475 Set_Etype (N, Saved_Typ); 476 Set_Analyzed (N); 477 end; 478 479 -- If the type of the allocator expression is an interface type we 480 -- generate a run-time call to displace "this" to reference the 481 -- component containing the pointer to the secondary dispatch table 482 -- or else raise Constraint_Error if the actual object does not 483 -- implement the target interface. This case corresponds to the 484 -- following example: 485 486 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is 487 -- begin 488 -- return new Iface_2'Class'(Obj); 489 -- end Op; 490 491 else 492 Rewrite (N, 493 Unchecked_Convert_To (PtrT, 494 Make_Function_Call (Loc, 495 Name => New_Occurrence_Of (RTE (RE_Displace), Loc), 496 Parameter_Associations => New_List ( 497 Unchecked_Convert_To (RTE (RE_Address), 498 Relocate_Node (N)), 499 500 New_Occurrence_Of 501 (Elists.Node 502 (First_Elmt 503 (Access_Disp_Table (Etype (Base_Type (Dtyp))))), 504 Loc))))); 505 Analyze_And_Resolve (N, PtrT); 506 end if; 507 end if; 508 end Displace_Allocator_Pointer; 509 510 --------------------------------- 511 -- Expand_Allocator_Expression -- 512 --------------------------------- 513 514 procedure Expand_Allocator_Expression (N : Node_Id) is 515 Loc : constant Source_Ptr := Sloc (N); 516 Exp : constant Node_Id := Expression (Expression (N)); 517 PtrT : constant Entity_Id := Etype (N); 518 DesigT : constant Entity_Id := Designated_Type (PtrT); 519 520 procedure Apply_Accessibility_Check 521 (Ref : Node_Id; 522 Built_In_Place : Boolean := False); 523 -- Ada 2005 (AI-344): For an allocator with a class-wide designated 524 -- type, generate an accessibility check to verify that the level of the 525 -- type of the created object is not deeper than the level of the access 526 -- type. If the type of the qualified expression is class-wide, then 527 -- always generate the check (except in the case where it is known to be 528 -- unnecessary, see comment below). Otherwise, only generate the check 529 -- if the level of the qualified expression type is statically deeper 530 -- than the access type. 531 -- 532 -- Although the static accessibility will generally have been performed 533 -- as a legality check, it won't have been done in cases where the 534 -- allocator appears in generic body, so a run-time check is needed in 535 -- general. One special case is when the access type is declared in the 536 -- same scope as the class-wide allocator, in which case the check can 537 -- never fail, so it need not be generated. 538 -- 539 -- As an open issue, there seem to be cases where the static level 540 -- associated with the class-wide object's underlying type is not 541 -- sufficient to perform the proper accessibility check, such as for 542 -- allocators in nested subprograms or accept statements initialized by 543 -- class-wide formals when the actual originates outside at a deeper 544 -- static level. The nested subprogram case might require passing 545 -- accessibility levels along with class-wide parameters, and the task 546 -- case seems to be an actual gap in the language rules that needs to 547 -- be fixed by the ARG. ??? 548 549 ------------------------------- 550 -- Apply_Accessibility_Check -- 551 ------------------------------- 552 553 procedure Apply_Accessibility_Check 554 (Ref : Node_Id; 555 Built_In_Place : Boolean := False) 556 is 557 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); 558 Cond : Node_Id; 559 Fin_Call : Node_Id; 560 Free_Stmt : Node_Id; 561 Obj_Ref : Node_Id; 562 Stmts : List_Id; 563 564 begin 565 if Ada_Version >= Ada_2005 566 and then Is_Class_Wide_Type (DesigT) 567 and then Tagged_Type_Expansion 568 and then not Scope_Suppress.Suppress (Accessibility_Check) 569 and then 570 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) 571 or else 572 (Is_Class_Wide_Type (Etype (Exp)) 573 and then Scope (PtrT) /= Current_Scope)) 574 then 575 -- If the allocator was built in place, Ref is already a reference 576 -- to the access object initialized to the result of the allocator 577 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call 578 -- Remove_Side_Effects for cases where the build-in-place call may 579 -- still be the prefix of the reference (to avoid generating 580 -- duplicate calls). Otherwise, it is the entity associated with 581 -- the object containing the address of the allocated object. 582 583 if Built_In_Place then 584 Remove_Side_Effects (Ref); 585 Obj_Ref := New_Copy_Tree (Ref); 586 else 587 Obj_Ref := New_Occurrence_Of (Ref, Loc); 588 end if; 589 590 -- For access to interface types we must generate code to displace 591 -- the pointer to the base of the object since the subsequent code 592 -- references components located in the TSD of the object (which 593 -- is associated with the primary dispatch table --see a-tags.ads) 594 -- and also generates code invoking Free, which requires also a 595 -- reference to the base of the unallocated object. 596 597 if Is_Interface (DesigT) and then Tagged_Type_Expansion then 598 Obj_Ref := 599 Unchecked_Convert_To (Etype (Obj_Ref), 600 Make_Function_Call (Loc, 601 Name => 602 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 603 Parameter_Associations => New_List ( 604 Unchecked_Convert_To (RTE (RE_Address), 605 New_Copy_Tree (Obj_Ref))))); 606 end if; 607 608 -- Step 1: Create the object clean up code 609 610 Stmts := New_List; 611 612 -- Deallocate the object if the accessibility check fails. This 613 -- is done only on targets or profiles that support deallocation. 614 615 -- Free (Obj_Ref); 616 617 if RTE_Available (RE_Free) then 618 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref)); 619 Set_Storage_Pool (Free_Stmt, Pool_Id); 620 621 Append_To (Stmts, Free_Stmt); 622 623 -- The target or profile cannot deallocate objects 624 625 else 626 Free_Stmt := Empty; 627 end if; 628 629 -- Finalize the object if applicable. Generate: 630 631 -- [Deep_]Finalize (Obj_Ref.all); 632 633 if Needs_Finalization (DesigT) 634 and then not No_Heap_Finalization (PtrT) 635 then 636 Fin_Call := 637 Make_Final_Call 638 (Obj_Ref => 639 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), 640 Typ => DesigT); 641 642 -- Guard against a missing [Deep_]Finalize when the designated 643 -- type was not properly frozen. 644 645 if No (Fin_Call) then 646 Fin_Call := Make_Null_Statement (Loc); 647 end if; 648 649 -- When the target or profile supports deallocation, wrap the 650 -- finalization call in a block to ensure proper deallocation 651 -- even if finalization fails. Generate: 652 653 -- begin 654 -- <Fin_Call> 655 -- exception 656 -- when others => 657 -- <Free_Stmt> 658 -- raise; 659 -- end; 660 661 if Present (Free_Stmt) then 662 Fin_Call := 663 Make_Block_Statement (Loc, 664 Handled_Statement_Sequence => 665 Make_Handled_Sequence_Of_Statements (Loc, 666 Statements => New_List (Fin_Call), 667 668 Exception_Handlers => New_List ( 669 Make_Exception_Handler (Loc, 670 Exception_Choices => New_List ( 671 Make_Others_Choice (Loc)), 672 Statements => New_List ( 673 New_Copy_Tree (Free_Stmt), 674 Make_Raise_Statement (Loc)))))); 675 end if; 676 677 Prepend_To (Stmts, Fin_Call); 678 end if; 679 680 -- Signal the accessibility failure through a Program_Error 681 682 Append_To (Stmts, 683 Make_Raise_Program_Error (Loc, 684 Condition => New_Occurrence_Of (Standard_True, Loc), 685 Reason => PE_Accessibility_Check_Failed)); 686 687 -- Step 2: Create the accessibility comparison 688 689 -- Generate: 690 -- Ref'Tag 691 692 Obj_Ref := 693 Make_Attribute_Reference (Loc, 694 Prefix => Obj_Ref, 695 Attribute_Name => Name_Tag); 696 697 -- For tagged types, determine the accessibility level by looking 698 -- at the type specific data of the dispatch table. Generate: 699 700 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level 701 702 if Tagged_Type_Expansion then 703 Cond := Build_Get_Access_Level (Loc, Obj_Ref); 704 705 -- Use a runtime call to determine the accessibility level when 706 -- compiling on virtual machine targets. Generate: 707 708 -- Get_Access_Level (Ref'Tag) 709 710 else 711 Cond := 712 Make_Function_Call (Loc, 713 Name => 714 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc), 715 Parameter_Associations => New_List (Obj_Ref)); 716 end if; 717 718 Cond := 719 Make_Op_Gt (Loc, 720 Left_Opnd => Cond, 721 Right_Opnd => 722 Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); 723 724 -- Due to the complexity and side effects of the check, utilize an 725 -- if statement instead of the regular Program_Error circuitry. 726 727 Insert_Action (N, 728 Make_Implicit_If_Statement (N, 729 Condition => Cond, 730 Then_Statements => Stmts)); 731 end if; 732 end Apply_Accessibility_Check; 733 734 -- Local variables 735 736 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); 737 Indic : constant Node_Id := Subtype_Mark (Expression (N)); 738 T : constant Entity_Id := Entity (Indic); 739 Adj_Call : Node_Id; 740 Node : Node_Id; 741 Tag_Assign : Node_Id; 742 Temp : Entity_Id; 743 Temp_Decl : Node_Id; 744 745 TagT : Entity_Id := Empty; 746 -- Type used as source for tag assignment 747 748 TagR : Node_Id := Empty; 749 -- Target reference for tag assignment 750 751 -- Start of processing for Expand_Allocator_Expression 752 753 begin 754 -- Handle call to C++ constructor 755 756 if Is_CPP_Constructor_Call (Exp) then 757 Make_CPP_Constructor_Call_In_Allocator 758 (Allocator => N, 759 Function_Call => Exp); 760 return; 761 end if; 762 763 -- In the case of an Ada 2012 allocator whose initial value comes from a 764 -- function call, pass "the accessibility level determined by the point 765 -- of call" (AI05-0234) to the function. Conceptually, this belongs in 766 -- Expand_Call but it couldn't be done there (because the Etype of the 767 -- allocator wasn't set then) so we generate the parameter here. See 768 -- the Boolean variable Defer in (a block within) Expand_Call. 769 770 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then 771 declare 772 Subp : Entity_Id; 773 774 begin 775 if Nkind (Name (Exp)) = N_Explicit_Dereference then 776 Subp := Designated_Type (Etype (Prefix (Name (Exp)))); 777 else 778 Subp := Entity (Name (Exp)); 779 end if; 780 781 Subp := Ultimate_Alias (Subp); 782 783 if Present (Extra_Accessibility_Of_Result (Subp)) then 784 Add_Extra_Actual_To_Call 785 (Subprogram_Call => Exp, 786 Extra_Formal => Extra_Accessibility_Of_Result (Subp), 787 Extra_Actual => Dynamic_Accessibility_Level (PtrT)); 788 end if; 789 end; 790 end if; 791 792 -- Case of tagged type or type requiring finalization 793 794 if Is_Tagged_Type (T) or else Needs_Finalization (T) then 795 796 -- Ada 2005 (AI-318-02): If the initialization expression is a call 797 -- to a build-in-place function, then access to the allocated object 798 -- must be passed to the function. 799 800 if Is_Build_In_Place_Function_Call (Exp) then 801 Make_Build_In_Place_Call_In_Allocator (N, Exp); 802 Apply_Accessibility_Check (N, Built_In_Place => True); 803 return; 804 805 -- Ada 2005 (AI-318-02): Specialization of the previous case for 806 -- expressions containing a build-in-place function call whose 807 -- returned object covers interface types, and Expr has calls to 808 -- Ada.Tags.Displace to displace the pointer to the returned build- 809 -- in-place object to reference the secondary dispatch table of a 810 -- covered interface type. 811 812 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then 813 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp); 814 Apply_Accessibility_Check (N, Built_In_Place => True); 815 return; 816 end if; 817 818 -- Actions inserted before: 819 -- Temp : constant ptr_T := new T'(Expression); 820 -- Temp._tag = T'tag; -- when not class-wide 821 -- [Deep_]Adjust (Temp.all); 822 823 -- We analyze by hand the new internal allocator to avoid any 824 -- recursion and inappropriate call to Initialize. 825 826 -- We don't want to remove side effects when the expression must be 827 -- built in place. In the case of a build-in-place function call, 828 -- that could lead to a duplication of the call, which was already 829 -- substituted for the allocator. 830 831 if not Aggr_In_Place then 832 Remove_Side_Effects (Exp); 833 end if; 834 835 Temp := Make_Temporary (Loc, 'P', N); 836 837 -- For a class wide allocation generate the following code: 838 839 -- type Equiv_Record is record ... end record; 840 -- implicit subtype CW is <Class_Wide_Subytpe>; 841 -- temp : PtrT := new CW'(CW!(expr)); 842 843 if Is_Class_Wide_Type (T) then 844 Expand_Subtype_From_Expr (Empty, T, Indic, Exp); 845 846 -- Ada 2005 (AI-251): If the expression is a class-wide interface 847 -- object we generate code to move up "this" to reference the 848 -- base of the object before allocating the new object. 849 850 -- Note that Exp'Address is recursively expanded into a call 851 -- to Base_Address (Exp.Tag) 852 853 if Is_Class_Wide_Type (Etype (Exp)) 854 and then Is_Interface (Etype (Exp)) 855 and then Tagged_Type_Expansion 856 then 857 Set_Expression 858 (Expression (N), 859 Unchecked_Convert_To (Entity (Indic), 860 Make_Explicit_Dereference (Loc, 861 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 862 Make_Attribute_Reference (Loc, 863 Prefix => Exp, 864 Attribute_Name => Name_Address))))); 865 else 866 Set_Expression 867 (Expression (N), 868 Unchecked_Convert_To (Entity (Indic), Exp)); 869 end if; 870 871 Analyze_And_Resolve (Expression (N), Entity (Indic)); 872 end if; 873 874 -- Processing for allocators returning non-interface types 875 876 if not Is_Interface (Directly_Designated_Type (PtrT)) then 877 if Aggr_In_Place then 878 Temp_Decl := 879 Make_Object_Declaration (Loc, 880 Defining_Identifier => Temp, 881 Object_Definition => New_Occurrence_Of (PtrT, Loc), 882 Expression => 883 Make_Allocator (Loc, 884 Expression => 885 New_Occurrence_Of (Etype (Exp), Loc))); 886 887 -- Copy the Comes_From_Source flag for the allocator we just 888 -- built, since logically this allocator is a replacement of 889 -- the original allocator node. This is for proper handling of 890 -- restriction No_Implicit_Heap_Allocations. 891 892 Set_Comes_From_Source 893 (Expression (Temp_Decl), Comes_From_Source (N)); 894 895 Set_No_Initialization (Expression (Temp_Decl)); 896 Insert_Action (N, Temp_Decl); 897 898 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 899 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 900 901 else 902 Node := Relocate_Node (N); 903 Set_Analyzed (Node); 904 905 Temp_Decl := 906 Make_Object_Declaration (Loc, 907 Defining_Identifier => Temp, 908 Constant_Present => True, 909 Object_Definition => New_Occurrence_Of (PtrT, Loc), 910 Expression => Node); 911 912 Insert_Action (N, Temp_Decl); 913 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 914 end if; 915 916 -- Ada 2005 (AI-251): Handle allocators whose designated type is an 917 -- interface type. In this case we use the type of the qualified 918 -- expression to allocate the object. 919 920 else 921 declare 922 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 923 New_Decl : Node_Id; 924 925 begin 926 New_Decl := 927 Make_Full_Type_Declaration (Loc, 928 Defining_Identifier => Def_Id, 929 Type_Definition => 930 Make_Access_To_Object_Definition (Loc, 931 All_Present => True, 932 Null_Exclusion_Present => False, 933 Constant_Present => 934 Is_Access_Constant (Etype (N)), 935 Subtype_Indication => 936 New_Occurrence_Of (Etype (Exp), Loc))); 937 938 Insert_Action (N, New_Decl); 939 940 -- Inherit the allocation-related attributes from the original 941 -- access type. 942 943 Set_Finalization_Master 944 (Def_Id, Finalization_Master (PtrT)); 945 946 Set_Associated_Storage_Pool 947 (Def_Id, Associated_Storage_Pool (PtrT)); 948 949 -- Declare the object using the previous type declaration 950 951 if Aggr_In_Place then 952 Temp_Decl := 953 Make_Object_Declaration (Loc, 954 Defining_Identifier => Temp, 955 Object_Definition => New_Occurrence_Of (Def_Id, Loc), 956 Expression => 957 Make_Allocator (Loc, 958 New_Occurrence_Of (Etype (Exp), Loc))); 959 960 -- Copy the Comes_From_Source flag for the allocator we just 961 -- built, since logically this allocator is a replacement of 962 -- the original allocator node. This is for proper handling 963 -- of restriction No_Implicit_Heap_Allocations. 964 965 Set_Comes_From_Source 966 (Expression (Temp_Decl), Comes_From_Source (N)); 967 968 Set_No_Initialization (Expression (Temp_Decl)); 969 Insert_Action (N, Temp_Decl); 970 971 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 972 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 973 974 else 975 Node := Relocate_Node (N); 976 Set_Analyzed (Node); 977 978 Temp_Decl := 979 Make_Object_Declaration (Loc, 980 Defining_Identifier => Temp, 981 Constant_Present => True, 982 Object_Definition => New_Occurrence_Of (Def_Id, Loc), 983 Expression => Node); 984 985 Insert_Action (N, Temp_Decl); 986 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 987 end if; 988 989 -- Generate an additional object containing the address of the 990 -- returned object. The type of this second object declaration 991 -- is the correct type required for the common processing that 992 -- is still performed by this subprogram. The displacement of 993 -- this pointer to reference the component associated with the 994 -- interface type will be done at the end of common processing. 995 996 New_Decl := 997 Make_Object_Declaration (Loc, 998 Defining_Identifier => Make_Temporary (Loc, 'P'), 999 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1000 Expression => 1001 Unchecked_Convert_To (PtrT, 1002 New_Occurrence_Of (Temp, Loc))); 1003 1004 Insert_Action (N, New_Decl); 1005 1006 Temp_Decl := New_Decl; 1007 Temp := Defining_Identifier (New_Decl); 1008 end; 1009 end if; 1010 1011 -- Generate the tag assignment 1012 1013 -- Suppress the tag assignment for VM targets because VM tags are 1014 -- represented implicitly in objects. 1015 1016 if not Tagged_Type_Expansion then 1017 null; 1018 1019 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide 1020 -- interface objects because in this case the tag does not change. 1021 1022 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then 1023 pragma Assert (Is_Class_Wide_Type 1024 (Directly_Designated_Type (Etype (N)))); 1025 null; 1026 1027 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then 1028 TagT := T; 1029 TagR := New_Occurrence_Of (Temp, Loc); 1030 1031 elsif Is_Private_Type (T) 1032 and then Is_Tagged_Type (Underlying_Type (T)) 1033 then 1034 TagT := Underlying_Type (T); 1035 TagR := 1036 Unchecked_Convert_To (Underlying_Type (T), 1037 Make_Explicit_Dereference (Loc, 1038 Prefix => New_Occurrence_Of (Temp, Loc))); 1039 end if; 1040 1041 if Present (TagT) then 1042 declare 1043 Full_T : constant Entity_Id := Underlying_Type (TagT); 1044 1045 begin 1046 Tag_Assign := 1047 Make_Assignment_Statement (Loc, 1048 Name => 1049 Make_Selected_Component (Loc, 1050 Prefix => TagR, 1051 Selector_Name => 1052 New_Occurrence_Of 1053 (First_Tag_Component (Full_T), Loc)), 1054 1055 Expression => 1056 Unchecked_Convert_To (RTE (RE_Tag), 1057 New_Occurrence_Of 1058 (Elists.Node 1059 (First_Elmt (Access_Disp_Table (Full_T))), Loc))); 1060 end; 1061 1062 -- The previous assignment has to be done in any case 1063 1064 Set_Assignment_OK (Name (Tag_Assign)); 1065 Insert_Action (N, Tag_Assign); 1066 end if; 1067 1068 -- Generate an Adjust call if the object will be moved. In Ada 2005, 1069 -- the object may be inherently limited, in which case there is no 1070 -- Adjust procedure, and the object is built in place. In Ada 95, the 1071 -- object can be limited but not inherently limited if this allocator 1072 -- came from a return statement (we're allocating the result on the 1073 -- secondary stack). In that case, the object will be moved, so we do 1074 -- want to Adjust. However, if it's a nonlimited build-in-place 1075 -- function call, Adjust is not wanted. 1076 1077 if Needs_Finalization (DesigT) 1078 and then Needs_Finalization (T) 1079 and then not Aggr_In_Place 1080 and then not Is_Limited_View (T) 1081 and then not Alloc_For_BIP_Return (N) 1082 and then not Is_Build_In_Place_Function_Call (Expression (N)) 1083 then 1084 -- An unchecked conversion is needed in the classwide case because 1085 -- the designated type can be an ancestor of the subtype mark of 1086 -- the allocator. 1087 1088 Adj_Call := 1089 Make_Adjust_Call 1090 (Obj_Ref => 1091 Unchecked_Convert_To (T, 1092 Make_Explicit_Dereference (Loc, 1093 Prefix => New_Occurrence_Of (Temp, Loc))), 1094 Typ => T); 1095 1096 if Present (Adj_Call) then 1097 Insert_Action (N, Adj_Call); 1098 end if; 1099 end if; 1100 1101 -- Note: the accessibility check must be inserted after the call to 1102 -- [Deep_]Adjust to ensure proper completion of the assignment. 1103 1104 Apply_Accessibility_Check (Temp); 1105 1106 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1107 Analyze_And_Resolve (N, PtrT); 1108 1109 -- Ada 2005 (AI-251): Displace the pointer to reference the record 1110 -- component containing the secondary dispatch table of the interface 1111 -- type. 1112 1113 if Is_Interface (Directly_Designated_Type (PtrT)) then 1114 Displace_Allocator_Pointer (N); 1115 end if; 1116 1117 -- Always force the generation of a temporary for aggregates when 1118 -- generating C code, to simplify the work in the code generator. 1119 1120 elsif Aggr_In_Place 1121 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate) 1122 then 1123 Temp := Make_Temporary (Loc, 'P', N); 1124 Temp_Decl := 1125 Make_Object_Declaration (Loc, 1126 Defining_Identifier => Temp, 1127 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1128 Expression => 1129 Make_Allocator (Loc, 1130 Expression => New_Occurrence_Of (Etype (Exp), Loc))); 1131 1132 -- Copy the Comes_From_Source flag for the allocator we just built, 1133 -- since logically this allocator is a replacement of the original 1134 -- allocator node. This is for proper handling of restriction 1135 -- No_Implicit_Heap_Allocations. 1136 1137 Set_Comes_From_Source 1138 (Expression (Temp_Decl), Comes_From_Source (N)); 1139 1140 Set_No_Initialization (Expression (Temp_Decl)); 1141 Insert_Action (N, Temp_Decl); 1142 1143 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1144 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1145 1146 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1147 Analyze_And_Resolve (N, PtrT); 1148 1149 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then 1150 Install_Null_Excluding_Check (Exp); 1151 1152 elsif Is_Access_Type (DesigT) 1153 and then Nkind (Exp) = N_Allocator 1154 and then Nkind (Expression (Exp)) /= N_Qualified_Expression 1155 then 1156 -- Apply constraint to designated subtype indication 1157 1158 Apply_Constraint_Check 1159 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True); 1160 1161 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then 1162 1163 -- Propagate constraint_error to enclosing allocator 1164 1165 Rewrite (Exp, New_Copy (Expression (Exp))); 1166 end if; 1167 1168 else 1169 Build_Allocate_Deallocate_Proc (N, True); 1170 1171 -- If we have: 1172 -- type A is access T1; 1173 -- X : A := new T2'(...); 1174 -- T1 and T2 can be different subtypes, and we might need to check 1175 -- both constraints. First check against the type of the qualified 1176 -- expression. 1177 1178 Apply_Constraint_Check (Exp, T, No_Sliding => True); 1179 1180 if Do_Range_Check (Exp) then 1181 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 1182 end if; 1183 1184 -- A check is also needed in cases where the designated subtype is 1185 -- constrained and differs from the subtype given in the qualified 1186 -- expression. Note that the check on the qualified expression does 1187 -- not allow sliding, but this check does (a relaxation from Ada 83). 1188 1189 if Is_Constrained (DesigT) 1190 and then not Subtypes_Statically_Match (T, DesigT) 1191 then 1192 Apply_Constraint_Check 1193 (Exp, DesigT, No_Sliding => False); 1194 1195 if Do_Range_Check (Exp) then 1196 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 1197 end if; 1198 end if; 1199 1200 -- For an access to unconstrained packed array, GIGI needs to see an 1201 -- expression with a constrained subtype in order to compute the 1202 -- proper size for the allocator. 1203 1204 if Is_Array_Type (T) 1205 and then not Is_Constrained (T) 1206 and then Is_Packed (T) 1207 then 1208 declare 1209 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); 1210 Internal_Exp : constant Node_Id := Relocate_Node (Exp); 1211 begin 1212 Insert_Action (Exp, 1213 Make_Subtype_Declaration (Loc, 1214 Defining_Identifier => ConstrT, 1215 Subtype_Indication => 1216 Make_Subtype_From_Expr (Internal_Exp, T))); 1217 Freeze_Itype (ConstrT, Exp); 1218 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); 1219 end; 1220 end if; 1221 1222 -- Ada 2005 (AI-318-02): If the initialization expression is a call 1223 -- to a build-in-place function, then access to the allocated object 1224 -- must be passed to the function. 1225 1226 if Is_Build_In_Place_Function_Call (Exp) then 1227 Make_Build_In_Place_Call_In_Allocator (N, Exp); 1228 end if; 1229 end if; 1230 1231 exception 1232 when RE_Not_Available => 1233 return; 1234 end Expand_Allocator_Expression; 1235 1236 ----------------------------- 1237 -- Expand_Array_Comparison -- 1238 ----------------------------- 1239 1240 -- Expansion is only required in the case of array types. For the unpacked 1241 -- case, an appropriate runtime routine is called. For packed cases, and 1242 -- also in some other cases where a runtime routine cannot be called, the 1243 -- form of the expansion is: 1244 1245 -- [body for greater_nn; boolean_expression] 1246 1247 -- The body is built by Make_Array_Comparison_Op, and the form of the 1248 -- Boolean expression depends on the operator involved. 1249 1250 procedure Expand_Array_Comparison (N : Node_Id) is 1251 Loc : constant Source_Ptr := Sloc (N); 1252 Op1 : Node_Id := Left_Opnd (N); 1253 Op2 : Node_Id := Right_Opnd (N); 1254 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 1255 Ctyp : constant Entity_Id := Component_Type (Typ1); 1256 1257 Expr : Node_Id; 1258 Func_Body : Node_Id; 1259 Func_Name : Entity_Id; 1260 1261 Comp : RE_Id; 1262 1263 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; 1264 -- True for byte addressable target 1265 1266 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; 1267 -- Returns True if the length of the given operand is known to be less 1268 -- than 4. Returns False if this length is known to be four or greater 1269 -- or is not known at compile time. 1270 1271 ------------------------ 1272 -- Length_Less_Than_4 -- 1273 ------------------------ 1274 1275 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is 1276 Otyp : constant Entity_Id := Etype (Opnd); 1277 1278 begin 1279 if Ekind (Otyp) = E_String_Literal_Subtype then 1280 return String_Literal_Length (Otyp) < 4; 1281 1282 else 1283 declare 1284 Ityp : constant Entity_Id := Etype (First_Index (Otyp)); 1285 Lo : constant Node_Id := Type_Low_Bound (Ityp); 1286 Hi : constant Node_Id := Type_High_Bound (Ityp); 1287 Lov : Uint; 1288 Hiv : Uint; 1289 1290 begin 1291 if Compile_Time_Known_Value (Lo) then 1292 Lov := Expr_Value (Lo); 1293 else 1294 return False; 1295 end if; 1296 1297 if Compile_Time_Known_Value (Hi) then 1298 Hiv := Expr_Value (Hi); 1299 else 1300 return False; 1301 end if; 1302 1303 return Hiv < Lov + 3; 1304 end; 1305 end if; 1306 end Length_Less_Than_4; 1307 1308 -- Start of processing for Expand_Array_Comparison 1309 1310 begin 1311 -- Deal first with unpacked case, where we can call a runtime routine 1312 -- except that we avoid this for targets for which are not addressable 1313 -- by bytes. 1314 1315 if not Is_Bit_Packed_Array (Typ1) 1316 and then Byte_Addressable 1317 then 1318 -- The call we generate is: 1319 1320 -- Compare_Array_xn[_Unaligned] 1321 -- (left'address, right'address, left'length, right'length) <op> 0 1322 1323 -- x = U for unsigned, S for signed 1324 -- n = 8,16,32,64 for component size 1325 -- Add _Unaligned if length < 4 and component size is 8. 1326 -- <op> is the standard comparison operator 1327 1328 if Component_Size (Typ1) = 8 then 1329 if Length_Less_Than_4 (Op1) 1330 or else 1331 Length_Less_Than_4 (Op2) 1332 then 1333 if Is_Unsigned_Type (Ctyp) then 1334 Comp := RE_Compare_Array_U8_Unaligned; 1335 else 1336 Comp := RE_Compare_Array_S8_Unaligned; 1337 end if; 1338 1339 else 1340 if Is_Unsigned_Type (Ctyp) then 1341 Comp := RE_Compare_Array_U8; 1342 else 1343 Comp := RE_Compare_Array_S8; 1344 end if; 1345 end if; 1346 1347 elsif Component_Size (Typ1) = 16 then 1348 if Is_Unsigned_Type (Ctyp) then 1349 Comp := RE_Compare_Array_U16; 1350 else 1351 Comp := RE_Compare_Array_S16; 1352 end if; 1353 1354 elsif Component_Size (Typ1) = 32 then 1355 if Is_Unsigned_Type (Ctyp) then 1356 Comp := RE_Compare_Array_U32; 1357 else 1358 Comp := RE_Compare_Array_S32; 1359 end if; 1360 1361 else pragma Assert (Component_Size (Typ1) = 64); 1362 if Is_Unsigned_Type (Ctyp) then 1363 Comp := RE_Compare_Array_U64; 1364 else 1365 Comp := RE_Compare_Array_S64; 1366 end if; 1367 end if; 1368 1369 if RTE_Available (Comp) then 1370 1371 -- Expand to a call only if the runtime function is available, 1372 -- otherwise fall back to inline code. 1373 1374 Remove_Side_Effects (Op1, Name_Req => True); 1375 Remove_Side_Effects (Op2, Name_Req => True); 1376 1377 Rewrite (Op1, 1378 Make_Function_Call (Sloc (Op1), 1379 Name => New_Occurrence_Of (RTE (Comp), Loc), 1380 1381 Parameter_Associations => New_List ( 1382 Make_Attribute_Reference (Loc, 1383 Prefix => Relocate_Node (Op1), 1384 Attribute_Name => Name_Address), 1385 1386 Make_Attribute_Reference (Loc, 1387 Prefix => Relocate_Node (Op2), 1388 Attribute_Name => Name_Address), 1389 1390 Make_Attribute_Reference (Loc, 1391 Prefix => Relocate_Node (Op1), 1392 Attribute_Name => Name_Length), 1393 1394 Make_Attribute_Reference (Loc, 1395 Prefix => Relocate_Node (Op2), 1396 Attribute_Name => Name_Length)))); 1397 1398 Rewrite (Op2, 1399 Make_Integer_Literal (Sloc (Op2), 1400 Intval => Uint_0)); 1401 1402 Analyze_And_Resolve (Op1, Standard_Integer); 1403 Analyze_And_Resolve (Op2, Standard_Integer); 1404 return; 1405 end if; 1406 end if; 1407 1408 -- Cases where we cannot make runtime call 1409 1410 -- For (a <= b) we convert to not (a > b) 1411 1412 if Chars (N) = Name_Op_Le then 1413 Rewrite (N, 1414 Make_Op_Not (Loc, 1415 Right_Opnd => 1416 Make_Op_Gt (Loc, 1417 Left_Opnd => Op1, 1418 Right_Opnd => Op2))); 1419 Analyze_And_Resolve (N, Standard_Boolean); 1420 return; 1421 1422 -- For < the Boolean expression is 1423 -- greater__nn (op2, op1) 1424 1425 elsif Chars (N) = Name_Op_Lt then 1426 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1427 1428 -- Switch operands 1429 1430 Op1 := Right_Opnd (N); 1431 Op2 := Left_Opnd (N); 1432 1433 -- For (a >= b) we convert to not (a < b) 1434 1435 elsif Chars (N) = Name_Op_Ge then 1436 Rewrite (N, 1437 Make_Op_Not (Loc, 1438 Right_Opnd => 1439 Make_Op_Lt (Loc, 1440 Left_Opnd => Op1, 1441 Right_Opnd => Op2))); 1442 Analyze_And_Resolve (N, Standard_Boolean); 1443 return; 1444 1445 -- For > the Boolean expression is 1446 -- greater__nn (op1, op2) 1447 1448 else 1449 pragma Assert (Chars (N) = Name_Op_Gt); 1450 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1451 end if; 1452 1453 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 1454 Expr := 1455 Make_Function_Call (Loc, 1456 Name => New_Occurrence_Of (Func_Name, Loc), 1457 Parameter_Associations => New_List (Op1, Op2)); 1458 1459 Insert_Action (N, Func_Body); 1460 Rewrite (N, Expr); 1461 Analyze_And_Resolve (N, Standard_Boolean); 1462 end Expand_Array_Comparison; 1463 1464 --------------------------- 1465 -- Expand_Array_Equality -- 1466 --------------------------- 1467 1468 -- Expand an equality function for multi-dimensional arrays. Here is an 1469 -- example of such a function for Nb_Dimension = 2 1470 1471 -- function Enn (A : atyp; B : btyp) return boolean is 1472 -- begin 1473 -- if (A'length (1) = 0 or else A'length (2) = 0) 1474 -- and then 1475 -- (B'length (1) = 0 or else B'length (2) = 0) 1476 -- then 1477 -- return True; -- RM 4.5.2(22) 1478 -- end if; 1479 1480 -- if A'length (1) /= B'length (1) 1481 -- or else 1482 -- A'length (2) /= B'length (2) 1483 -- then 1484 -- return False; -- RM 4.5.2(23) 1485 -- end if; 1486 1487 -- declare 1488 -- A1 : Index_T1 := A'first (1); 1489 -- B1 : Index_T1 := B'first (1); 1490 -- begin 1491 -- loop 1492 -- declare 1493 -- A2 : Index_T2 := A'first (2); 1494 -- B2 : Index_T2 := B'first (2); 1495 -- begin 1496 -- loop 1497 -- if A (A1, A2) /= B (B1, B2) then 1498 -- return False; 1499 -- end if; 1500 1501 -- exit when A2 = A'last (2); 1502 -- A2 := Index_T2'succ (A2); 1503 -- B2 := Index_T2'succ (B2); 1504 -- end loop; 1505 -- end; 1506 1507 -- exit when A1 = A'last (1); 1508 -- A1 := Index_T1'succ (A1); 1509 -- B1 := Index_T1'succ (B1); 1510 -- end loop; 1511 -- end; 1512 1513 -- return true; 1514 -- end Enn; 1515 1516 -- Note on the formal types used (atyp and btyp). If either of the arrays 1517 -- is of a private type, we use the underlying type, and do an unchecked 1518 -- conversion of the actual. If either of the arrays has a bound depending 1519 -- on a discriminant, then we use the base type since otherwise we have an 1520 -- escaped discriminant in the function. 1521 1522 -- If both arrays are constrained and have the same bounds, we can generate 1523 -- a loop with an explicit iteration scheme using a 'Range attribute over 1524 -- the first array. 1525 1526 function Expand_Array_Equality 1527 (Nod : Node_Id; 1528 Lhs : Node_Id; 1529 Rhs : Node_Id; 1530 Bodies : List_Id; 1531 Typ : Entity_Id) return Node_Id 1532 is 1533 Loc : constant Source_Ptr := Sloc (Nod); 1534 Decls : constant List_Id := New_List; 1535 Index_List1 : constant List_Id := New_List; 1536 Index_List2 : constant List_Id := New_List; 1537 1538 Actuals : List_Id; 1539 Formals : List_Id; 1540 Func_Name : Entity_Id; 1541 Func_Body : Node_Id; 1542 1543 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 1544 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 1545 1546 Ltyp : Entity_Id; 1547 Rtyp : Entity_Id; 1548 -- The parameter types to be used for the formals 1549 1550 function Arr_Attr 1551 (Arr : Entity_Id; 1552 Nam : Name_Id; 1553 Num : Int) return Node_Id; 1554 -- This builds the attribute reference Arr'Nam (Expr) 1555 1556 function Component_Equality (Typ : Entity_Id) return Node_Id; 1557 -- Create one statement to compare corresponding components, designated 1558 -- by a full set of indexes. 1559 1560 function Get_Arg_Type (N : Node_Id) return Entity_Id; 1561 -- Given one of the arguments, computes the appropriate type to be used 1562 -- for that argument in the corresponding function formal 1563 1564 function Handle_One_Dimension 1565 (N : Int; 1566 Index : Node_Id) return Node_Id; 1567 -- This procedure returns the following code 1568 -- 1569 -- declare 1570 -- Bn : Index_T := B'First (N); 1571 -- begin 1572 -- loop 1573 -- xxx 1574 -- exit when An = A'Last (N); 1575 -- An := Index_T'Succ (An) 1576 -- Bn := Index_T'Succ (Bn) 1577 -- end loop; 1578 -- end; 1579 -- 1580 -- If both indexes are constrained and identical, the procedure 1581 -- returns a simpler loop: 1582 -- 1583 -- for An in A'Range (N) loop 1584 -- xxx 1585 -- end loop 1586 -- 1587 -- N is the dimension for which we are generating a loop. Index is the 1588 -- N'th index node, whose Etype is Index_Type_n in the above code. The 1589 -- xxx statement is either the loop or declare for the next dimension 1590 -- or if this is the last dimension the comparison of corresponding 1591 -- components of the arrays. 1592 -- 1593 -- The actual way the code works is to return the comparison of 1594 -- corresponding components for the N+1 call. That's neater. 1595 1596 function Test_Empty_Arrays return Node_Id; 1597 -- This function constructs the test for both arrays being empty 1598 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) 1599 -- and then 1600 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) 1601 1602 function Test_Lengths_Correspond return Node_Id; 1603 -- This function constructs the test for arrays having different lengths 1604 -- in at least one index position, in which case the resulting code is: 1605 1606 -- A'length (1) /= B'length (1) 1607 -- or else 1608 -- A'length (2) /= B'length (2) 1609 -- or else 1610 -- ... 1611 1612 -------------- 1613 -- Arr_Attr -- 1614 -------------- 1615 1616 function Arr_Attr 1617 (Arr : Entity_Id; 1618 Nam : Name_Id; 1619 Num : Int) return Node_Id 1620 is 1621 begin 1622 return 1623 Make_Attribute_Reference (Loc, 1624 Attribute_Name => Nam, 1625 Prefix => New_Occurrence_Of (Arr, Loc), 1626 Expressions => New_List (Make_Integer_Literal (Loc, Num))); 1627 end Arr_Attr; 1628 1629 ------------------------ 1630 -- Component_Equality -- 1631 ------------------------ 1632 1633 function Component_Equality (Typ : Entity_Id) return Node_Id is 1634 Test : Node_Id; 1635 L, R : Node_Id; 1636 1637 begin 1638 -- if a(i1...) /= b(j1...) then return false; end if; 1639 1640 L := 1641 Make_Indexed_Component (Loc, 1642 Prefix => Make_Identifier (Loc, Chars (A)), 1643 Expressions => Index_List1); 1644 1645 R := 1646 Make_Indexed_Component (Loc, 1647 Prefix => Make_Identifier (Loc, Chars (B)), 1648 Expressions => Index_List2); 1649 1650 Test := Expand_Composite_Equality 1651 (Nod, Component_Type (Typ), L, R, Decls); 1652 1653 -- If some (sub)component is an unchecked_union, the whole operation 1654 -- will raise program error. 1655 1656 if Nkind (Test) = N_Raise_Program_Error then 1657 1658 -- This node is going to be inserted at a location where a 1659 -- statement is expected: clear its Etype so analysis will set 1660 -- it to the expected Standard_Void_Type. 1661 1662 Set_Etype (Test, Empty); 1663 return Test; 1664 1665 else 1666 return 1667 Make_Implicit_If_Statement (Nod, 1668 Condition => Make_Op_Not (Loc, Right_Opnd => Test), 1669 Then_Statements => New_List ( 1670 Make_Simple_Return_Statement (Loc, 1671 Expression => New_Occurrence_Of (Standard_False, Loc)))); 1672 end if; 1673 end Component_Equality; 1674 1675 ------------------ 1676 -- Get_Arg_Type -- 1677 ------------------ 1678 1679 function Get_Arg_Type (N : Node_Id) return Entity_Id is 1680 T : Entity_Id; 1681 X : Node_Id; 1682 1683 begin 1684 T := Etype (N); 1685 1686 if No (T) then 1687 return Typ; 1688 1689 else 1690 T := Underlying_Type (T); 1691 1692 X := First_Index (T); 1693 while Present (X) loop 1694 if Denotes_Discriminant (Type_Low_Bound (Etype (X))) 1695 or else 1696 Denotes_Discriminant (Type_High_Bound (Etype (X))) 1697 then 1698 T := Base_Type (T); 1699 exit; 1700 end if; 1701 1702 Next_Index (X); 1703 end loop; 1704 1705 return T; 1706 end if; 1707 end Get_Arg_Type; 1708 1709 -------------------------- 1710 -- Handle_One_Dimension -- 1711 --------------------------- 1712 1713 function Handle_One_Dimension 1714 (N : Int; 1715 Index : Node_Id) return Node_Id 1716 is 1717 Need_Separate_Indexes : constant Boolean := 1718 Ltyp /= Rtyp or else not Is_Constrained (Ltyp); 1719 -- If the index types are identical, and we are working with 1720 -- constrained types, then we can use the same index for both 1721 -- of the arrays. 1722 1723 An : constant Entity_Id := Make_Temporary (Loc, 'A'); 1724 1725 Bn : Entity_Id; 1726 Index_T : Entity_Id; 1727 Stm_List : List_Id; 1728 Loop_Stm : Node_Id; 1729 1730 begin 1731 if N > Number_Dimensions (Ltyp) then 1732 return Component_Equality (Ltyp); 1733 end if; 1734 1735 -- Case where we generate a loop 1736 1737 Index_T := Base_Type (Etype (Index)); 1738 1739 if Need_Separate_Indexes then 1740 Bn := Make_Temporary (Loc, 'B'); 1741 else 1742 Bn := An; 1743 end if; 1744 1745 Append (New_Occurrence_Of (An, Loc), Index_List1); 1746 Append (New_Occurrence_Of (Bn, Loc), Index_List2); 1747 1748 Stm_List := New_List ( 1749 Handle_One_Dimension (N + 1, Next_Index (Index))); 1750 1751 if Need_Separate_Indexes then 1752 1753 -- Generate guard for loop, followed by increments of indexes 1754 1755 Append_To (Stm_List, 1756 Make_Exit_Statement (Loc, 1757 Condition => 1758 Make_Op_Eq (Loc, 1759 Left_Opnd => New_Occurrence_Of (An, Loc), 1760 Right_Opnd => Arr_Attr (A, Name_Last, N)))); 1761 1762 Append_To (Stm_List, 1763 Make_Assignment_Statement (Loc, 1764 Name => New_Occurrence_Of (An, Loc), 1765 Expression => 1766 Make_Attribute_Reference (Loc, 1767 Prefix => New_Occurrence_Of (Index_T, Loc), 1768 Attribute_Name => Name_Succ, 1769 Expressions => New_List ( 1770 New_Occurrence_Of (An, Loc))))); 1771 1772 Append_To (Stm_List, 1773 Make_Assignment_Statement (Loc, 1774 Name => New_Occurrence_Of (Bn, Loc), 1775 Expression => 1776 Make_Attribute_Reference (Loc, 1777 Prefix => New_Occurrence_Of (Index_T, Loc), 1778 Attribute_Name => Name_Succ, 1779 Expressions => New_List ( 1780 New_Occurrence_Of (Bn, Loc))))); 1781 end if; 1782 1783 -- If separate indexes, we need a declare block for An and Bn, and a 1784 -- loop without an iteration scheme. 1785 1786 if Need_Separate_Indexes then 1787 Loop_Stm := 1788 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); 1789 1790 return 1791 Make_Block_Statement (Loc, 1792 Declarations => New_List ( 1793 Make_Object_Declaration (Loc, 1794 Defining_Identifier => An, 1795 Object_Definition => New_Occurrence_Of (Index_T, Loc), 1796 Expression => Arr_Attr (A, Name_First, N)), 1797 1798 Make_Object_Declaration (Loc, 1799 Defining_Identifier => Bn, 1800 Object_Definition => New_Occurrence_Of (Index_T, Loc), 1801 Expression => Arr_Attr (B, Name_First, N))), 1802 1803 Handled_Statement_Sequence => 1804 Make_Handled_Sequence_Of_Statements (Loc, 1805 Statements => New_List (Loop_Stm))); 1806 1807 -- If no separate indexes, return loop statement with explicit 1808 -- iteration scheme on its own 1809 1810 else 1811 Loop_Stm := 1812 Make_Implicit_Loop_Statement (Nod, 1813 Statements => Stm_List, 1814 Iteration_Scheme => 1815 Make_Iteration_Scheme (Loc, 1816 Loop_Parameter_Specification => 1817 Make_Loop_Parameter_Specification (Loc, 1818 Defining_Identifier => An, 1819 Discrete_Subtype_Definition => 1820 Arr_Attr (A, Name_Range, N)))); 1821 return Loop_Stm; 1822 end if; 1823 end Handle_One_Dimension; 1824 1825 ----------------------- 1826 -- Test_Empty_Arrays -- 1827 ----------------------- 1828 1829 function Test_Empty_Arrays return Node_Id is 1830 Alist : Node_Id; 1831 Blist : Node_Id; 1832 1833 Atest : Node_Id; 1834 Btest : Node_Id; 1835 1836 begin 1837 Alist := Empty; 1838 Blist := Empty; 1839 for J in 1 .. Number_Dimensions (Ltyp) loop 1840 Atest := 1841 Make_Op_Eq (Loc, 1842 Left_Opnd => Arr_Attr (A, Name_Length, J), 1843 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1844 1845 Btest := 1846 Make_Op_Eq (Loc, 1847 Left_Opnd => Arr_Attr (B, Name_Length, J), 1848 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1849 1850 if No (Alist) then 1851 Alist := Atest; 1852 Blist := Btest; 1853 1854 else 1855 Alist := 1856 Make_Or_Else (Loc, 1857 Left_Opnd => Relocate_Node (Alist), 1858 Right_Opnd => Atest); 1859 1860 Blist := 1861 Make_Or_Else (Loc, 1862 Left_Opnd => Relocate_Node (Blist), 1863 Right_Opnd => Btest); 1864 end if; 1865 end loop; 1866 1867 return 1868 Make_And_Then (Loc, 1869 Left_Opnd => Alist, 1870 Right_Opnd => Blist); 1871 end Test_Empty_Arrays; 1872 1873 ----------------------------- 1874 -- Test_Lengths_Correspond -- 1875 ----------------------------- 1876 1877 function Test_Lengths_Correspond return Node_Id is 1878 Result : Node_Id; 1879 Rtest : Node_Id; 1880 1881 begin 1882 Result := Empty; 1883 for J in 1 .. Number_Dimensions (Ltyp) loop 1884 Rtest := 1885 Make_Op_Ne (Loc, 1886 Left_Opnd => Arr_Attr (A, Name_Length, J), 1887 Right_Opnd => Arr_Attr (B, Name_Length, J)); 1888 1889 if No (Result) then 1890 Result := Rtest; 1891 else 1892 Result := 1893 Make_Or_Else (Loc, 1894 Left_Opnd => Relocate_Node (Result), 1895 Right_Opnd => Rtest); 1896 end if; 1897 end loop; 1898 1899 return Result; 1900 end Test_Lengths_Correspond; 1901 1902 -- Start of processing for Expand_Array_Equality 1903 1904 begin 1905 Ltyp := Get_Arg_Type (Lhs); 1906 Rtyp := Get_Arg_Type (Rhs); 1907 1908 -- For now, if the argument types are not the same, go to the base type, 1909 -- since the code assumes that the formals have the same type. This is 1910 -- fixable in future ??? 1911 1912 if Ltyp /= Rtyp then 1913 Ltyp := Base_Type (Ltyp); 1914 Rtyp := Base_Type (Rtyp); 1915 pragma Assert (Ltyp = Rtyp); 1916 end if; 1917 1918 -- Build list of formals for function 1919 1920 Formals := New_List ( 1921 Make_Parameter_Specification (Loc, 1922 Defining_Identifier => A, 1923 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)), 1924 1925 Make_Parameter_Specification (Loc, 1926 Defining_Identifier => B, 1927 Parameter_Type => New_Occurrence_Of (Rtyp, Loc))); 1928 1929 Func_Name := Make_Temporary (Loc, 'E'); 1930 1931 -- Build statement sequence for function 1932 1933 Func_Body := 1934 Make_Subprogram_Body (Loc, 1935 Specification => 1936 Make_Function_Specification (Loc, 1937 Defining_Unit_Name => Func_Name, 1938 Parameter_Specifications => Formals, 1939 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 1940 1941 Declarations => Decls, 1942 1943 Handled_Statement_Sequence => 1944 Make_Handled_Sequence_Of_Statements (Loc, 1945 Statements => New_List ( 1946 1947 Make_Implicit_If_Statement (Nod, 1948 Condition => Test_Empty_Arrays, 1949 Then_Statements => New_List ( 1950 Make_Simple_Return_Statement (Loc, 1951 Expression => 1952 New_Occurrence_Of (Standard_True, Loc)))), 1953 1954 Make_Implicit_If_Statement (Nod, 1955 Condition => Test_Lengths_Correspond, 1956 Then_Statements => New_List ( 1957 Make_Simple_Return_Statement (Loc, 1958 Expression => New_Occurrence_Of (Standard_False, Loc)))), 1959 1960 Handle_One_Dimension (1, First_Index (Ltyp)), 1961 1962 Make_Simple_Return_Statement (Loc, 1963 Expression => New_Occurrence_Of (Standard_True, Loc))))); 1964 1965 Set_Has_Completion (Func_Name, True); 1966 Set_Is_Inlined (Func_Name); 1967 1968 -- If the array type is distinct from the type of the arguments, it 1969 -- is the full view of a private type. Apply an unchecked conversion 1970 -- to insure that analysis of the call succeeds. 1971 1972 declare 1973 L, R : Node_Id; 1974 1975 begin 1976 L := Lhs; 1977 R := Rhs; 1978 1979 if No (Etype (Lhs)) 1980 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp) 1981 then 1982 L := OK_Convert_To (Ltyp, Lhs); 1983 end if; 1984 1985 if No (Etype (Rhs)) 1986 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp) 1987 then 1988 R := OK_Convert_To (Rtyp, Rhs); 1989 end if; 1990 1991 Actuals := New_List (L, R); 1992 end; 1993 1994 Append_To (Bodies, Func_Body); 1995 1996 return 1997 Make_Function_Call (Loc, 1998 Name => New_Occurrence_Of (Func_Name, Loc), 1999 Parameter_Associations => Actuals); 2000 end Expand_Array_Equality; 2001 2002 ----------------------------- 2003 -- Expand_Boolean_Operator -- 2004 ----------------------------- 2005 2006 -- Note that we first get the actual subtypes of the operands, since we 2007 -- always want to deal with types that have bounds. 2008 2009 procedure Expand_Boolean_Operator (N : Node_Id) is 2010 Typ : constant Entity_Id := Etype (N); 2011 2012 begin 2013 -- Special case of bit packed array where both operands are known to be 2014 -- properly aligned. In this case we use an efficient run time routine 2015 -- to carry out the operation (see System.Bit_Ops). 2016 2017 if Is_Bit_Packed_Array (Typ) 2018 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) 2019 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 2020 then 2021 Expand_Packed_Boolean_Operator (N); 2022 return; 2023 end if; 2024 2025 -- For the normal non-packed case, the general expansion is to build 2026 -- function for carrying out the comparison (use Make_Boolean_Array_Op) 2027 -- and then inserting it into the tree. The original operator node is 2028 -- then rewritten as a call to this function. We also use this in the 2029 -- packed case if either operand is a possibly unaligned object. 2030 2031 declare 2032 Loc : constant Source_Ptr := Sloc (N); 2033 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 2034 R : constant Node_Id := Relocate_Node (Right_Opnd (N)); 2035 Func_Body : Node_Id; 2036 Func_Name : Entity_Id; 2037 2038 begin 2039 Convert_To_Actual_Subtype (L); 2040 Convert_To_Actual_Subtype (R); 2041 Ensure_Defined (Etype (L), N); 2042 Ensure_Defined (Etype (R), N); 2043 Apply_Length_Check (R, Etype (L)); 2044 2045 if Nkind (N) = N_Op_Xor then 2046 Silly_Boolean_Array_Xor_Test (N, Etype (L)); 2047 end if; 2048 2049 if Nkind (Parent (N)) = N_Assignment_Statement 2050 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) 2051 then 2052 Build_Boolean_Array_Proc_Call (Parent (N), L, R); 2053 2054 elsif Nkind (Parent (N)) = N_Op_Not 2055 and then Nkind (N) = N_Op_And 2056 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 2057 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) 2058 then 2059 return; 2060 else 2061 2062 Func_Body := Make_Boolean_Array_Op (Etype (L), N); 2063 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 2064 Insert_Action (N, Func_Body); 2065 2066 -- Now rewrite the expression with a call 2067 2068 Rewrite (N, 2069 Make_Function_Call (Loc, 2070 Name => New_Occurrence_Of (Func_Name, Loc), 2071 Parameter_Associations => 2072 New_List ( 2073 L, 2074 Make_Type_Conversion 2075 (Loc, New_Occurrence_Of (Etype (L), Loc), R)))); 2076 2077 Analyze_And_Resolve (N, Typ); 2078 end if; 2079 end; 2080 end Expand_Boolean_Operator; 2081 2082 ------------------------------------------------ 2083 -- Expand_Compare_Minimize_Eliminate_Overflow -- 2084 ------------------------------------------------ 2085 2086 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is 2087 Loc : constant Source_Ptr := Sloc (N); 2088 2089 Result_Type : constant Entity_Id := Etype (N); 2090 -- Capture result type (could be a derived boolean type) 2091 2092 Llo, Lhi : Uint; 2093 Rlo, Rhi : Uint; 2094 2095 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 2096 -- Entity for Long_Long_Integer'Base 2097 2098 Check : constant Overflow_Mode_Type := Overflow_Check_Mode; 2099 -- Current overflow checking mode 2100 2101 procedure Set_True; 2102 procedure Set_False; 2103 -- These procedures rewrite N with an occurrence of Standard_True or 2104 -- Standard_False, and then makes a call to Warn_On_Known_Condition. 2105 2106 --------------- 2107 -- Set_False -- 2108 --------------- 2109 2110 procedure Set_False is 2111 begin 2112 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 2113 Warn_On_Known_Condition (N); 2114 end Set_False; 2115 2116 -------------- 2117 -- Set_True -- 2118 -------------- 2119 2120 procedure Set_True is 2121 begin 2122 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 2123 Warn_On_Known_Condition (N); 2124 end Set_True; 2125 2126 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow 2127 2128 begin 2129 -- Nothing to do unless we have a comparison operator with operands 2130 -- that are signed integer types, and we are operating in either 2131 -- MINIMIZED or ELIMINATED overflow checking mode. 2132 2133 if Nkind (N) not in N_Op_Compare 2134 or else Check not in Minimized_Or_Eliminated 2135 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N))) 2136 then 2137 return; 2138 end if; 2139 2140 -- OK, this is the case we are interested in. First step is to process 2141 -- our operands using the Minimize_Eliminate circuitry which applies 2142 -- this processing to the two operand subtrees. 2143 2144 Minimize_Eliminate_Overflows 2145 (Left_Opnd (N), Llo, Lhi, Top_Level => False); 2146 Minimize_Eliminate_Overflows 2147 (Right_Opnd (N), Rlo, Rhi, Top_Level => False); 2148 2149 -- See if the range information decides the result of the comparison. 2150 -- We can only do this if we in fact have full range information (which 2151 -- won't be the case if either operand is bignum at this stage). 2152 2153 if Llo /= No_Uint and then Rlo /= No_Uint then 2154 case N_Op_Compare (Nkind (N)) is 2155 when N_Op_Eq => 2156 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2157 Set_True; 2158 elsif Llo > Rhi or else Lhi < Rlo then 2159 Set_False; 2160 end if; 2161 2162 when N_Op_Ge => 2163 if Llo >= Rhi then 2164 Set_True; 2165 elsif Lhi < Rlo then 2166 Set_False; 2167 end if; 2168 2169 when N_Op_Gt => 2170 if Llo > Rhi then 2171 Set_True; 2172 elsif Lhi <= Rlo then 2173 Set_False; 2174 end if; 2175 2176 when N_Op_Le => 2177 if Llo > Rhi then 2178 Set_False; 2179 elsif Lhi <= Rlo then 2180 Set_True; 2181 end if; 2182 2183 when N_Op_Lt => 2184 if Llo >= Rhi then 2185 Set_False; 2186 elsif Lhi < Rlo then 2187 Set_True; 2188 end if; 2189 2190 when N_Op_Ne => 2191 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2192 Set_False; 2193 elsif Llo > Rhi or else Lhi < Rlo then 2194 Set_True; 2195 end if; 2196 end case; 2197 2198 -- All done if we did the rewrite 2199 2200 if Nkind (N) not in N_Op_Compare then 2201 return; 2202 end if; 2203 end if; 2204 2205 -- Otherwise, time to do the comparison 2206 2207 declare 2208 Ltype : constant Entity_Id := Etype (Left_Opnd (N)); 2209 Rtype : constant Entity_Id := Etype (Right_Opnd (N)); 2210 2211 begin 2212 -- If the two operands have the same signed integer type we are 2213 -- all set, nothing more to do. This is the case where either 2214 -- both operands were unchanged, or we rewrote both of them to 2215 -- be Long_Long_Integer. 2216 2217 -- Note: Entity for the comparison may be wrong, but it's not worth 2218 -- the effort to change it, since the back end does not use it. 2219 2220 if Is_Signed_Integer_Type (Ltype) 2221 and then Base_Type (Ltype) = Base_Type (Rtype) 2222 then 2223 return; 2224 2225 -- Here if bignums are involved (can only happen in ELIMINATED mode) 2226 2227 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then 2228 declare 2229 Left : Node_Id := Left_Opnd (N); 2230 Right : Node_Id := Right_Opnd (N); 2231 -- Bignum references for left and right operands 2232 2233 begin 2234 if not Is_RTE (Ltype, RE_Bignum) then 2235 Left := Convert_To_Bignum (Left); 2236 elsif not Is_RTE (Rtype, RE_Bignum) then 2237 Right := Convert_To_Bignum (Right); 2238 end if; 2239 2240 -- We rewrite our node with: 2241 2242 -- do 2243 -- Bnn : Result_Type; 2244 -- declare 2245 -- M : Mark_Id := SS_Mark; 2246 -- begin 2247 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc) 2248 -- SS_Release (M); 2249 -- end; 2250 -- in 2251 -- Bnn 2252 -- end 2253 2254 declare 2255 Blk : constant Node_Id := Make_Bignum_Block (Loc); 2256 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 2257 Ent : RE_Id; 2258 2259 begin 2260 case N_Op_Compare (Nkind (N)) is 2261 when N_Op_Eq => Ent := RE_Big_EQ; 2262 when N_Op_Ge => Ent := RE_Big_GE; 2263 when N_Op_Gt => Ent := RE_Big_GT; 2264 when N_Op_Le => Ent := RE_Big_LE; 2265 when N_Op_Lt => Ent := RE_Big_LT; 2266 when N_Op_Ne => Ent := RE_Big_NE; 2267 end case; 2268 2269 -- Insert assignment to Bnn into the bignum block 2270 2271 Insert_Before 2272 (First (Statements (Handled_Statement_Sequence (Blk))), 2273 Make_Assignment_Statement (Loc, 2274 Name => New_Occurrence_Of (Bnn, Loc), 2275 Expression => 2276 Make_Function_Call (Loc, 2277 Name => 2278 New_Occurrence_Of (RTE (Ent), Loc), 2279 Parameter_Associations => New_List (Left, Right)))); 2280 2281 -- Now do the rewrite with expression actions 2282 2283 Rewrite (N, 2284 Make_Expression_With_Actions (Loc, 2285 Actions => New_List ( 2286 Make_Object_Declaration (Loc, 2287 Defining_Identifier => Bnn, 2288 Object_Definition => 2289 New_Occurrence_Of (Result_Type, Loc)), 2290 Blk), 2291 Expression => New_Occurrence_Of (Bnn, Loc))); 2292 Analyze_And_Resolve (N, Result_Type); 2293 end; 2294 end; 2295 2296 -- No bignums involved, but types are different, so we must have 2297 -- rewritten one of the operands as a Long_Long_Integer but not 2298 -- the other one. 2299 2300 -- If left operand is Long_Long_Integer, convert right operand 2301 -- and we are done (with a comparison of two Long_Long_Integers). 2302 2303 elsif Ltype = LLIB then 2304 Convert_To_And_Rewrite (LLIB, Right_Opnd (N)); 2305 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks); 2306 return; 2307 2308 -- If right operand is Long_Long_Integer, convert left operand 2309 -- and we are done (with a comparison of two Long_Long_Integers). 2310 2311 -- This is the only remaining possibility 2312 2313 else pragma Assert (Rtype = LLIB); 2314 Convert_To_And_Rewrite (LLIB, Left_Opnd (N)); 2315 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks); 2316 return; 2317 end if; 2318 end; 2319 end Expand_Compare_Minimize_Eliminate_Overflow; 2320 2321 ------------------------------- 2322 -- Expand_Composite_Equality -- 2323 ------------------------------- 2324 2325 -- This function is only called for comparing internal fields of composite 2326 -- types when these fields are themselves composites. This is a special 2327 -- case because it is not possible to respect normal Ada visibility rules. 2328 2329 function Expand_Composite_Equality 2330 (Nod : Node_Id; 2331 Typ : Entity_Id; 2332 Lhs : Node_Id; 2333 Rhs : Node_Id; 2334 Bodies : List_Id) return Node_Id 2335 is 2336 Loc : constant Source_Ptr := Sloc (Nod); 2337 Full_Type : Entity_Id; 2338 Prim : Elmt_Id; 2339 Eq_Op : Entity_Id; 2340 2341 function Find_Primitive_Eq return Node_Id; 2342 -- AI05-0123: Locate primitive equality for type if it exists, and 2343 -- build the corresponding call. If operation is abstract, replace 2344 -- call with an explicit raise. Return Empty if there is no primitive. 2345 2346 ----------------------- 2347 -- Find_Primitive_Eq -- 2348 ----------------------- 2349 2350 function Find_Primitive_Eq return Node_Id is 2351 Prim_E : Elmt_Id; 2352 Prim : Node_Id; 2353 2354 begin 2355 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); 2356 while Present (Prim_E) loop 2357 Prim := Node (Prim_E); 2358 2359 -- Locate primitive equality with the right signature 2360 2361 if Chars (Prim) = Name_Op_Eq 2362 and then Etype (First_Formal (Prim)) = 2363 Etype (Next_Formal (First_Formal (Prim))) 2364 and then Etype (Prim) = Standard_Boolean 2365 then 2366 if Is_Abstract_Subprogram (Prim) then 2367 return 2368 Make_Raise_Program_Error (Loc, 2369 Reason => PE_Explicit_Raise); 2370 2371 else 2372 return 2373 Make_Function_Call (Loc, 2374 Name => New_Occurrence_Of (Prim, Loc), 2375 Parameter_Associations => New_List (Lhs, Rhs)); 2376 end if; 2377 end if; 2378 2379 Next_Elmt (Prim_E); 2380 end loop; 2381 2382 -- If not found, predefined operation will be used 2383 2384 return Empty; 2385 end Find_Primitive_Eq; 2386 2387 -- Start of processing for Expand_Composite_Equality 2388 2389 begin 2390 if Is_Private_Type (Typ) then 2391 Full_Type := Underlying_Type (Typ); 2392 else 2393 Full_Type := Typ; 2394 end if; 2395 2396 -- If the private type has no completion the context may be the 2397 -- expansion of a composite equality for a composite type with some 2398 -- still incomplete components. The expression will not be analyzed 2399 -- until the enclosing type is completed, at which point this will be 2400 -- properly expanded, unless there is a bona fide completion error. 2401 2402 if No (Full_Type) then 2403 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2404 end if; 2405 2406 Full_Type := Base_Type (Full_Type); 2407 2408 -- When the base type itself is private, use the full view to expand 2409 -- the composite equality. 2410 2411 if Is_Private_Type (Full_Type) then 2412 Full_Type := Underlying_Type (Full_Type); 2413 end if; 2414 2415 -- Case of array types 2416 2417 if Is_Array_Type (Full_Type) then 2418 2419 -- If the operand is an elementary type other than a floating-point 2420 -- type, then we can simply use the built-in block bitwise equality, 2421 -- since the predefined equality operators always apply and bitwise 2422 -- equality is fine for all these cases. 2423 2424 if Is_Elementary_Type (Component_Type (Full_Type)) 2425 and then not Is_Floating_Point_Type (Component_Type (Full_Type)) 2426 then 2427 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2428 2429 -- For composite component types, and floating-point types, use the 2430 -- expansion. This deals with tagged component types (where we use 2431 -- the applicable equality routine) and floating-point, (where we 2432 -- need to worry about negative zeroes), and also the case of any 2433 -- composite type recursively containing such fields. 2434 2435 else 2436 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type); 2437 end if; 2438 2439 -- Case of tagged record types 2440 2441 elsif Is_Tagged_Type (Full_Type) then 2442 2443 -- Call the primitive operation "=" of this type 2444 2445 if Is_Class_Wide_Type (Full_Type) then 2446 Full_Type := Root_Type (Full_Type); 2447 end if; 2448 2449 -- If this is derived from an untagged private type completed with a 2450 -- tagged type, it does not have a full view, so we use the primitive 2451 -- operations of the private type. This check should no longer be 2452 -- necessary when these types receive their full views ??? 2453 2454 if Is_Private_Type (Typ) 2455 and then not Is_Tagged_Type (Typ) 2456 and then not Is_Controlled (Typ) 2457 and then Is_Derived_Type (Typ) 2458 and then No (Full_View (Typ)) 2459 then 2460 Prim := First_Elmt (Collect_Primitive_Operations (Typ)); 2461 else 2462 Prim := First_Elmt (Primitive_Operations (Full_Type)); 2463 end if; 2464 2465 loop 2466 Eq_Op := Node (Prim); 2467 exit when Chars (Eq_Op) = Name_Op_Eq 2468 and then Etype (First_Formal (Eq_Op)) = 2469 Etype (Next_Formal (First_Formal (Eq_Op))) 2470 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean; 2471 Next_Elmt (Prim); 2472 pragma Assert (Present (Prim)); 2473 end loop; 2474 2475 Eq_Op := Node (Prim); 2476 2477 return 2478 Make_Function_Call (Loc, 2479 Name => New_Occurrence_Of (Eq_Op, Loc), 2480 Parameter_Associations => 2481 New_List 2482 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), 2483 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); 2484 2485 -- Case of untagged record types 2486 2487 elsif Is_Record_Type (Full_Type) then 2488 Eq_Op := TSS (Full_Type, TSS_Composite_Equality); 2489 2490 if Present (Eq_Op) then 2491 if Etype (First_Formal (Eq_Op)) /= Full_Type then 2492 2493 -- Inherited equality from parent type. Convert the actuals to 2494 -- match signature of operation. 2495 2496 declare 2497 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2498 2499 begin 2500 return 2501 Make_Function_Call (Loc, 2502 Name => New_Occurrence_Of (Eq_Op, Loc), 2503 Parameter_Associations => New_List ( 2504 OK_Convert_To (T, Lhs), 2505 OK_Convert_To (T, Rhs))); 2506 end; 2507 2508 else 2509 -- Comparison between Unchecked_Union components 2510 2511 if Is_Unchecked_Union (Full_Type) then 2512 declare 2513 Lhs_Type : Node_Id := Full_Type; 2514 Rhs_Type : Node_Id := Full_Type; 2515 Lhs_Discr_Val : Node_Id; 2516 Rhs_Discr_Val : Node_Id; 2517 2518 begin 2519 -- Lhs subtype 2520 2521 if Nkind (Lhs) = N_Selected_Component then 2522 Lhs_Type := Etype (Entity (Selector_Name (Lhs))); 2523 end if; 2524 2525 -- Rhs subtype 2526 2527 if Nkind (Rhs) = N_Selected_Component then 2528 Rhs_Type := Etype (Entity (Selector_Name (Rhs))); 2529 end if; 2530 2531 -- Lhs of the composite equality 2532 2533 if Is_Constrained (Lhs_Type) then 2534 2535 -- Since the enclosing record type can never be an 2536 -- Unchecked_Union (this code is executed for records 2537 -- that do not have variants), we may reference its 2538 -- discriminant(s). 2539 2540 if Nkind (Lhs) = N_Selected_Component 2541 and then Has_Per_Object_Constraint 2542 (Entity (Selector_Name (Lhs))) 2543 then 2544 Lhs_Discr_Val := 2545 Make_Selected_Component (Loc, 2546 Prefix => Prefix (Lhs), 2547 Selector_Name => 2548 New_Copy 2549 (Get_Discriminant_Value 2550 (First_Discriminant (Lhs_Type), 2551 Lhs_Type, 2552 Stored_Constraint (Lhs_Type)))); 2553 2554 else 2555 Lhs_Discr_Val := 2556 New_Copy 2557 (Get_Discriminant_Value 2558 (First_Discriminant (Lhs_Type), 2559 Lhs_Type, 2560 Stored_Constraint (Lhs_Type))); 2561 2562 end if; 2563 else 2564 -- It is not possible to infer the discriminant since 2565 -- the subtype is not constrained. 2566 2567 return 2568 Make_Raise_Program_Error (Loc, 2569 Reason => PE_Unchecked_Union_Restriction); 2570 end if; 2571 2572 -- Rhs of the composite equality 2573 2574 if Is_Constrained (Rhs_Type) then 2575 if Nkind (Rhs) = N_Selected_Component 2576 and then Has_Per_Object_Constraint 2577 (Entity (Selector_Name (Rhs))) 2578 then 2579 Rhs_Discr_Val := 2580 Make_Selected_Component (Loc, 2581 Prefix => Prefix (Rhs), 2582 Selector_Name => 2583 New_Copy 2584 (Get_Discriminant_Value 2585 (First_Discriminant (Rhs_Type), 2586 Rhs_Type, 2587 Stored_Constraint (Rhs_Type)))); 2588 2589 else 2590 Rhs_Discr_Val := 2591 New_Copy 2592 (Get_Discriminant_Value 2593 (First_Discriminant (Rhs_Type), 2594 Rhs_Type, 2595 Stored_Constraint (Rhs_Type))); 2596 2597 end if; 2598 else 2599 return 2600 Make_Raise_Program_Error (Loc, 2601 Reason => PE_Unchecked_Union_Restriction); 2602 end if; 2603 2604 -- Call the TSS equality function with the inferred 2605 -- discriminant values. 2606 2607 return 2608 Make_Function_Call (Loc, 2609 Name => New_Occurrence_Of (Eq_Op, Loc), 2610 Parameter_Associations => New_List ( 2611 Lhs, 2612 Rhs, 2613 Lhs_Discr_Val, 2614 Rhs_Discr_Val)); 2615 end; 2616 2617 -- All cases other than comparing Unchecked_Union types 2618 2619 else 2620 declare 2621 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2622 begin 2623 return 2624 Make_Function_Call (Loc, 2625 Name => 2626 New_Occurrence_Of (Eq_Op, Loc), 2627 Parameter_Associations => New_List ( 2628 OK_Convert_To (T, Lhs), 2629 OK_Convert_To (T, Rhs))); 2630 end; 2631 end if; 2632 end if; 2633 2634 -- Equality composes in Ada 2012 for untagged record types. It also 2635 -- composes for bounded strings, because they are part of the 2636 -- predefined environment. We could make it compose for bounded 2637 -- strings by making them tagged, or by making sure all subcomponents 2638 -- are set to the same value, even when not used. Instead, we have 2639 -- this special case in the compiler, because it's more efficient. 2640 2641 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then 2642 2643 -- If no TSS has been created for the type, check whether there is 2644 -- a primitive equality declared for it. 2645 2646 declare 2647 Op : constant Node_Id := Find_Primitive_Eq; 2648 2649 begin 2650 -- Use user-defined primitive if it exists, otherwise use 2651 -- predefined equality. 2652 2653 if Present (Op) then 2654 return Op; 2655 else 2656 return Make_Op_Eq (Loc, Lhs, Rhs); 2657 end if; 2658 end; 2659 2660 else 2661 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); 2662 end if; 2663 2664 -- Non-composite types (always use predefined equality) 2665 2666 else 2667 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2668 end if; 2669 end Expand_Composite_Equality; 2670 2671 ------------------------ 2672 -- Expand_Concatenate -- 2673 ------------------------ 2674 2675 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is 2676 Loc : constant Source_Ptr := Sloc (Cnode); 2677 2678 Atyp : constant Entity_Id := Base_Type (Etype (Cnode)); 2679 -- Result type of concatenation 2680 2681 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode))); 2682 -- Component type. Elements of this component type can appear as one 2683 -- of the operands of concatenation as well as arrays. 2684 2685 Istyp : constant Entity_Id := Etype (First_Index (Atyp)); 2686 -- Index subtype 2687 2688 Ityp : constant Entity_Id := Base_Type (Istyp); 2689 -- Index type. This is the base type of the index subtype, and is used 2690 -- for all computed bounds (which may be out of range of Istyp in the 2691 -- case of null ranges). 2692 2693 Artyp : Entity_Id; 2694 -- This is the type we use to do arithmetic to compute the bounds and 2695 -- lengths of operands. The choice of this type is a little subtle and 2696 -- is discussed in a separate section at the start of the body code. 2697 2698 Concatenation_Error : exception; 2699 -- Raised if concatenation is sure to raise a CE 2700 2701 Result_May_Be_Null : Boolean := True; 2702 -- Reset to False if at least one operand is encountered which is known 2703 -- at compile time to be non-null. Used for handling the special case 2704 -- of setting the high bound to the last operand high bound for a null 2705 -- result, thus ensuring a proper high bound in the super-flat case. 2706 2707 N : constant Nat := List_Length (Opnds); 2708 -- Number of concatenation operands including possibly null operands 2709 2710 NN : Nat := 0; 2711 -- Number of operands excluding any known to be null, except that the 2712 -- last operand is always retained, in case it provides the bounds for 2713 -- a null result. 2714 2715 Opnd : Node_Id := Empty; 2716 -- Current operand being processed in the loop through operands. After 2717 -- this loop is complete, always contains the last operand (which is not 2718 -- the same as Operands (NN), since null operands are skipped). 2719 2720 -- Arrays describing the operands, only the first NN entries of each 2721 -- array are set (NN < N when we exclude known null operands). 2722 2723 Is_Fixed_Length : array (1 .. N) of Boolean; 2724 -- True if length of corresponding operand known at compile time 2725 2726 Operands : array (1 .. N) of Node_Id; 2727 -- Set to the corresponding entry in the Opnds list (but note that null 2728 -- operands are excluded, so not all entries in the list are stored). 2729 2730 Fixed_Length : array (1 .. N) of Uint; 2731 -- Set to length of operand. Entries in this array are set only if the 2732 -- corresponding entry in Is_Fixed_Length is True. 2733 2734 Opnd_Low_Bound : array (1 .. N) of Node_Id; 2735 -- Set to lower bound of operand. Either an integer literal in the case 2736 -- where the bound is known at compile time, else actual lower bound. 2737 -- The operand low bound is of type Ityp. 2738 2739 Var_Length : array (1 .. N) of Entity_Id; 2740 -- Set to an entity of type Natural that contains the length of an 2741 -- operand whose length is not known at compile time. Entries in this 2742 -- array are set only if the corresponding entry in Is_Fixed_Length 2743 -- is False. The entity is of type Artyp. 2744 2745 Aggr_Length : array (0 .. N) of Node_Id; 2746 -- The J'th entry in an expression node that represents the total length 2747 -- of operands 1 through J. It is either an integer literal node, or a 2748 -- reference to a constant entity with the right value, so it is fine 2749 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th 2750 -- entry always is set to zero. The length is of type Artyp. 2751 2752 Low_Bound : Node_Id; 2753 -- A tree node representing the low bound of the result (of type Ityp). 2754 -- This is either an integer literal node, or an identifier reference to 2755 -- a constant entity initialized to the appropriate value. 2756 2757 Last_Opnd_Low_Bound : Node_Id := Empty; 2758 -- A tree node representing the low bound of the last operand. This 2759 -- need only be set if the result could be null. It is used for the 2760 -- special case of setting the right low bound for a null result. 2761 -- This is of type Ityp. 2762 2763 Last_Opnd_High_Bound : Node_Id := Empty; 2764 -- A tree node representing the high bound of the last operand. This 2765 -- need only be set if the result could be null. It is used for the 2766 -- special case of setting the right high bound for a null result. 2767 -- This is of type Ityp. 2768 2769 High_Bound : Node_Id := Empty; 2770 -- A tree node representing the high bound of the result (of type Ityp) 2771 2772 Result : Node_Id; 2773 -- Result of the concatenation (of type Ityp) 2774 2775 Actions : constant List_Id := New_List; 2776 -- Collect actions to be inserted 2777 2778 Known_Non_Null_Operand_Seen : Boolean; 2779 -- Set True during generation of the assignments of operands into 2780 -- result once an operand known to be non-null has been seen. 2781 2782 function Library_Level_Target return Boolean; 2783 -- Return True if the concatenation is within the expression of the 2784 -- declaration of a library-level object. 2785 2786 function Make_Artyp_Literal (Val : Nat) return Node_Id; 2787 -- This function makes an N_Integer_Literal node that is returned in 2788 -- analyzed form with the type set to Artyp. Importantly this literal 2789 -- is not flagged as static, so that if we do computations with it that 2790 -- result in statically detected out of range conditions, we will not 2791 -- generate error messages but instead warning messages. 2792 2793 function To_Artyp (X : Node_Id) return Node_Id; 2794 -- Given a node of type Ityp, returns the corresponding value of type 2795 -- Artyp. For non-enumeration types, this is a plain integer conversion. 2796 -- For enum types, the Pos of the value is returned. 2797 2798 function To_Ityp (X : Node_Id) return Node_Id; 2799 -- The inverse function (uses Val in the case of enumeration types) 2800 2801 -------------------------- 2802 -- Library_Level_Target -- 2803 -------------------------- 2804 2805 function Library_Level_Target return Boolean is 2806 P : Node_Id := Parent (Cnode); 2807 2808 begin 2809 while Present (P) loop 2810 if Nkind (P) = N_Object_Declaration then 2811 return Is_Library_Level_Entity (Defining_Identifier (P)); 2812 2813 -- Prevent the search from going too far 2814 2815 elsif Is_Body_Or_Package_Declaration (P) then 2816 return False; 2817 end if; 2818 2819 P := Parent (P); 2820 end loop; 2821 2822 return False; 2823 end Library_Level_Target; 2824 2825 ------------------------ 2826 -- Make_Artyp_Literal -- 2827 ------------------------ 2828 2829 function Make_Artyp_Literal (Val : Nat) return Node_Id is 2830 Result : constant Node_Id := Make_Integer_Literal (Loc, Val); 2831 begin 2832 Set_Etype (Result, Artyp); 2833 Set_Analyzed (Result, True); 2834 Set_Is_Static_Expression (Result, False); 2835 return Result; 2836 end Make_Artyp_Literal; 2837 2838 -------------- 2839 -- To_Artyp -- 2840 -------------- 2841 2842 function To_Artyp (X : Node_Id) return Node_Id is 2843 begin 2844 if Ityp = Base_Type (Artyp) then 2845 return X; 2846 2847 elsif Is_Enumeration_Type (Ityp) then 2848 return 2849 Make_Attribute_Reference (Loc, 2850 Prefix => New_Occurrence_Of (Ityp, Loc), 2851 Attribute_Name => Name_Pos, 2852 Expressions => New_List (X)); 2853 2854 else 2855 return Convert_To (Artyp, X); 2856 end if; 2857 end To_Artyp; 2858 2859 ------------- 2860 -- To_Ityp -- 2861 ------------- 2862 2863 function To_Ityp (X : Node_Id) return Node_Id is 2864 begin 2865 if Is_Enumeration_Type (Ityp) then 2866 return 2867 Make_Attribute_Reference (Loc, 2868 Prefix => New_Occurrence_Of (Ityp, Loc), 2869 Attribute_Name => Name_Val, 2870 Expressions => New_List (X)); 2871 2872 -- Case where we will do a type conversion 2873 2874 else 2875 if Ityp = Base_Type (Artyp) then 2876 return X; 2877 else 2878 return Convert_To (Ityp, X); 2879 end if; 2880 end if; 2881 end To_Ityp; 2882 2883 -- Local Declarations 2884 2885 Opnd_Typ : Entity_Id; 2886 Ent : Entity_Id; 2887 Len : Uint; 2888 J : Nat; 2889 Clen : Node_Id; 2890 Set : Boolean; 2891 2892 -- Start of processing for Expand_Concatenate 2893 2894 begin 2895 -- Choose an appropriate computational type 2896 2897 -- We will be doing calculations of lengths and bounds in this routine 2898 -- and computing one from the other in some cases, e.g. getting the high 2899 -- bound by adding the length-1 to the low bound. 2900 2901 -- We can't just use the index type, or even its base type for this 2902 -- purpose for two reasons. First it might be an enumeration type which 2903 -- is not suitable for computations of any kind, and second it may 2904 -- simply not have enough range. For example if the index type is 2905 -- -128..+127 then lengths can be up to 256, which is out of range of 2906 -- the type. 2907 2908 -- For enumeration types, we can simply use Standard_Integer, this is 2909 -- sufficient since the actual number of enumeration literals cannot 2910 -- possibly exceed the range of integer (remember we will be doing the 2911 -- arithmetic with POS values, not representation values). 2912 2913 if Is_Enumeration_Type (Ityp) then 2914 Artyp := Standard_Integer; 2915 2916 -- If index type is Positive, we use the standard unsigned type, to give 2917 -- more room on the top of the range, obviating the need for an overflow 2918 -- check when creating the upper bound. This is needed to avoid junk 2919 -- overflow checks in the common case of String types. 2920 2921 -- ??? Disabled for now 2922 2923 -- elsif Istyp = Standard_Positive then 2924 -- Artyp := Standard_Unsigned; 2925 2926 -- For modular types, we use a 32-bit modular type for types whose size 2927 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the 2928 -- identity type, and for larger unsigned types we use 64-bits. 2929 2930 elsif Is_Modular_Integer_Type (Ityp) then 2931 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then 2932 Artyp := Standard_Unsigned; 2933 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then 2934 Artyp := Ityp; 2935 else 2936 Artyp := RTE (RE_Long_Long_Unsigned); 2937 end if; 2938 2939 -- Similar treatment for signed types 2940 2941 else 2942 if RM_Size (Ityp) < RM_Size (Standard_Integer) then 2943 Artyp := Standard_Integer; 2944 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then 2945 Artyp := Ityp; 2946 else 2947 Artyp := Standard_Long_Long_Integer; 2948 end if; 2949 end if; 2950 2951 -- Supply dummy entry at start of length array 2952 2953 Aggr_Length (0) := Make_Artyp_Literal (0); 2954 2955 -- Go through operands setting up the above arrays 2956 2957 J := 1; 2958 while J <= N loop 2959 Opnd := Remove_Head (Opnds); 2960 Opnd_Typ := Etype (Opnd); 2961 2962 -- The parent got messed up when we put the operands in a list, 2963 -- so now put back the proper parent for the saved operand, that 2964 -- is to say the concatenation node, to make sure that each operand 2965 -- is seen as a subexpression, e.g. if actions must be inserted. 2966 2967 Set_Parent (Opnd, Cnode); 2968 2969 -- Set will be True when we have setup one entry in the array 2970 2971 Set := False; 2972 2973 -- Singleton element (or character literal) case 2974 2975 if Base_Type (Opnd_Typ) = Ctyp then 2976 NN := NN + 1; 2977 Operands (NN) := Opnd; 2978 Is_Fixed_Length (NN) := True; 2979 Fixed_Length (NN) := Uint_1; 2980 Result_May_Be_Null := False; 2981 2982 -- Set low bound of operand (no need to set Last_Opnd_High_Bound 2983 -- since we know that the result cannot be null). 2984 2985 Opnd_Low_Bound (NN) := 2986 Make_Attribute_Reference (Loc, 2987 Prefix => New_Occurrence_Of (Istyp, Loc), 2988 Attribute_Name => Name_First); 2989 2990 Set := True; 2991 2992 -- String literal case (can only occur for strings of course) 2993 2994 elsif Nkind (Opnd) = N_String_Literal then 2995 Len := String_Literal_Length (Opnd_Typ); 2996 2997 if Len /= 0 then 2998 Result_May_Be_Null := False; 2999 end if; 3000 3001 -- Capture last operand low and high bound if result could be null 3002 3003 if J = N and then Result_May_Be_Null then 3004 Last_Opnd_Low_Bound := 3005 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3006 3007 Last_Opnd_High_Bound := 3008 Make_Op_Subtract (Loc, 3009 Left_Opnd => 3010 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), 3011 Right_Opnd => Make_Integer_Literal (Loc, 1)); 3012 end if; 3013 3014 -- Skip null string literal 3015 3016 if J < N and then Len = 0 then 3017 goto Continue; 3018 end if; 3019 3020 NN := NN + 1; 3021 Operands (NN) := Opnd; 3022 Is_Fixed_Length (NN) := True; 3023 3024 -- Set length and bounds 3025 3026 Fixed_Length (NN) := Len; 3027 3028 Opnd_Low_Bound (NN) := 3029 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3030 3031 Set := True; 3032 3033 -- All other cases 3034 3035 else 3036 -- Check constrained case with known bounds 3037 3038 if Is_Constrained (Opnd_Typ) then 3039 declare 3040 Index : constant Node_Id := First_Index (Opnd_Typ); 3041 Indx_Typ : constant Entity_Id := Etype (Index); 3042 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ); 3043 Hi : constant Node_Id := Type_High_Bound (Indx_Typ); 3044 3045 begin 3046 -- Fixed length constrained array type with known at compile 3047 -- time bounds is last case of fixed length operand. 3048 3049 if Compile_Time_Known_Value (Lo) 3050 and then 3051 Compile_Time_Known_Value (Hi) 3052 then 3053 declare 3054 Loval : constant Uint := Expr_Value (Lo); 3055 Hival : constant Uint := Expr_Value (Hi); 3056 Len : constant Uint := 3057 UI_Max (Hival - Loval + 1, Uint_0); 3058 3059 begin 3060 if Len > 0 then 3061 Result_May_Be_Null := False; 3062 end if; 3063 3064 -- Capture last operand bounds if result could be null 3065 3066 if J = N and then Result_May_Be_Null then 3067 Last_Opnd_Low_Bound := 3068 Convert_To (Ityp, 3069 Make_Integer_Literal (Loc, Expr_Value (Lo))); 3070 3071 Last_Opnd_High_Bound := 3072 Convert_To (Ityp, 3073 Make_Integer_Literal (Loc, Expr_Value (Hi))); 3074 end if; 3075 3076 -- Exclude null length case unless last operand 3077 3078 if J < N and then Len = 0 then 3079 goto Continue; 3080 end if; 3081 3082 NN := NN + 1; 3083 Operands (NN) := Opnd; 3084 Is_Fixed_Length (NN) := True; 3085 Fixed_Length (NN) := Len; 3086 3087 Opnd_Low_Bound (NN) := 3088 To_Ityp 3089 (Make_Integer_Literal (Loc, Expr_Value (Lo))); 3090 Set := True; 3091 end; 3092 end if; 3093 end; 3094 end if; 3095 3096 -- All cases where the length is not known at compile time, or the 3097 -- special case of an operand which is known to be null but has a 3098 -- lower bound other than 1 or is other than a string type. 3099 3100 if not Set then 3101 NN := NN + 1; 3102 3103 -- Capture operand bounds 3104 3105 Opnd_Low_Bound (NN) := 3106 Make_Attribute_Reference (Loc, 3107 Prefix => 3108 Duplicate_Subexpr (Opnd, Name_Req => True), 3109 Attribute_Name => Name_First); 3110 3111 -- Capture last operand bounds if result could be null 3112 3113 if J = N and Result_May_Be_Null then 3114 Last_Opnd_Low_Bound := 3115 Convert_To (Ityp, 3116 Make_Attribute_Reference (Loc, 3117 Prefix => 3118 Duplicate_Subexpr (Opnd, Name_Req => True), 3119 Attribute_Name => Name_First)); 3120 3121 Last_Opnd_High_Bound := 3122 Convert_To (Ityp, 3123 Make_Attribute_Reference (Loc, 3124 Prefix => 3125 Duplicate_Subexpr (Opnd, Name_Req => True), 3126 Attribute_Name => Name_Last)); 3127 end if; 3128 3129 -- Capture length of operand in entity 3130 3131 Operands (NN) := Opnd; 3132 Is_Fixed_Length (NN) := False; 3133 3134 Var_Length (NN) := Make_Temporary (Loc, 'L'); 3135 3136 Append_To (Actions, 3137 Make_Object_Declaration (Loc, 3138 Defining_Identifier => Var_Length (NN), 3139 Constant_Present => True, 3140 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3141 Expression => 3142 Make_Attribute_Reference (Loc, 3143 Prefix => 3144 Duplicate_Subexpr (Opnd, Name_Req => True), 3145 Attribute_Name => Name_Length))); 3146 end if; 3147 end if; 3148 3149 -- Set next entry in aggregate length array 3150 3151 -- For first entry, make either integer literal for fixed length 3152 -- or a reference to the saved length for variable length. 3153 3154 if NN = 1 then 3155 if Is_Fixed_Length (1) then 3156 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1)); 3157 else 3158 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc); 3159 end if; 3160 3161 -- If entry is fixed length and only fixed lengths so far, make 3162 -- appropriate new integer literal adding new length. 3163 3164 elsif Is_Fixed_Length (NN) 3165 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal 3166 then 3167 Aggr_Length (NN) := 3168 Make_Integer_Literal (Loc, 3169 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1))); 3170 3171 -- All other cases, construct an addition node for the length and 3172 -- create an entity initialized to this length. 3173 3174 else 3175 Ent := Make_Temporary (Loc, 'L'); 3176 3177 if Is_Fixed_Length (NN) then 3178 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); 3179 else 3180 Clen := New_Occurrence_Of (Var_Length (NN), Loc); 3181 end if; 3182 3183 Append_To (Actions, 3184 Make_Object_Declaration (Loc, 3185 Defining_Identifier => Ent, 3186 Constant_Present => True, 3187 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3188 Expression => 3189 Make_Op_Add (Loc, 3190 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)), 3191 Right_Opnd => Clen))); 3192 3193 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent)); 3194 end if; 3195 3196 <<Continue>> 3197 J := J + 1; 3198 end loop; 3199 3200 -- If we have only skipped null operands, return the last operand 3201 3202 if NN = 0 then 3203 Result := Opnd; 3204 goto Done; 3205 end if; 3206 3207 -- If we have only one non-null operand, return it and we are done. 3208 -- There is one case in which this cannot be done, and that is when 3209 -- the sole operand is of the element type, in which case it must be 3210 -- converted to an array, and the easiest way of doing that is to go 3211 -- through the normal general circuit. 3212 3213 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then 3214 Result := Operands (1); 3215 goto Done; 3216 end if; 3217 3218 -- Cases where we have a real concatenation 3219 3220 -- Next step is to find the low bound for the result array that we 3221 -- will allocate. The rules for this are in (RM 4.5.6(5-7)). 3222 3223 -- If the ultimate ancestor of the index subtype is a constrained array 3224 -- definition, then the lower bound is that of the index subtype as 3225 -- specified by (RM 4.5.3(6)). 3226 3227 -- The right test here is to go to the root type, and then the ultimate 3228 -- ancestor is the first subtype of this root type. 3229 3230 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then 3231 Low_Bound := 3232 Make_Attribute_Reference (Loc, 3233 Prefix => 3234 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc), 3235 Attribute_Name => Name_First); 3236 3237 -- If the first operand in the list has known length we know that 3238 -- the lower bound of the result is the lower bound of this operand. 3239 3240 elsif Is_Fixed_Length (1) then 3241 Low_Bound := Opnd_Low_Bound (1); 3242 3243 -- OK, we don't know the lower bound, we have to build a horrible 3244 -- if expression node of the form 3245 3246 -- if Cond1'Length /= 0 then 3247 -- Opnd1 low bound 3248 -- else 3249 -- if Opnd2'Length /= 0 then 3250 -- Opnd2 low bound 3251 -- else 3252 -- ... 3253 3254 -- The nesting ends either when we hit an operand whose length is known 3255 -- at compile time, or on reaching the last operand, whose low bound we 3256 -- take unconditionally whether or not it is null. It's easiest to do 3257 -- this with a recursive procedure: 3258 3259 else 3260 declare 3261 function Get_Known_Bound (J : Nat) return Node_Id; 3262 -- Returns the lower bound determined by operands J .. NN 3263 3264 --------------------- 3265 -- Get_Known_Bound -- 3266 --------------------- 3267 3268 function Get_Known_Bound (J : Nat) return Node_Id is 3269 begin 3270 if Is_Fixed_Length (J) or else J = NN then 3271 return New_Copy_Tree (Opnd_Low_Bound (J)); 3272 3273 else 3274 return 3275 Make_If_Expression (Loc, 3276 Expressions => New_List ( 3277 3278 Make_Op_Ne (Loc, 3279 Left_Opnd => 3280 New_Occurrence_Of (Var_Length (J), Loc), 3281 Right_Opnd => 3282 Make_Integer_Literal (Loc, 0)), 3283 3284 New_Copy_Tree (Opnd_Low_Bound (J)), 3285 Get_Known_Bound (J + 1))); 3286 end if; 3287 end Get_Known_Bound; 3288 3289 begin 3290 Ent := Make_Temporary (Loc, 'L'); 3291 3292 Append_To (Actions, 3293 Make_Object_Declaration (Loc, 3294 Defining_Identifier => Ent, 3295 Constant_Present => True, 3296 Object_Definition => New_Occurrence_Of (Ityp, Loc), 3297 Expression => Get_Known_Bound (1))); 3298 3299 Low_Bound := New_Occurrence_Of (Ent, Loc); 3300 end; 3301 end if; 3302 3303 -- Now we can safely compute the upper bound, normally 3304 -- Low_Bound + Length - 1. 3305 3306 High_Bound := 3307 To_Ityp 3308 (Make_Op_Add (Loc, 3309 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3310 Right_Opnd => 3311 Make_Op_Subtract (Loc, 3312 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3313 Right_Opnd => Make_Artyp_Literal (1)))); 3314 3315 -- Note that calculation of the high bound may cause overflow in some 3316 -- very weird cases, so in the general case we need an overflow check on 3317 -- the high bound. We can avoid this for the common case of string types 3318 -- and other types whose index is Positive, since we chose a wider range 3319 -- for the arithmetic type. If checks are suppressed we do not set the 3320 -- flag, and possibly superfluous warnings will be omitted. 3321 3322 if Istyp /= Standard_Positive 3323 and then not Overflow_Checks_Suppressed (Istyp) 3324 then 3325 Activate_Overflow_Check (High_Bound); 3326 end if; 3327 3328 -- Handle the exceptional case where the result is null, in which case 3329 -- case the bounds come from the last operand (so that we get the proper 3330 -- bounds if the last operand is super-flat). 3331 3332 if Result_May_Be_Null then 3333 Low_Bound := 3334 Make_If_Expression (Loc, 3335 Expressions => New_List ( 3336 Make_Op_Eq (Loc, 3337 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3338 Right_Opnd => Make_Artyp_Literal (0)), 3339 Last_Opnd_Low_Bound, 3340 Low_Bound)); 3341 3342 High_Bound := 3343 Make_If_Expression (Loc, 3344 Expressions => New_List ( 3345 Make_Op_Eq (Loc, 3346 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3347 Right_Opnd => Make_Artyp_Literal (0)), 3348 Last_Opnd_High_Bound, 3349 High_Bound)); 3350 end if; 3351 3352 -- Here is where we insert the saved up actions 3353 3354 Insert_Actions (Cnode, Actions, Suppress => All_Checks); 3355 3356 -- Now we construct an array object with appropriate bounds. We mark 3357 -- the target as internal to prevent useless initialization when 3358 -- Initialize_Scalars is enabled. Also since this is the actual result 3359 -- entity, we make sure we have debug information for the result. 3360 3361 Ent := Make_Temporary (Loc, 'S'); 3362 Set_Is_Internal (Ent); 3363 Set_Needs_Debug_Info (Ent); 3364 3365 -- If the bound is statically known to be out of range, we do not want 3366 -- to abort, we want a warning and a runtime constraint error. Note that 3367 -- we have arranged that the result will not be treated as a static 3368 -- constant, so we won't get an illegality during this insertion. 3369 3370 Insert_Action (Cnode, 3371 Make_Object_Declaration (Loc, 3372 Defining_Identifier => Ent, 3373 Object_Definition => 3374 Make_Subtype_Indication (Loc, 3375 Subtype_Mark => New_Occurrence_Of (Atyp, Loc), 3376 Constraint => 3377 Make_Index_Or_Discriminant_Constraint (Loc, 3378 Constraints => New_List ( 3379 Make_Range (Loc, 3380 Low_Bound => Low_Bound, 3381 High_Bound => High_Bound))))), 3382 Suppress => All_Checks); 3383 3384 -- If the result of the concatenation appears as the initializing 3385 -- expression of an object declaration, we can just rename the 3386 -- result, rather than copying it. 3387 3388 Set_OK_To_Rename (Ent); 3389 3390 -- Catch the static out of range case now 3391 3392 if Raises_Constraint_Error (High_Bound) then 3393 raise Concatenation_Error; 3394 end if; 3395 3396 -- Now we will generate the assignments to do the actual concatenation 3397 3398 -- There is one case in which we will not do this, namely when all the 3399 -- following conditions are met: 3400 3401 -- The result type is Standard.String 3402 3403 -- There are nine or fewer retained (non-null) operands 3404 3405 -- The optimization level is -O0 or the debug flag gnatd.C is set, 3406 -- and the debug flag gnatd.c is not set. 3407 3408 -- The corresponding System.Concat_n.Str_Concat_n routine is 3409 -- available in the run time. 3410 3411 -- If all these conditions are met then we generate a call to the 3412 -- relevant concatenation routine. The purpose of this is to avoid 3413 -- undesirable code bloat at -O0. 3414 3415 -- If the concatenation is within the declaration of a library-level 3416 -- object, we call the built-in concatenation routines to prevent code 3417 -- bloat, regardless of the optimization level. This is space efficient 3418 -- and prevents linking problems when units are compiled with different 3419 -- optimization levels. 3420 3421 if Atyp = Standard_String 3422 and then NN in 2 .. 9 3423 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC) 3424 and then not Debug_Flag_Dot_C) 3425 or else Library_Level_Target) 3426 then 3427 declare 3428 RR : constant array (Nat range 2 .. 9) of RE_Id := 3429 (RE_Str_Concat_2, 3430 RE_Str_Concat_3, 3431 RE_Str_Concat_4, 3432 RE_Str_Concat_5, 3433 RE_Str_Concat_6, 3434 RE_Str_Concat_7, 3435 RE_Str_Concat_8, 3436 RE_Str_Concat_9); 3437 3438 begin 3439 if RTE_Available (RR (NN)) then 3440 declare 3441 Opnds : constant List_Id := 3442 New_List (New_Occurrence_Of (Ent, Loc)); 3443 3444 begin 3445 for J in 1 .. NN loop 3446 if Is_List_Member (Operands (J)) then 3447 Remove (Operands (J)); 3448 end if; 3449 3450 if Base_Type (Etype (Operands (J))) = Ctyp then 3451 Append_To (Opnds, 3452 Make_Aggregate (Loc, 3453 Component_Associations => New_List ( 3454 Make_Component_Association (Loc, 3455 Choices => New_List ( 3456 Make_Integer_Literal (Loc, 1)), 3457 Expression => Operands (J))))); 3458 3459 else 3460 Append_To (Opnds, Operands (J)); 3461 end if; 3462 end loop; 3463 3464 Insert_Action (Cnode, 3465 Make_Procedure_Call_Statement (Loc, 3466 Name => New_Occurrence_Of (RTE (RR (NN)), Loc), 3467 Parameter_Associations => Opnds)); 3468 3469 Result := New_Occurrence_Of (Ent, Loc); 3470 goto Done; 3471 end; 3472 end if; 3473 end; 3474 end if; 3475 3476 -- Not special case so generate the assignments 3477 3478 Known_Non_Null_Operand_Seen := False; 3479 3480 for J in 1 .. NN loop 3481 declare 3482 Lo : constant Node_Id := 3483 Make_Op_Add (Loc, 3484 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3485 Right_Opnd => Aggr_Length (J - 1)); 3486 3487 Hi : constant Node_Id := 3488 Make_Op_Add (Loc, 3489 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3490 Right_Opnd => 3491 Make_Op_Subtract (Loc, 3492 Left_Opnd => Aggr_Length (J), 3493 Right_Opnd => Make_Artyp_Literal (1))); 3494 3495 begin 3496 -- Singleton case, simple assignment 3497 3498 if Base_Type (Etype (Operands (J))) = Ctyp then 3499 Known_Non_Null_Operand_Seen := True; 3500 Insert_Action (Cnode, 3501 Make_Assignment_Statement (Loc, 3502 Name => 3503 Make_Indexed_Component (Loc, 3504 Prefix => New_Occurrence_Of (Ent, Loc), 3505 Expressions => New_List (To_Ityp (Lo))), 3506 Expression => Operands (J)), 3507 Suppress => All_Checks); 3508 3509 -- Array case, slice assignment, skipped when argument is fixed 3510 -- length and known to be null. 3511 3512 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then 3513 declare 3514 Assign : Node_Id := 3515 Make_Assignment_Statement (Loc, 3516 Name => 3517 Make_Slice (Loc, 3518 Prefix => 3519 New_Occurrence_Of (Ent, Loc), 3520 Discrete_Range => 3521 Make_Range (Loc, 3522 Low_Bound => To_Ityp (Lo), 3523 High_Bound => To_Ityp (Hi))), 3524 Expression => Operands (J)); 3525 begin 3526 if Is_Fixed_Length (J) then 3527 Known_Non_Null_Operand_Seen := True; 3528 3529 elsif not Known_Non_Null_Operand_Seen then 3530 3531 -- Here if operand length is not statically known and no 3532 -- operand known to be non-null has been processed yet. 3533 -- If operand length is 0, we do not need to perform the 3534 -- assignment, and we must avoid the evaluation of the 3535 -- high bound of the slice, since it may underflow if the 3536 -- low bound is Ityp'First. 3537 3538 Assign := 3539 Make_Implicit_If_Statement (Cnode, 3540 Condition => 3541 Make_Op_Ne (Loc, 3542 Left_Opnd => 3543 New_Occurrence_Of (Var_Length (J), Loc), 3544 Right_Opnd => Make_Integer_Literal (Loc, 0)), 3545 Then_Statements => New_List (Assign)); 3546 end if; 3547 3548 Insert_Action (Cnode, Assign, Suppress => All_Checks); 3549 end; 3550 end if; 3551 end; 3552 end loop; 3553 3554 -- Finally we build the result, which is a reference to the array object 3555 3556 Result := New_Occurrence_Of (Ent, Loc); 3557 3558 <<Done>> 3559 Rewrite (Cnode, Result); 3560 Analyze_And_Resolve (Cnode, Atyp); 3561 3562 exception 3563 when Concatenation_Error => 3564 3565 -- Kill warning generated for the declaration of the static out of 3566 -- range high bound, and instead generate a Constraint_Error with 3567 -- an appropriate specific message. 3568 3569 Kill_Dead_Code (Declaration_Node (Entity (High_Bound))); 3570 Apply_Compile_Time_Constraint_Error 3571 (N => Cnode, 3572 Msg => "concatenation result upper bound out of range??", 3573 Reason => CE_Range_Check_Failed); 3574 end Expand_Concatenate; 3575 3576 --------------------------------------------------- 3577 -- Expand_Membership_Minimize_Eliminate_Overflow -- 3578 --------------------------------------------------- 3579 3580 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is 3581 pragma Assert (Nkind (N) = N_In); 3582 -- Despite the name, this routine applies only to N_In, not to 3583 -- N_Not_In. The latter is always rewritten as not (X in Y). 3584 3585 Result_Type : constant Entity_Id := Etype (N); 3586 -- Capture result type, may be a derived boolean type 3587 3588 Loc : constant Source_Ptr := Sloc (N); 3589 Lop : constant Node_Id := Left_Opnd (N); 3590 Rop : constant Node_Id := Right_Opnd (N); 3591 3592 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It 3593 -- is thus tempting to capture these values, but due to the rewrites 3594 -- that occur as a result of overflow checking, these values change 3595 -- as we go along, and it is safe just to always use Etype explicitly. 3596 3597 Restype : constant Entity_Id := Etype (N); 3598 -- Save result type 3599 3600 Lo, Hi : Uint; 3601 -- Bounds in Minimize calls, not used currently 3602 3603 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 3604 -- Entity for Long_Long_Integer'Base (Standard should export this???) 3605 3606 begin 3607 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False); 3608 3609 -- If right operand is a subtype name, and the subtype name has no 3610 -- predicate, then we can just replace the right operand with an 3611 -- explicit range T'First .. T'Last, and use the explicit range code. 3612 3613 if Nkind (Rop) /= N_Range 3614 and then No (Predicate_Function (Etype (Rop))) 3615 then 3616 declare 3617 Rtyp : constant Entity_Id := Etype (Rop); 3618 begin 3619 Rewrite (Rop, 3620 Make_Range (Loc, 3621 Low_Bound => 3622 Make_Attribute_Reference (Loc, 3623 Attribute_Name => Name_First, 3624 Prefix => New_Occurrence_Of (Rtyp, Loc)), 3625 High_Bound => 3626 Make_Attribute_Reference (Loc, 3627 Attribute_Name => Name_Last, 3628 Prefix => New_Occurrence_Of (Rtyp, Loc)))); 3629 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks); 3630 end; 3631 end if; 3632 3633 -- Here for the explicit range case. Note that the bounds of the range 3634 -- have not been processed for minimized or eliminated checks. 3635 3636 if Nkind (Rop) = N_Range then 3637 Minimize_Eliminate_Overflows 3638 (Low_Bound (Rop), Lo, Hi, Top_Level => False); 3639 Minimize_Eliminate_Overflows 3640 (High_Bound (Rop), Lo, Hi, Top_Level => False); 3641 3642 -- We have A in B .. C, treated as A >= B and then A <= C 3643 3644 -- Bignum case 3645 3646 if Is_RTE (Etype (Lop), RE_Bignum) 3647 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum) 3648 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum) 3649 then 3650 declare 3651 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3652 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3653 L : constant Entity_Id := 3654 Make_Defining_Identifier (Loc, Name_uL); 3655 Lopnd : constant Node_Id := Convert_To_Bignum (Lop); 3656 Lbound : constant Node_Id := 3657 Convert_To_Bignum (Low_Bound (Rop)); 3658 Hbound : constant Node_Id := 3659 Convert_To_Bignum (High_Bound (Rop)); 3660 3661 -- Now we rewrite the membership test node to look like 3662 3663 -- do 3664 -- Bnn : Result_Type; 3665 -- declare 3666 -- M : Mark_Id := SS_Mark; 3667 -- L : Bignum := Lopnd; 3668 -- begin 3669 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound) 3670 -- SS_Release (M); 3671 -- end; 3672 -- in 3673 -- Bnn 3674 -- end 3675 3676 begin 3677 -- Insert declaration of L into declarations of bignum block 3678 3679 Insert_After 3680 (Last (Declarations (Blk)), 3681 Make_Object_Declaration (Loc, 3682 Defining_Identifier => L, 3683 Object_Definition => 3684 New_Occurrence_Of (RTE (RE_Bignum), Loc), 3685 Expression => Lopnd)); 3686 3687 -- Insert assignment to Bnn into expressions of bignum block 3688 3689 Insert_Before 3690 (First (Statements (Handled_Statement_Sequence (Blk))), 3691 Make_Assignment_Statement (Loc, 3692 Name => New_Occurrence_Of (Bnn, Loc), 3693 Expression => 3694 Make_And_Then (Loc, 3695 Left_Opnd => 3696 Make_Function_Call (Loc, 3697 Name => 3698 New_Occurrence_Of (RTE (RE_Big_GE), Loc), 3699 Parameter_Associations => New_List ( 3700 New_Occurrence_Of (L, Loc), 3701 Lbound)), 3702 3703 Right_Opnd => 3704 Make_Function_Call (Loc, 3705 Name => 3706 New_Occurrence_Of (RTE (RE_Big_LE), Loc), 3707 Parameter_Associations => New_List ( 3708 New_Occurrence_Of (L, Loc), 3709 Hbound))))); 3710 3711 -- Now rewrite the node 3712 3713 Rewrite (N, 3714 Make_Expression_With_Actions (Loc, 3715 Actions => New_List ( 3716 Make_Object_Declaration (Loc, 3717 Defining_Identifier => Bnn, 3718 Object_Definition => 3719 New_Occurrence_Of (Result_Type, Loc)), 3720 Blk), 3721 Expression => New_Occurrence_Of (Bnn, Loc))); 3722 Analyze_And_Resolve (N, Result_Type); 3723 return; 3724 end; 3725 3726 -- Here if no bignums around 3727 3728 else 3729 -- Case where types are all the same 3730 3731 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop))) 3732 and then 3733 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop))) 3734 then 3735 null; 3736 3737 -- If types are not all the same, it means that we have rewritten 3738 -- at least one of them to be of type Long_Long_Integer, and we 3739 -- will convert the other operands to Long_Long_Integer. 3740 3741 else 3742 Convert_To_And_Rewrite (LLIB, Lop); 3743 Set_Analyzed (Lop, False); 3744 Analyze_And_Resolve (Lop, LLIB); 3745 3746 -- For the right operand, avoid unnecessary recursion into 3747 -- this routine, we know that overflow is not possible. 3748 3749 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop)); 3750 Convert_To_And_Rewrite (LLIB, High_Bound (Rop)); 3751 Set_Analyzed (Rop, False); 3752 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check); 3753 end if; 3754 3755 -- Now the three operands are of the same signed integer type, 3756 -- so we can use the normal expansion routine for membership, 3757 -- setting the flag to prevent recursion into this procedure. 3758 3759 Set_No_Minimize_Eliminate (N); 3760 Expand_N_In (N); 3761 end if; 3762 3763 -- Right operand is a subtype name and the subtype has a predicate. We 3764 -- have to make sure the predicate is checked, and for that we need to 3765 -- use the standard N_In circuitry with appropriate types. 3766 3767 else 3768 pragma Assert (Present (Predicate_Function (Etype (Rop)))); 3769 3770 -- If types are "right", just call Expand_N_In preventing recursion 3771 3772 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then 3773 Set_No_Minimize_Eliminate (N); 3774 Expand_N_In (N); 3775 3776 -- Bignum case 3777 3778 elsif Is_RTE (Etype (Lop), RE_Bignum) then 3779 3780 -- For X in T, we want to rewrite our node as 3781 3782 -- do 3783 -- Bnn : Result_Type; 3784 3785 -- declare 3786 -- M : Mark_Id := SS_Mark; 3787 -- Lnn : Long_Long_Integer'Base 3788 -- Nnn : Bignum; 3789 3790 -- begin 3791 -- Nnn := X; 3792 3793 -- if not Bignum_In_LLI_Range (Nnn) then 3794 -- Bnn := False; 3795 -- else 3796 -- Lnn := From_Bignum (Nnn); 3797 -- Bnn := 3798 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last) 3799 -- and then T'Base (Lnn) in T; 3800 -- end if; 3801 3802 -- SS_Release (M); 3803 -- end 3804 -- in 3805 -- Bnn 3806 -- end 3807 3808 -- A bit gruesome, but there doesn't seem to be a simpler way 3809 3810 declare 3811 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3812 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3813 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N); 3814 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N); 3815 T : constant Entity_Id := Etype (Rop); 3816 TB : constant Entity_Id := Base_Type (T); 3817 Nin : Node_Id; 3818 3819 begin 3820 -- Mark the last membership operation to prevent recursion 3821 3822 Nin := 3823 Make_In (Loc, 3824 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)), 3825 Right_Opnd => New_Occurrence_Of (T, Loc)); 3826 Set_No_Minimize_Eliminate (Nin); 3827 3828 -- Now decorate the block 3829 3830 Insert_After 3831 (Last (Declarations (Blk)), 3832 Make_Object_Declaration (Loc, 3833 Defining_Identifier => Lnn, 3834 Object_Definition => New_Occurrence_Of (LLIB, Loc))); 3835 3836 Insert_After 3837 (Last (Declarations (Blk)), 3838 Make_Object_Declaration (Loc, 3839 Defining_Identifier => Nnn, 3840 Object_Definition => 3841 New_Occurrence_Of (RTE (RE_Bignum), Loc))); 3842 3843 Insert_List_Before 3844 (First (Statements (Handled_Statement_Sequence (Blk))), 3845 New_List ( 3846 Make_Assignment_Statement (Loc, 3847 Name => New_Occurrence_Of (Nnn, Loc), 3848 Expression => Relocate_Node (Lop)), 3849 3850 Make_Implicit_If_Statement (N, 3851 Condition => 3852 Make_Op_Not (Loc, 3853 Right_Opnd => 3854 Make_Function_Call (Loc, 3855 Name => 3856 New_Occurrence_Of 3857 (RTE (RE_Bignum_In_LLI_Range), Loc), 3858 Parameter_Associations => New_List ( 3859 New_Occurrence_Of (Nnn, Loc)))), 3860 3861 Then_Statements => New_List ( 3862 Make_Assignment_Statement (Loc, 3863 Name => New_Occurrence_Of (Bnn, Loc), 3864 Expression => 3865 New_Occurrence_Of (Standard_False, Loc))), 3866 3867 Else_Statements => New_List ( 3868 Make_Assignment_Statement (Loc, 3869 Name => New_Occurrence_Of (Lnn, Loc), 3870 Expression => 3871 Make_Function_Call (Loc, 3872 Name => 3873 New_Occurrence_Of (RTE (RE_From_Bignum), Loc), 3874 Parameter_Associations => New_List ( 3875 New_Occurrence_Of (Nnn, Loc)))), 3876 3877 Make_Assignment_Statement (Loc, 3878 Name => New_Occurrence_Of (Bnn, Loc), 3879 Expression => 3880 Make_And_Then (Loc, 3881 Left_Opnd => 3882 Make_In (Loc, 3883 Left_Opnd => New_Occurrence_Of (Lnn, Loc), 3884 Right_Opnd => 3885 Make_Range (Loc, 3886 Low_Bound => 3887 Convert_To (LLIB, 3888 Make_Attribute_Reference (Loc, 3889 Attribute_Name => Name_First, 3890 Prefix => 3891 New_Occurrence_Of (TB, Loc))), 3892 3893 High_Bound => 3894 Convert_To (LLIB, 3895 Make_Attribute_Reference (Loc, 3896 Attribute_Name => Name_Last, 3897 Prefix => 3898 New_Occurrence_Of (TB, Loc))))), 3899 3900 Right_Opnd => Nin)))))); 3901 3902 -- Now we can do the rewrite 3903 3904 Rewrite (N, 3905 Make_Expression_With_Actions (Loc, 3906 Actions => New_List ( 3907 Make_Object_Declaration (Loc, 3908 Defining_Identifier => Bnn, 3909 Object_Definition => 3910 New_Occurrence_Of (Result_Type, Loc)), 3911 Blk), 3912 Expression => New_Occurrence_Of (Bnn, Loc))); 3913 Analyze_And_Resolve (N, Result_Type); 3914 return; 3915 end; 3916 3917 -- Not bignum case, but types don't match (this means we rewrote the 3918 -- left operand to be Long_Long_Integer). 3919 3920 else 3921 pragma Assert (Base_Type (Etype (Lop)) = LLIB); 3922 3923 -- We rewrite the membership test as (where T is the type with 3924 -- the predicate, i.e. the type of the right operand) 3925 3926 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last) 3927 -- and then T'Base (Lop) in T 3928 3929 declare 3930 T : constant Entity_Id := Etype (Rop); 3931 TB : constant Entity_Id := Base_Type (T); 3932 Nin : Node_Id; 3933 3934 begin 3935 -- The last membership test is marked to prevent recursion 3936 3937 Nin := 3938 Make_In (Loc, 3939 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)), 3940 Right_Opnd => New_Occurrence_Of (T, Loc)); 3941 Set_No_Minimize_Eliminate (Nin); 3942 3943 -- Now do the rewrite 3944 3945 Rewrite (N, 3946 Make_And_Then (Loc, 3947 Left_Opnd => 3948 Make_In (Loc, 3949 Left_Opnd => Lop, 3950 Right_Opnd => 3951 Make_Range (Loc, 3952 Low_Bound => 3953 Convert_To (LLIB, 3954 Make_Attribute_Reference (Loc, 3955 Attribute_Name => Name_First, 3956 Prefix => 3957 New_Occurrence_Of (TB, Loc))), 3958 High_Bound => 3959 Convert_To (LLIB, 3960 Make_Attribute_Reference (Loc, 3961 Attribute_Name => Name_Last, 3962 Prefix => 3963 New_Occurrence_Of (TB, Loc))))), 3964 Right_Opnd => Nin)); 3965 Set_Analyzed (N, False); 3966 Analyze_And_Resolve (N, Restype); 3967 end; 3968 end if; 3969 end if; 3970 end Expand_Membership_Minimize_Eliminate_Overflow; 3971 3972 --------------------------------- 3973 -- Expand_Nonbinary_Modular_Op -- 3974 --------------------------------- 3975 3976 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is 3977 Loc : constant Source_Ptr := Sloc (N); 3978 Typ : constant Entity_Id := Etype (N); 3979 3980 procedure Expand_Modular_Addition; 3981 -- Expand the modular addition, handling the special case of adding a 3982 -- constant. 3983 3984 procedure Expand_Modular_Op; 3985 -- Compute the general rule: (lhs OP rhs) mod Modulus 3986 3987 procedure Expand_Modular_Subtraction; 3988 -- Expand the modular addition, handling the special case of subtracting 3989 -- a constant. 3990 3991 ----------------------------- 3992 -- Expand_Modular_Addition -- 3993 ----------------------------- 3994 3995 procedure Expand_Modular_Addition is 3996 begin 3997 -- If this is not the addition of a constant then compute it using 3998 -- the general rule: (lhs + rhs) mod Modulus 3999 4000 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then 4001 Expand_Modular_Op; 4002 4003 -- If this is an addition of a constant, convert it to a subtraction 4004 -- plus a conditional expression since we can compute it faster than 4005 -- computing the modulus. 4006 4007 -- modMinusRhs = Modulus - rhs 4008 -- if lhs < modMinusRhs then lhs + rhs 4009 -- else lhs - modMinusRhs 4010 4011 else 4012 declare 4013 Mod_Minus_Right : constant Uint := 4014 Modulus (Typ) - Intval (Right_Opnd (N)); 4015 4016 Exprs : constant List_Id := New_List; 4017 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); 4018 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); 4019 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, 4020 Loc); 4021 begin 4022 Set_Left_Opnd (Cond_Expr, 4023 New_Copy_Tree (Left_Opnd (N))); 4024 Set_Right_Opnd (Cond_Expr, 4025 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4026 Append_To (Exprs, Cond_Expr); 4027 4028 Set_Left_Opnd (Then_Expr, 4029 Unchecked_Convert_To (Standard_Unsigned, 4030 New_Copy_Tree (Left_Opnd (N)))); 4031 Set_Right_Opnd (Then_Expr, 4032 Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); 4033 Append_To (Exprs, Then_Expr); 4034 4035 Set_Left_Opnd (Else_Expr, 4036 Unchecked_Convert_To (Standard_Unsigned, 4037 New_Copy_Tree (Left_Opnd (N)))); 4038 Set_Right_Opnd (Else_Expr, 4039 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4040 Append_To (Exprs, Else_Expr); 4041 4042 Rewrite (N, 4043 Unchecked_Convert_To (Typ, 4044 Make_If_Expression (Loc, Expressions => Exprs))); 4045 end; 4046 end if; 4047 end Expand_Modular_Addition; 4048 4049 ----------------------- 4050 -- Expand_Modular_Op -- 4051 ----------------------- 4052 4053 procedure Expand_Modular_Op is 4054 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc); 4055 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc); 4056 4057 begin 4058 -- Convert nonbinary modular type operands into integer values. Thus 4059 -- we avoid never-ending loops expanding them, and we also ensure 4060 -- the back end never receives nonbinary modular type expressions. 4061 4062 if Nkind_In (Nkind (N), N_Op_And, N_Op_Or) then 4063 Set_Left_Opnd (Op_Expr, 4064 Unchecked_Convert_To (Standard_Unsigned, 4065 New_Copy_Tree (Left_Opnd (N)))); 4066 Set_Right_Opnd (Op_Expr, 4067 Unchecked_Convert_To (Standard_Unsigned, 4068 New_Copy_Tree (Right_Opnd (N)))); 4069 Set_Left_Opnd (Mod_Expr, 4070 Unchecked_Convert_To (Standard_Integer, Op_Expr)); 4071 4072 else 4073 Set_Left_Opnd (Op_Expr, 4074 Unchecked_Convert_To (Standard_Integer, 4075 New_Copy_Tree (Left_Opnd (N)))); 4076 Set_Right_Opnd (Op_Expr, 4077 Unchecked_Convert_To (Standard_Integer, 4078 New_Copy_Tree (Right_Opnd (N)))); 4079 4080 -- Link this node to the tree to analyze it 4081 4082 -- If the parent node is an expression with actions we link it to 4083 -- N since otherwise Force_Evaluation cannot identify if this node 4084 -- comes from the Expression and rejects generating the temporary. 4085 4086 if Nkind (Parent (N)) = N_Expression_With_Actions then 4087 Set_Parent (Op_Expr, N); 4088 4089 -- Common case 4090 4091 else 4092 Set_Parent (Op_Expr, Parent (N)); 4093 end if; 4094 4095 Analyze (Op_Expr); 4096 4097 -- Force generating a temporary because in the expansion of this 4098 -- expression we may generate code that performs this computation 4099 -- several times. 4100 4101 Force_Evaluation (Op_Expr, Mode => Strict); 4102 4103 Set_Left_Opnd (Mod_Expr, Op_Expr); 4104 end if; 4105 4106 Set_Right_Opnd (Mod_Expr, 4107 Make_Integer_Literal (Loc, Modulus (Typ))); 4108 4109 Rewrite (N, 4110 Unchecked_Convert_To (Typ, Mod_Expr)); 4111 end Expand_Modular_Op; 4112 4113 -------------------------------- 4114 -- Expand_Modular_Subtraction -- 4115 -------------------------------- 4116 4117 procedure Expand_Modular_Subtraction is 4118 begin 4119 -- If this is not the addition of a constant then compute it using 4120 -- the general rule: (lhs + rhs) mod Modulus 4121 4122 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then 4123 Expand_Modular_Op; 4124 4125 -- If this is an addition of a constant, convert it to a subtraction 4126 -- plus a conditional expression since we can compute it faster than 4127 -- computing the modulus. 4128 4129 -- modMinusRhs = Modulus - rhs 4130 -- if lhs < rhs then lhs + modMinusRhs 4131 -- else lhs - rhs 4132 4133 else 4134 declare 4135 Mod_Minus_Right : constant Uint := 4136 Modulus (Typ) - Intval (Right_Opnd (N)); 4137 4138 Exprs : constant List_Id := New_List; 4139 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); 4140 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); 4141 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, 4142 Loc); 4143 begin 4144 Set_Left_Opnd (Cond_Expr, 4145 New_Copy_Tree (Left_Opnd (N))); 4146 Set_Right_Opnd (Cond_Expr, 4147 Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); 4148 Append_To (Exprs, Cond_Expr); 4149 4150 Set_Left_Opnd (Then_Expr, 4151 Unchecked_Convert_To (Standard_Unsigned, 4152 New_Copy_Tree (Left_Opnd (N)))); 4153 Set_Right_Opnd (Then_Expr, 4154 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4155 Append_To (Exprs, Then_Expr); 4156 4157 Set_Left_Opnd (Else_Expr, 4158 Unchecked_Convert_To (Standard_Unsigned, 4159 New_Copy_Tree (Left_Opnd (N)))); 4160 Set_Right_Opnd (Else_Expr, 4161 Unchecked_Convert_To (Standard_Unsigned, 4162 New_Copy_Tree (Right_Opnd (N)))); 4163 Append_To (Exprs, Else_Expr); 4164 4165 Rewrite (N, 4166 Unchecked_Convert_To (Typ, 4167 Make_If_Expression (Loc, Expressions => Exprs))); 4168 end; 4169 end if; 4170 end Expand_Modular_Subtraction; 4171 4172 -- Start of processing for Expand_Nonbinary_Modular_Op 4173 4174 begin 4175 -- No action needed if front-end expansion is not required or if we 4176 -- have a binary modular operand. 4177 4178 if not Expand_Nonbinary_Modular_Ops 4179 or else not Non_Binary_Modulus (Typ) 4180 then 4181 return; 4182 end if; 4183 4184 case Nkind (N) is 4185 when N_Op_Add => 4186 Expand_Modular_Addition; 4187 4188 when N_Op_Subtract => 4189 Expand_Modular_Subtraction; 4190 4191 when N_Op_Minus => 4192 4193 -- Expand -expr into (0 - expr) 4194 4195 Rewrite (N, 4196 Make_Op_Subtract (Loc, 4197 Left_Opnd => Make_Integer_Literal (Loc, 0), 4198 Right_Opnd => Right_Opnd (N))); 4199 Analyze_And_Resolve (N, Typ); 4200 4201 when others => 4202 Expand_Modular_Op; 4203 end case; 4204 4205 Analyze_And_Resolve (N, Typ); 4206 end Expand_Nonbinary_Modular_Op; 4207 4208 ------------------------ 4209 -- Expand_N_Allocator -- 4210 ------------------------ 4211 4212 procedure Expand_N_Allocator (N : Node_Id) is 4213 Etyp : constant Entity_Id := Etype (Expression (N)); 4214 Loc : constant Source_Ptr := Sloc (N); 4215 PtrT : constant Entity_Id := Etype (N); 4216 4217 procedure Rewrite_Coextension (N : Node_Id); 4218 -- Static coextensions have the same lifetime as the entity they 4219 -- constrain. Such occurrences can be rewritten as aliased objects 4220 -- and their unrestricted access used instead of the coextension. 4221 4222 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; 4223 -- Given a constrained array type E, returns a node representing the 4224 -- code to compute the size in storage elements for the given type. 4225 -- This is done without using the attribute (which malfunctions for 4226 -- large sizes ???) 4227 4228 ------------------------- 4229 -- Rewrite_Coextension -- 4230 ------------------------- 4231 4232 procedure Rewrite_Coextension (N : Node_Id) is 4233 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C'); 4234 Temp_Decl : Node_Id; 4235 4236 begin 4237 -- Generate: 4238 -- Cnn : aliased Etyp; 4239 4240 Temp_Decl := 4241 Make_Object_Declaration (Loc, 4242 Defining_Identifier => Temp_Id, 4243 Aliased_Present => True, 4244 Object_Definition => New_Occurrence_Of (Etyp, Loc)); 4245 4246 if Nkind (Expression (N)) = N_Qualified_Expression then 4247 Set_Expression (Temp_Decl, Expression (Expression (N))); 4248 end if; 4249 4250 Insert_Action (N, Temp_Decl); 4251 Rewrite (N, 4252 Make_Attribute_Reference (Loc, 4253 Prefix => New_Occurrence_Of (Temp_Id, Loc), 4254 Attribute_Name => Name_Unrestricted_Access)); 4255 4256 Analyze_And_Resolve (N, PtrT); 4257 end Rewrite_Coextension; 4258 4259 ------------------------------ 4260 -- Size_In_Storage_Elements -- 4261 ------------------------------ 4262 4263 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is 4264 begin 4265 -- Logically this just returns E'Max_Size_In_Storage_Elements. 4266 -- However, the reason for the existence of this function is 4267 -- to construct a test for sizes too large, which means near the 4268 -- 32-bit limit on a 32-bit machine, and precisely the trouble 4269 -- is that we get overflows when sizes are greater than 2**31. 4270 4271 -- So what we end up doing for array types is to use the expression: 4272 4273 -- number-of-elements * component_type'Max_Size_In_Storage_Elements 4274 4275 -- which avoids this problem. All this is a bit bogus, but it does 4276 -- mean we catch common cases of trying to allocate arrays that 4277 -- are too large, and which in the absence of a check results in 4278 -- undetected chaos ??? 4279 4280 -- Note in particular that this is a pessimistic estimate in the 4281 -- case of packed array types, where an array element might occupy 4282 -- just a fraction of a storage element??? 4283 4284 declare 4285 Len : Node_Id; 4286 Res : Node_Id; 4287 pragma Warnings (Off, Res); 4288 4289 begin 4290 for J in 1 .. Number_Dimensions (E) loop 4291 Len := 4292 Make_Attribute_Reference (Loc, 4293 Prefix => New_Occurrence_Of (E, Loc), 4294 Attribute_Name => Name_Length, 4295 Expressions => New_List (Make_Integer_Literal (Loc, J))); 4296 4297 if J = 1 then 4298 Res := Len; 4299 4300 else 4301 Res := 4302 Make_Op_Multiply (Loc, 4303 Left_Opnd => Res, 4304 Right_Opnd => Len); 4305 end if; 4306 end loop; 4307 4308 return 4309 Make_Op_Multiply (Loc, 4310 Left_Opnd => Len, 4311 Right_Opnd => 4312 Make_Attribute_Reference (Loc, 4313 Prefix => New_Occurrence_Of (Component_Type (E), Loc), 4314 Attribute_Name => Name_Max_Size_In_Storage_Elements)); 4315 end; 4316 end Size_In_Storage_Elements; 4317 4318 -- Local variables 4319 4320 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); 4321 Desig : Entity_Id; 4322 Nod : Node_Id; 4323 Pool : Entity_Id; 4324 Rel_Typ : Entity_Id; 4325 Temp : Entity_Id; 4326 4327 -- Start of processing for Expand_N_Allocator 4328 4329 begin 4330 -- RM E.2.3(22). We enforce that the expected type of an allocator 4331 -- shall not be a remote access-to-class-wide-limited-private type 4332 4333 -- Why is this being done at expansion time, seems clearly wrong ??? 4334 4335 Validate_Remote_Access_To_Class_Wide_Type (N); 4336 4337 -- Processing for anonymous access-to-controlled types. These access 4338 -- types receive a special finalization master which appears in the 4339 -- declarations of the enclosing semantic unit. This expansion is done 4340 -- now to ensure that any additional types generated by this routine or 4341 -- Expand_Allocator_Expression inherit the proper type attributes. 4342 4343 if (Ekind (PtrT) = E_Anonymous_Access_Type 4344 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT)))) 4345 and then Needs_Finalization (Dtyp) 4346 then 4347 -- Detect the allocation of an anonymous controlled object where the 4348 -- type of the context is named. For example: 4349 4350 -- procedure Proc (Ptr : Named_Access_Typ); 4351 -- Proc (new Designated_Typ); 4352 4353 -- Regardless of the anonymous-to-named access type conversion, the 4354 -- lifetime of the object must be associated with the named access 4355 -- type. Use the finalization-related attributes of this type. 4356 4357 if Nkind_In (Parent (N), N_Type_Conversion, 4358 N_Unchecked_Type_Conversion) 4359 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype, 4360 E_Access_Type, 4361 E_General_Access_Type) 4362 then 4363 Rel_Typ := Etype (Parent (N)); 4364 else 4365 Rel_Typ := Empty; 4366 end if; 4367 4368 -- Anonymous access-to-controlled types allocate on the global pool. 4369 -- Note that this is a "root type only" attribute. 4370 4371 if No (Associated_Storage_Pool (PtrT)) then 4372 if Present (Rel_Typ) then 4373 Set_Associated_Storage_Pool 4374 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ)); 4375 else 4376 Set_Associated_Storage_Pool 4377 (Root_Type (PtrT), RTE (RE_Global_Pool_Object)); 4378 end if; 4379 end if; 4380 4381 -- The finalization master must be inserted and analyzed as part of 4382 -- the current semantic unit. Note that the master is updated when 4383 -- analysis changes current units. Note that this is a "root type 4384 -- only" attribute. 4385 4386 if Present (Rel_Typ) then 4387 Set_Finalization_Master 4388 (Root_Type (PtrT), Finalization_Master (Rel_Typ)); 4389 else 4390 Build_Anonymous_Master (Root_Type (PtrT)); 4391 end if; 4392 end if; 4393 4394 -- Set the storage pool and find the appropriate version of Allocate to 4395 -- call. Do not overwrite the storage pool if it is already set, which 4396 -- can happen for build-in-place function returns (see 4397 -- Exp_Ch4.Expand_N_Extended_Return_Statement). 4398 4399 if No (Storage_Pool (N)) then 4400 Pool := Associated_Storage_Pool (Root_Type (PtrT)); 4401 4402 if Present (Pool) then 4403 Set_Storage_Pool (N, Pool); 4404 4405 if Is_RTE (Pool, RE_SS_Pool) then 4406 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); 4407 4408 -- In the case of an allocator for a simple storage pool, locate 4409 -- and save a reference to the pool type's Allocate routine. 4410 4411 elsif Present (Get_Rep_Pragma 4412 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 4413 then 4414 declare 4415 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); 4416 Alloc_Op : Entity_Id; 4417 begin 4418 Alloc_Op := Get_Name_Entity_Id (Name_Allocate); 4419 while Present (Alloc_Op) loop 4420 if Scope (Alloc_Op) = Scope (Pool_Type) 4421 and then Present (First_Formal (Alloc_Op)) 4422 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 4423 then 4424 Set_Procedure_To_Call (N, Alloc_Op); 4425 exit; 4426 else 4427 Alloc_Op := Homonym (Alloc_Op); 4428 end if; 4429 end loop; 4430 end; 4431 4432 elsif Is_Class_Wide_Type (Etype (Pool)) then 4433 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); 4434 4435 else 4436 Set_Procedure_To_Call (N, 4437 Find_Prim_Op (Etype (Pool), Name_Allocate)); 4438 end if; 4439 end if; 4440 end if; 4441 4442 -- Under certain circumstances we can replace an allocator by an access 4443 -- to statically allocated storage. The conditions, as noted in AARM 4444 -- 3.10 (10c) are as follows: 4445 4446 -- Size and initial value is known at compile time 4447 -- Access type is access-to-constant 4448 4449 -- The allocator is not part of a constraint on a record component, 4450 -- because in that case the inserted actions are delayed until the 4451 -- record declaration is fully analyzed, which is too late for the 4452 -- analysis of the rewritten allocator. 4453 4454 if Is_Access_Constant (PtrT) 4455 and then Nkind (Expression (N)) = N_Qualified_Expression 4456 and then Compile_Time_Known_Value (Expression (Expression (N))) 4457 and then Size_Known_At_Compile_Time 4458 (Etype (Expression (Expression (N)))) 4459 and then not Is_Record_Type (Current_Scope) 4460 then 4461 -- Here we can do the optimization. For the allocator 4462 4463 -- new x'(y) 4464 4465 -- We insert an object declaration 4466 4467 -- Tnn : aliased x := y; 4468 4469 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is 4470 -- marked as requiring static allocation. 4471 4472 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); 4473 Desig := Subtype_Mark (Expression (N)); 4474 4475 -- If context is constrained, use constrained subtype directly, 4476 -- so that the constant is not labelled as having a nominally 4477 -- unconstrained subtype. 4478 4479 if Entity (Desig) = Base_Type (Dtyp) then 4480 Desig := New_Occurrence_Of (Dtyp, Loc); 4481 end if; 4482 4483 Insert_Action (N, 4484 Make_Object_Declaration (Loc, 4485 Defining_Identifier => Temp, 4486 Aliased_Present => True, 4487 Constant_Present => Is_Access_Constant (PtrT), 4488 Object_Definition => Desig, 4489 Expression => Expression (Expression (N)))); 4490 4491 Rewrite (N, 4492 Make_Attribute_Reference (Loc, 4493 Prefix => New_Occurrence_Of (Temp, Loc), 4494 Attribute_Name => Name_Unrestricted_Access)); 4495 4496 Analyze_And_Resolve (N, PtrT); 4497 4498 -- We set the variable as statically allocated, since we don't want 4499 -- it going on the stack of the current procedure. 4500 4501 Set_Is_Statically_Allocated (Temp); 4502 return; 4503 end if; 4504 4505 -- Same if the allocator is an access discriminant for a local object: 4506 -- instead of an allocator we create a local value and constrain the 4507 -- enclosing object with the corresponding access attribute. 4508 4509 if Is_Static_Coextension (N) then 4510 Rewrite_Coextension (N); 4511 return; 4512 end if; 4513 4514 -- Check for size too large, we do this because the back end misses 4515 -- proper checks here and can generate rubbish allocation calls when 4516 -- we are near the limit. We only do this for the 32-bit address case 4517 -- since that is from a practical point of view where we see a problem. 4518 4519 if System_Address_Size = 32 4520 and then not Storage_Checks_Suppressed (PtrT) 4521 and then not Storage_Checks_Suppressed (Dtyp) 4522 and then not Storage_Checks_Suppressed (Etyp) 4523 then 4524 -- The check we want to generate should look like 4525 4526 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then 4527 -- raise Storage_Error; 4528 -- end if; 4529 4530 -- where 3.5 gigabytes is a constant large enough to accommodate any 4531 -- reasonable request for. But we can't do it this way because at 4532 -- least at the moment we don't compute this attribute right, and 4533 -- can silently give wrong results when the result gets large. Since 4534 -- this is all about large results, that's bad, so instead we only 4535 -- apply the check for constrained arrays, and manually compute the 4536 -- value of the attribute ??? 4537 4538 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then 4539 Insert_Action (N, 4540 Make_Raise_Storage_Error (Loc, 4541 Condition => 4542 Make_Op_Gt (Loc, 4543 Left_Opnd => Size_In_Storage_Elements (Etyp), 4544 Right_Opnd => 4545 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))), 4546 Reason => SE_Object_Too_Large)); 4547 end if; 4548 end if; 4549 4550 -- If no storage pool has been specified and we have the restriction 4551 -- No_Standard_Allocators_After_Elaboration is present, then generate 4552 -- a call to Elaboration_Allocators.Check_Standard_Allocator. 4553 4554 if Nkind (N) = N_Allocator 4555 and then No (Storage_Pool (N)) 4556 and then Restriction_Active (No_Standard_Allocators_After_Elaboration) 4557 then 4558 Insert_Action (N, 4559 Make_Procedure_Call_Statement (Loc, 4560 Name => 4561 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc))); 4562 end if; 4563 4564 -- Handle case of qualified expression (other than optimization above) 4565 -- First apply constraint checks, because the bounds or discriminants 4566 -- in the aggregate might not match the subtype mark in the allocator. 4567 4568 if Nkind (Expression (N)) = N_Qualified_Expression then 4569 declare 4570 Exp : constant Node_Id := Expression (Expression (N)); 4571 Typ : constant Entity_Id := Etype (Expression (N)); 4572 4573 begin 4574 Apply_Constraint_Check (Exp, Typ); 4575 Apply_Predicate_Check (Exp, Typ); 4576 end; 4577 4578 Expand_Allocator_Expression (N); 4579 return; 4580 end if; 4581 4582 -- If the allocator is for a type which requires initialization, and 4583 -- there is no initial value (i.e. operand is a subtype indication 4584 -- rather than a qualified expression), then we must generate a call to 4585 -- the initialization routine using an expressions action node: 4586 4587 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] 4588 4589 -- Here ptr_T is the pointer type for the allocator, and T is the 4590 -- subtype of the allocator. A special case arises if the designated 4591 -- type of the access type is a task or contains tasks. In this case 4592 -- the call to Init (Temp.all ...) is replaced by code that ensures 4593 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block 4594 -- for details). In addition, if the type T is a task type, then the 4595 -- first argument to Init must be converted to the task record type. 4596 4597 declare 4598 T : constant Entity_Id := Entity (Expression (N)); 4599 Args : List_Id; 4600 Decls : List_Id; 4601 Decl : Node_Id; 4602 Discr : Elmt_Id; 4603 Init : Entity_Id; 4604 Init_Arg1 : Node_Id; 4605 Init_Call : Node_Id; 4606 Temp_Decl : Node_Id; 4607 Temp_Type : Entity_Id; 4608 4609 begin 4610 if No_Initialization (N) then 4611 4612 -- Even though this might be a simple allocation, create a custom 4613 -- Allocate if the context requires it. 4614 4615 if Present (Finalization_Master (PtrT)) then 4616 Build_Allocate_Deallocate_Proc 4617 (N => N, 4618 Is_Allocate => True); 4619 end if; 4620 4621 -- Case of no initialization procedure present 4622 4623 elsif not Has_Non_Null_Base_Init_Proc (T) then 4624 4625 -- Case of simple initialization required 4626 4627 if Needs_Simple_Initialization (T) then 4628 Check_Restriction (No_Default_Initialization, N); 4629 Rewrite (Expression (N), 4630 Make_Qualified_Expression (Loc, 4631 Subtype_Mark => New_Occurrence_Of (T, Loc), 4632 Expression => Get_Simple_Init_Val (T, N))); 4633 4634 Analyze_And_Resolve (Expression (Expression (N)), T); 4635 Analyze_And_Resolve (Expression (N), T); 4636 Set_Paren_Count (Expression (Expression (N)), 1); 4637 Expand_N_Allocator (N); 4638 4639 -- No initialization required 4640 4641 else 4642 Build_Allocate_Deallocate_Proc 4643 (N => N, 4644 Is_Allocate => True); 4645 end if; 4646 4647 -- Case of initialization procedure present, must be called 4648 4649 else 4650 Check_Restriction (No_Default_Initialization, N); 4651 4652 if not Restriction_Active (No_Default_Initialization) then 4653 Init := Base_Init_Proc (T); 4654 Nod := N; 4655 Temp := Make_Temporary (Loc, 'P'); 4656 4657 -- Construct argument list for the initialization routine call 4658 4659 Init_Arg1 := 4660 Make_Explicit_Dereference (Loc, 4661 Prefix => 4662 New_Occurrence_Of (Temp, Loc)); 4663 4664 Set_Assignment_OK (Init_Arg1); 4665 Temp_Type := PtrT; 4666 4667 -- The initialization procedure expects a specific type. if the 4668 -- context is access to class wide, indicate that the object 4669 -- being allocated has the right specific type. 4670 4671 if Is_Class_Wide_Type (Dtyp) then 4672 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1); 4673 end if; 4674 4675 -- If designated type is a concurrent type or if it is private 4676 -- type whose definition is a concurrent type, the first 4677 -- argument in the Init routine has to be unchecked conversion 4678 -- to the corresponding record type. If the designated type is 4679 -- a derived type, also convert the argument to its root type. 4680 4681 if Is_Concurrent_Type (T) then 4682 Init_Arg1 := 4683 Unchecked_Convert_To ( 4684 Corresponding_Record_Type (T), Init_Arg1); 4685 4686 elsif Is_Private_Type (T) 4687 and then Present (Full_View (T)) 4688 and then Is_Concurrent_Type (Full_View (T)) 4689 then 4690 Init_Arg1 := 4691 Unchecked_Convert_To 4692 (Corresponding_Record_Type (Full_View (T)), Init_Arg1); 4693 4694 elsif Etype (First_Formal (Init)) /= Base_Type (T) then 4695 declare 4696 Ftyp : constant Entity_Id := Etype (First_Formal (Init)); 4697 4698 begin 4699 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1); 4700 Set_Etype (Init_Arg1, Ftyp); 4701 end; 4702 end if; 4703 4704 Args := New_List (Init_Arg1); 4705 4706 -- For the task case, pass the Master_Id of the access type as 4707 -- the value of the _Master parameter, and _Chain as the value 4708 -- of the _Chain parameter (_Chain will be defined as part of 4709 -- the generated code for the allocator). 4710 4711 -- In Ada 2005, the context may be a function that returns an 4712 -- anonymous access type. In that case the Master_Id has been 4713 -- created when expanding the function declaration. 4714 4715 if Has_Task (T) then 4716 if No (Master_Id (Base_Type (PtrT))) then 4717 4718 -- The designated type was an incomplete type, and the 4719 -- access type did not get expanded. Salvage it now. 4720 4721 if not Restriction_Active (No_Task_Hierarchy) then 4722 if Present (Parent (Base_Type (PtrT))) then 4723 Expand_N_Full_Type_Declaration 4724 (Parent (Base_Type (PtrT))); 4725 4726 -- The only other possibility is an itype. For this 4727 -- case, the master must exist in the context. This is 4728 -- the case when the allocator initializes an access 4729 -- component in an init-proc. 4730 4731 else 4732 pragma Assert (Is_Itype (PtrT)); 4733 Build_Master_Renaming (PtrT, N); 4734 end if; 4735 end if; 4736 end if; 4737 4738 -- If the context of the allocator is a declaration or an 4739 -- assignment, we can generate a meaningful image for it, 4740 -- even though subsequent assignments might remove the 4741 -- connection between task and entity. We build this image 4742 -- when the left-hand side is a simple variable, a simple 4743 -- indexed assignment or a simple selected component. 4744 4745 if Nkind (Parent (N)) = N_Assignment_Statement then 4746 declare 4747 Nam : constant Node_Id := Name (Parent (N)); 4748 4749 begin 4750 if Is_Entity_Name (Nam) then 4751 Decls := 4752 Build_Task_Image_Decls 4753 (Loc, 4754 New_Occurrence_Of 4755 (Entity (Nam), Sloc (Nam)), T); 4756 4757 elsif Nkind_In (Nam, N_Indexed_Component, 4758 N_Selected_Component) 4759 and then Is_Entity_Name (Prefix (Nam)) 4760 then 4761 Decls := 4762 Build_Task_Image_Decls 4763 (Loc, Nam, Etype (Prefix (Nam))); 4764 else 4765 Decls := Build_Task_Image_Decls (Loc, T, T); 4766 end if; 4767 end; 4768 4769 elsif Nkind (Parent (N)) = N_Object_Declaration then 4770 Decls := 4771 Build_Task_Image_Decls 4772 (Loc, Defining_Identifier (Parent (N)), T); 4773 4774 else 4775 Decls := Build_Task_Image_Decls (Loc, T, T); 4776 end if; 4777 4778 if Restriction_Active (No_Task_Hierarchy) then 4779 Append_To (Args, 4780 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 4781 else 4782 Append_To (Args, 4783 New_Occurrence_Of 4784 (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); 4785 end if; 4786 4787 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 4788 4789 Decl := Last (Decls); 4790 Append_To (Args, 4791 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 4792 4793 -- Has_Task is false, Decls not used 4794 4795 else 4796 Decls := No_List; 4797 end if; 4798 4799 -- Add discriminants if discriminated type 4800 4801 declare 4802 Dis : Boolean := False; 4803 Typ : Entity_Id := Empty; 4804 4805 begin 4806 if Has_Discriminants (T) then 4807 Dis := True; 4808 Typ := T; 4809 4810 -- Type may be a private type with no visible discriminants 4811 -- in which case check full view if in scope, or the 4812 -- underlying_full_view if dealing with a type whose full 4813 -- view may be derived from a private type whose own full 4814 -- view has discriminants. 4815 4816 elsif Is_Private_Type (T) then 4817 if Present (Full_View (T)) 4818 and then Has_Discriminants (Full_View (T)) 4819 then 4820 Dis := True; 4821 Typ := Full_View (T); 4822 4823 elsif Present (Underlying_Full_View (T)) 4824 and then Has_Discriminants (Underlying_Full_View (T)) 4825 then 4826 Dis := True; 4827 Typ := Underlying_Full_View (T); 4828 end if; 4829 end if; 4830 4831 if Dis then 4832 4833 -- If the allocated object will be constrained by the 4834 -- default values for discriminants, then build a subtype 4835 -- with those defaults, and change the allocated subtype 4836 -- to that. Note that this happens in fewer cases in Ada 4837 -- 2005 (AI-363). 4838 4839 if not Is_Constrained (Typ) 4840 and then Present (Discriminant_Default_Value 4841 (First_Discriminant (Typ))) 4842 and then (Ada_Version < Ada_2005 4843 or else not 4844 Object_Type_Has_Constrained_Partial_View 4845 (Typ, Current_Scope)) 4846 then 4847 Typ := Build_Default_Subtype (Typ, N); 4848 Set_Expression (N, New_Occurrence_Of (Typ, Loc)); 4849 end if; 4850 4851 Discr := First_Elmt (Discriminant_Constraint (Typ)); 4852 while Present (Discr) loop 4853 Nod := Node (Discr); 4854 Append (New_Copy_Tree (Node (Discr)), Args); 4855 4856 -- AI-416: when the discriminant constraint is an 4857 -- anonymous access type make sure an accessibility 4858 -- check is inserted if necessary (3.10.2(22.q/2)) 4859 4860 if Ada_Version >= Ada_2005 4861 and then 4862 Ekind (Etype (Nod)) = E_Anonymous_Access_Type 4863 then 4864 Apply_Accessibility_Check 4865 (Nod, Typ, Insert_Node => Nod); 4866 end if; 4867 4868 Next_Elmt (Discr); 4869 end loop; 4870 end if; 4871 end; 4872 4873 -- We set the allocator as analyzed so that when we analyze 4874 -- the if expression node, we do not get an unwanted recursive 4875 -- expansion of the allocator expression. 4876 4877 Set_Analyzed (N, True); 4878 Nod := Relocate_Node (N); 4879 4880 -- Here is the transformation: 4881 -- input: new Ctrl_Typ 4882 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ; 4883 -- Ctrl_TypIP (Temp.all, ...); 4884 -- [Deep_]Initialize (Temp.all); 4885 4886 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and 4887 -- is the subtype of the allocator. 4888 4889 Temp_Decl := 4890 Make_Object_Declaration (Loc, 4891 Defining_Identifier => Temp, 4892 Constant_Present => True, 4893 Object_Definition => New_Occurrence_Of (Temp_Type, Loc), 4894 Expression => Nod); 4895 4896 Set_Assignment_OK (Temp_Decl); 4897 Insert_Action (N, Temp_Decl, Suppress => All_Checks); 4898 4899 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 4900 4901 -- If the designated type is a task type or contains tasks, 4902 -- create block to activate created tasks, and insert 4903 -- declaration for Task_Image variable ahead of call. 4904 4905 if Has_Task (T) then 4906 declare 4907 L : constant List_Id := New_List; 4908 Blk : Node_Id; 4909 begin 4910 Build_Task_Allocate_Block (L, Nod, Args); 4911 Blk := Last (L); 4912 Insert_List_Before (First (Declarations (Blk)), Decls); 4913 Insert_Actions (N, L); 4914 end; 4915 4916 else 4917 Insert_Action (N, 4918 Make_Procedure_Call_Statement (Loc, 4919 Name => New_Occurrence_Of (Init, Loc), 4920 Parameter_Associations => Args)); 4921 end if; 4922 4923 if Needs_Finalization (T) then 4924 4925 -- Generate: 4926 -- [Deep_]Initialize (Init_Arg1); 4927 4928 Init_Call := 4929 Make_Init_Call 4930 (Obj_Ref => New_Copy_Tree (Init_Arg1), 4931 Typ => T); 4932 4933 -- Guard against a missing [Deep_]Initialize when the 4934 -- designated type was not properly frozen. 4935 4936 if Present (Init_Call) then 4937 Insert_Action (N, Init_Call); 4938 end if; 4939 end if; 4940 4941 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 4942 Analyze_And_Resolve (N, PtrT); 4943 end if; 4944 end if; 4945 end; 4946 4947 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface 4948 -- object that has been rewritten as a reference, we displace "this" 4949 -- to reference properly its secondary dispatch table. 4950 4951 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then 4952 Displace_Allocator_Pointer (N); 4953 end if; 4954 4955 exception 4956 when RE_Not_Available => 4957 return; 4958 end Expand_N_Allocator; 4959 4960 ----------------------- 4961 -- Expand_N_And_Then -- 4962 ----------------------- 4963 4964 procedure Expand_N_And_Then (N : Node_Id) 4965 renames Expand_Short_Circuit_Operator; 4966 4967 ------------------------------ 4968 -- Expand_N_Case_Expression -- 4969 ------------------------------ 4970 4971 procedure Expand_N_Case_Expression (N : Node_Id) is 4972 4973 function Is_Copy_Type (Typ : Entity_Id) return Boolean; 4974 -- Return True if we can copy objects of this type when expanding a case 4975 -- expression. 4976 4977 ------------------ 4978 -- Is_Copy_Type -- 4979 ------------------ 4980 4981 function Is_Copy_Type (Typ : Entity_Id) return Boolean is 4982 begin 4983 -- If Minimize_Expression_With_Actions is True, we can afford to copy 4984 -- large objects, as long as they are constrained and not limited. 4985 4986 return 4987 Is_Elementary_Type (Underlying_Type (Typ)) 4988 or else 4989 (Minimize_Expression_With_Actions 4990 and then Is_Constrained (Underlying_Type (Typ)) 4991 and then not Is_Limited_View (Underlying_Type (Typ))); 4992 end Is_Copy_Type; 4993 4994 -- Local variables 4995 4996 Loc : constant Source_Ptr := Sloc (N); 4997 Par : constant Node_Id := Parent (N); 4998 Typ : constant Entity_Id := Etype (N); 4999 5000 Acts : List_Id; 5001 Alt : Node_Id; 5002 Case_Stmt : Node_Id; 5003 Decl : Node_Id; 5004 Expr : Node_Id; 5005 Target : Entity_Id; 5006 Target_Typ : Entity_Id; 5007 5008 In_Predicate : Boolean := False; 5009 -- Flag set when the case expression appears within a predicate 5010 5011 Optimize_Return_Stmt : Boolean := False; 5012 -- Flag set when the case expression can be optimized in the context of 5013 -- a simple return statement. 5014 5015 -- Start of processing for Expand_N_Case_Expression 5016 5017 begin 5018 -- Check for MINIMIZED/ELIMINATED overflow mode 5019 5020 if Minimized_Eliminated_Overflow_Check (N) then 5021 Apply_Arithmetic_Overflow_Check (N); 5022 return; 5023 end if; 5024 5025 -- If the case expression is a predicate specification, and the type 5026 -- to which it applies has a static predicate aspect, do not expand, 5027 -- because it will be converted to the proper predicate form later. 5028 5029 if Ekind_In (Current_Scope, E_Function, E_Procedure) 5030 and then Is_Predicate_Function (Current_Scope) 5031 then 5032 In_Predicate := True; 5033 5034 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope))) 5035 then 5036 return; 5037 end if; 5038 end if; 5039 5040 -- When the type of the case expression is elementary, expand 5041 5042 -- (case X is when A => AX, when B => BX ...) 5043 5044 -- into 5045 5046 -- do 5047 -- Target : Typ; 5048 -- case X is 5049 -- when A => 5050 -- Target := AX; 5051 -- when B => 5052 -- Target := BX; 5053 -- ... 5054 -- end case; 5055 -- in Target end; 5056 5057 -- In all other cases expand into 5058 5059 -- do 5060 -- type Ptr_Typ is access all Typ; 5061 -- Target : Ptr_Typ; 5062 -- case X is 5063 -- when A => 5064 -- Target := AX'Unrestricted_Access; 5065 -- when B => 5066 -- Target := BX'Unrestricted_Access; 5067 -- ... 5068 -- end case; 5069 -- in Target.all end; 5070 5071 -- This approach avoids extra copies of potentially large objects. It 5072 -- also allows handling of values of limited or unconstrained types. 5073 -- Note that we do the copy also for constrained, nonlimited types 5074 -- when minimizing expressions with actions (e.g. when generating C 5075 -- code) since it allows us to do the optimization below in more cases. 5076 5077 -- Small optimization: when the case expression appears in the context 5078 -- of a simple return statement, expand into 5079 5080 -- case X is 5081 -- when A => 5082 -- return AX; 5083 -- when B => 5084 -- return BX; 5085 -- ... 5086 -- end case; 5087 5088 Case_Stmt := 5089 Make_Case_Statement (Loc, 5090 Expression => Expression (N), 5091 Alternatives => New_List); 5092 5093 -- Preserve the original context for which the case statement is being 5094 -- generated. This is needed by the finalization machinery to prevent 5095 -- the premature finalization of controlled objects found within the 5096 -- case statement. 5097 5098 Set_From_Conditional_Expression (Case_Stmt); 5099 Acts := New_List; 5100 5101 -- Scalar/Copy case 5102 5103 if Is_Copy_Type (Typ) then 5104 Target_Typ := Typ; 5105 5106 -- ??? Do not perform the optimization when the return statement is 5107 -- within a predicate function, as this causes spurious errors. Could 5108 -- this be a possible mismatch in handling this case somewhere else 5109 -- in semantic analysis? 5110 5111 Optimize_Return_Stmt := 5112 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; 5113 5114 -- Otherwise create an access type to handle the general case using 5115 -- 'Unrestricted_Access. 5116 5117 -- Generate: 5118 -- type Ptr_Typ is access all Typ; 5119 5120 else 5121 if Generate_C_Code then 5122 5123 -- We cannot ensure that correct C code will be generated if any 5124 -- temporary is created down the line (to e.g. handle checks or 5125 -- capture values) since we might end up with dangling references 5126 -- to local variables, so better be safe and reject the construct. 5127 5128 Error_Msg_N 5129 ("case expression too complex, use case statement instead", N); 5130 end if; 5131 5132 Target_Typ := Make_Temporary (Loc, 'P'); 5133 5134 Append_To (Acts, 5135 Make_Full_Type_Declaration (Loc, 5136 Defining_Identifier => Target_Typ, 5137 Type_Definition => 5138 Make_Access_To_Object_Definition (Loc, 5139 All_Present => True, 5140 Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); 5141 end if; 5142 5143 -- Create the declaration of the target which captures the value of the 5144 -- expression. 5145 5146 -- Generate: 5147 -- Target : [Ptr_]Typ; 5148 5149 if not Optimize_Return_Stmt then 5150 Target := Make_Temporary (Loc, 'T'); 5151 5152 Decl := 5153 Make_Object_Declaration (Loc, 5154 Defining_Identifier => Target, 5155 Object_Definition => New_Occurrence_Of (Target_Typ, Loc)); 5156 Set_No_Initialization (Decl); 5157 5158 Append_To (Acts, Decl); 5159 end if; 5160 5161 -- Process the alternatives 5162 5163 Alt := First (Alternatives (N)); 5164 while Present (Alt) loop 5165 declare 5166 Alt_Expr : Node_Id := Expression (Alt); 5167 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); 5168 Stmts : List_Id; 5169 5170 begin 5171 -- Take the unrestricted access of the expression value for non- 5172 -- scalar types. This approach avoids big copies and covers the 5173 -- limited and unconstrained cases. 5174 5175 -- Generate: 5176 -- AX'Unrestricted_Access 5177 5178 if not Is_Copy_Type (Typ) then 5179 Alt_Expr := 5180 Make_Attribute_Reference (Alt_Loc, 5181 Prefix => Relocate_Node (Alt_Expr), 5182 Attribute_Name => Name_Unrestricted_Access); 5183 end if; 5184 5185 -- Generate: 5186 -- return AX['Unrestricted_Access]; 5187 5188 if Optimize_Return_Stmt then 5189 Stmts := New_List ( 5190 Make_Simple_Return_Statement (Alt_Loc, 5191 Expression => Alt_Expr)); 5192 5193 -- Generate: 5194 -- Target := AX['Unrestricted_Access]; 5195 5196 else 5197 Stmts := New_List ( 5198 Make_Assignment_Statement (Alt_Loc, 5199 Name => New_Occurrence_Of (Target, Loc), 5200 Expression => Alt_Expr)); 5201 end if; 5202 5203 -- Propagate declarations inserted in the node by Insert_Actions 5204 -- (for example, temporaries generated to remove side effects). 5205 -- These actions must remain attached to the alternative, given 5206 -- that they are generated by the corresponding expression. 5207 5208 if Present (Actions (Alt)) then 5209 Prepend_List (Actions (Alt), Stmts); 5210 end if; 5211 5212 -- Finalize any transient objects on exit from the alternative. 5213 -- This is done only in the return optimization case because 5214 -- otherwise the case expression is converted into an expression 5215 -- with actions which already contains this form of processing. 5216 5217 if Optimize_Return_Stmt then 5218 Process_If_Case_Statements (N, Stmts); 5219 end if; 5220 5221 Append_To 5222 (Alternatives (Case_Stmt), 5223 Make_Case_Statement_Alternative (Sloc (Alt), 5224 Discrete_Choices => Discrete_Choices (Alt), 5225 Statements => Stmts)); 5226 end; 5227 5228 Next (Alt); 5229 end loop; 5230 5231 -- Rewrite the parent return statement as a case statement 5232 5233 if Optimize_Return_Stmt then 5234 Rewrite (Par, Case_Stmt); 5235 Analyze (Par); 5236 5237 -- Otherwise convert the case expression into an expression with actions 5238 5239 else 5240 Append_To (Acts, Case_Stmt); 5241 5242 if Is_Copy_Type (Typ) then 5243 Expr := New_Occurrence_Of (Target, Loc); 5244 5245 else 5246 Expr := 5247 Make_Explicit_Dereference (Loc, 5248 Prefix => New_Occurrence_Of (Target, Loc)); 5249 end if; 5250 5251 -- Generate: 5252 -- do 5253 -- ... 5254 -- in Target[.all] end; 5255 5256 Rewrite (N, 5257 Make_Expression_With_Actions (Loc, 5258 Expression => Expr, 5259 Actions => Acts)); 5260 5261 Analyze_And_Resolve (N, Typ); 5262 end if; 5263 end Expand_N_Case_Expression; 5264 5265 ----------------------------------- 5266 -- Expand_N_Explicit_Dereference -- 5267 ----------------------------------- 5268 5269 procedure Expand_N_Explicit_Dereference (N : Node_Id) is 5270 begin 5271 -- Insert explicit dereference call for the checked storage pool case 5272 5273 Insert_Dereference_Action (Prefix (N)); 5274 5275 -- If the type is an Atomic type for which Atomic_Sync is enabled, then 5276 -- we set the atomic sync flag. 5277 5278 if Is_Atomic (Etype (N)) 5279 and then not Atomic_Synchronization_Disabled (Etype (N)) 5280 then 5281 Activate_Atomic_Synchronization (N); 5282 end if; 5283 end Expand_N_Explicit_Dereference; 5284 5285 -------------------------------------- 5286 -- Expand_N_Expression_With_Actions -- 5287 -------------------------------------- 5288 5289 procedure Expand_N_Expression_With_Actions (N : Node_Id) is 5290 Acts : constant List_Id := Actions (N); 5291 5292 procedure Force_Boolean_Evaluation (Expr : Node_Id); 5293 -- Force the evaluation of Boolean expression Expr 5294 5295 function Process_Action (Act : Node_Id) return Traverse_Result; 5296 -- Inspect and process a single action of an expression_with_actions for 5297 -- transient objects. If such objects are found, the routine generates 5298 -- code to clean them up when the context of the expression is evaluated 5299 -- or elaborated. 5300 5301 ------------------------------ 5302 -- Force_Boolean_Evaluation -- 5303 ------------------------------ 5304 5305 procedure Force_Boolean_Evaluation (Expr : Node_Id) is 5306 Loc : constant Source_Ptr := Sloc (N); 5307 Flag_Decl : Node_Id; 5308 Flag_Id : Entity_Id; 5309 5310 begin 5311 -- Relocate the expression to the actions list by capturing its value 5312 -- in a Boolean flag. Generate: 5313 -- Flag : constant Boolean := Expr; 5314 5315 Flag_Id := Make_Temporary (Loc, 'F'); 5316 5317 Flag_Decl := 5318 Make_Object_Declaration (Loc, 5319 Defining_Identifier => Flag_Id, 5320 Constant_Present => True, 5321 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 5322 Expression => Relocate_Node (Expr)); 5323 5324 Append (Flag_Decl, Acts); 5325 Analyze (Flag_Decl); 5326 5327 -- Replace the expression with a reference to the flag 5328 5329 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc)); 5330 Analyze (Expression (N)); 5331 end Force_Boolean_Evaluation; 5332 5333 -------------------- 5334 -- Process_Action -- 5335 -------------------- 5336 5337 function Process_Action (Act : Node_Id) return Traverse_Result is 5338 begin 5339 if Nkind (Act) = N_Object_Declaration 5340 and then Is_Finalizable_Transient (Act, N) 5341 then 5342 Process_Transient_In_Expression (Act, N, Acts); 5343 return Skip; 5344 5345 -- Avoid processing temporary function results multiple times when 5346 -- dealing with nested expression_with_actions. 5347 5348 elsif Nkind (Act) = N_Expression_With_Actions then 5349 return Abandon; 5350 5351 -- Do not process temporary function results in loops. This is done 5352 -- by Expand_N_Loop_Statement and Build_Finalizer. 5353 5354 elsif Nkind (Act) = N_Loop_Statement then 5355 return Abandon; 5356 end if; 5357 5358 return OK; 5359 end Process_Action; 5360 5361 procedure Process_Single_Action is new Traverse_Proc (Process_Action); 5362 5363 -- Local variables 5364 5365 Act : Node_Id; 5366 5367 -- Start of processing for Expand_N_Expression_With_Actions 5368 5369 begin 5370 -- Do not evaluate the expression when it denotes an entity because the 5371 -- expression_with_actions node will be replaced by the reference. 5372 5373 if Is_Entity_Name (Expression (N)) then 5374 null; 5375 5376 -- Do not evaluate the expression when there are no actions because the 5377 -- expression_with_actions node will be replaced by the expression. 5378 5379 elsif No (Acts) or else Is_Empty_List (Acts) then 5380 null; 5381 5382 -- Force the evaluation of the expression by capturing its value in a 5383 -- temporary. This ensures that aliases of transient objects do not leak 5384 -- to the expression of the expression_with_actions node: 5385 5386 -- do 5387 -- Trans_Id : Ctrl_Typ := ...; 5388 -- Alias : ... := Trans_Id; 5389 -- in ... Alias ... end; 5390 5391 -- In the example above, Trans_Id cannot be finalized at the end of the 5392 -- actions list because this may affect the alias and the final value of 5393 -- the expression_with_actions. Forcing the evaluation encapsulates the 5394 -- reference to the Alias within the actions list: 5395 5396 -- do 5397 -- Trans_Id : Ctrl_Typ := ...; 5398 -- Alias : ... := Trans_Id; 5399 -- Val : constant Boolean := ... Alias ...; 5400 -- <finalize Trans_Id> 5401 -- in Val end; 5402 5403 -- Once this transformation is performed, it is safe to finalize the 5404 -- transient object at the end of the actions list. 5405 5406 -- Note that Force_Evaluation does not remove side effects in operators 5407 -- because it assumes that all operands are evaluated and side effect 5408 -- free. This is not the case when an operand depends implicitly on the 5409 -- transient object through the use of access types. 5410 5411 elsif Is_Boolean_Type (Etype (Expression (N))) then 5412 Force_Boolean_Evaluation (Expression (N)); 5413 5414 -- The expression of an expression_with_actions node may not necessarily 5415 -- be Boolean when the node appears in an if expression. In this case do 5416 -- the usual forced evaluation to encapsulate potential aliasing. 5417 5418 else 5419 Force_Evaluation (Expression (N)); 5420 end if; 5421 5422 -- Process all transient objects found within the actions of the EWA 5423 -- node. 5424 5425 Act := First (Acts); 5426 while Present (Act) loop 5427 Process_Single_Action (Act); 5428 Next (Act); 5429 end loop; 5430 5431 -- Deal with case where there are no actions. In this case we simply 5432 -- rewrite the node with its expression since we don't need the actions 5433 -- and the specification of this node does not allow a null action list. 5434 5435 -- Note: we use Rewrite instead of Replace, because Codepeer is using 5436 -- the expanded tree and relying on being able to retrieve the original 5437 -- tree in cases like this. This raises a whole lot of issues of whether 5438 -- we have problems elsewhere, which will be addressed in the future??? 5439 5440 if Is_Empty_List (Acts) then 5441 Rewrite (N, Relocate_Node (Expression (N))); 5442 end if; 5443 end Expand_N_Expression_With_Actions; 5444 5445 ---------------------------- 5446 -- Expand_N_If_Expression -- 5447 ---------------------------- 5448 5449 -- Deal with limited types and condition actions 5450 5451 procedure Expand_N_If_Expression (N : Node_Id) is 5452 Cond : constant Node_Id := First (Expressions (N)); 5453 Loc : constant Source_Ptr := Sloc (N); 5454 Thenx : constant Node_Id := Next (Cond); 5455 Elsex : constant Node_Id := Next (Thenx); 5456 Typ : constant Entity_Id := Etype (N); 5457 5458 Actions : List_Id; 5459 Decl : Node_Id; 5460 Expr : Node_Id; 5461 New_If : Node_Id; 5462 New_N : Node_Id; 5463 5464 begin 5465 -- Check for MINIMIZED/ELIMINATED overflow mode 5466 5467 if Minimized_Eliminated_Overflow_Check (N) then 5468 Apply_Arithmetic_Overflow_Check (N); 5469 return; 5470 end if; 5471 5472 -- Fold at compile time if condition known. We have already folded 5473 -- static if expressions, but it is possible to fold any case in which 5474 -- the condition is known at compile time, even though the result is 5475 -- non-static. 5476 5477 -- Note that we don't do the fold of such cases in Sem_Elab because 5478 -- it can cause infinite loops with the expander adding a conditional 5479 -- expression, and Sem_Elab circuitry removing it repeatedly. 5480 5481 if Compile_Time_Known_Value (Cond) then 5482 declare 5483 function Fold_Known_Value (Cond : Node_Id) return Boolean; 5484 -- Fold at compile time. Assumes condition known. Return True if 5485 -- folding occurred, meaning we're done. 5486 5487 ---------------------- 5488 -- Fold_Known_Value -- 5489 ---------------------- 5490 5491 function Fold_Known_Value (Cond : Node_Id) return Boolean is 5492 begin 5493 if Is_True (Expr_Value (Cond)) then 5494 Expr := Thenx; 5495 Actions := Then_Actions (N); 5496 else 5497 Expr := Elsex; 5498 Actions := Else_Actions (N); 5499 end if; 5500 5501 Remove (Expr); 5502 5503 if Present (Actions) then 5504 5505 -- To minimize the use of Expression_With_Actions, just skip 5506 -- the optimization as it is not critical for correctness. 5507 5508 if Minimize_Expression_With_Actions then 5509 return False; 5510 end if; 5511 5512 Rewrite (N, 5513 Make_Expression_With_Actions (Loc, 5514 Expression => Relocate_Node (Expr), 5515 Actions => Actions)); 5516 Analyze_And_Resolve (N, Typ); 5517 5518 else 5519 Rewrite (N, Relocate_Node (Expr)); 5520 end if; 5521 5522 -- Note that the result is never static (legitimate cases of 5523 -- static if expressions were folded in Sem_Eval). 5524 5525 Set_Is_Static_Expression (N, False); 5526 return True; 5527 end Fold_Known_Value; 5528 5529 begin 5530 if Fold_Known_Value (Cond) then 5531 return; 5532 end if; 5533 end; 5534 end if; 5535 5536 -- If the type is limited, and the back end does not handle limited 5537 -- types, then we expand as follows to avoid the possibility of 5538 -- improper copying. 5539 5540 -- type Ptr is access all Typ; 5541 -- Cnn : Ptr; 5542 -- if cond then 5543 -- <<then actions>> 5544 -- Cnn := then-expr'Unrestricted_Access; 5545 -- else 5546 -- <<else actions>> 5547 -- Cnn := else-expr'Unrestricted_Access; 5548 -- end if; 5549 5550 -- and replace the if expression by a reference to Cnn.all. 5551 5552 -- This special case can be skipped if the back end handles limited 5553 -- types properly and ensures that no incorrect copies are made. 5554 5555 if Is_By_Reference_Type (Typ) 5556 and then not Back_End_Handles_Limited_Types 5557 then 5558 -- When the "then" or "else" expressions involve controlled function 5559 -- calls, generated temporaries are chained on the corresponding list 5560 -- of actions. These temporaries need to be finalized after the if 5561 -- expression is evaluated. 5562 5563 Process_If_Case_Statements (N, Then_Actions (N)); 5564 Process_If_Case_Statements (N, Else_Actions (N)); 5565 5566 declare 5567 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N); 5568 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); 5569 5570 begin 5571 -- Generate: 5572 -- type Ann is access all Typ; 5573 5574 Insert_Action (N, 5575 Make_Full_Type_Declaration (Loc, 5576 Defining_Identifier => Ptr_Typ, 5577 Type_Definition => 5578 Make_Access_To_Object_Definition (Loc, 5579 All_Present => True, 5580 Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); 5581 5582 -- Generate: 5583 -- Cnn : Ann; 5584 5585 Decl := 5586 Make_Object_Declaration (Loc, 5587 Defining_Identifier => Cnn, 5588 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); 5589 5590 -- Generate: 5591 -- if Cond then 5592 -- Cnn := <Thenx>'Unrestricted_Access; 5593 -- else 5594 -- Cnn := <Elsex>'Unrestricted_Access; 5595 -- end if; 5596 5597 New_If := 5598 Make_Implicit_If_Statement (N, 5599 Condition => Relocate_Node (Cond), 5600 Then_Statements => New_List ( 5601 Make_Assignment_Statement (Sloc (Thenx), 5602 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 5603 Expression => 5604 Make_Attribute_Reference (Loc, 5605 Prefix => Relocate_Node (Thenx), 5606 Attribute_Name => Name_Unrestricted_Access))), 5607 5608 Else_Statements => New_List ( 5609 Make_Assignment_Statement (Sloc (Elsex), 5610 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 5611 Expression => 5612 Make_Attribute_Reference (Loc, 5613 Prefix => Relocate_Node (Elsex), 5614 Attribute_Name => Name_Unrestricted_Access)))); 5615 5616 -- Preserve the original context for which the if statement is 5617 -- being generated. This is needed by the finalization machinery 5618 -- to prevent the premature finalization of controlled objects 5619 -- found within the if statement. 5620 5621 Set_From_Conditional_Expression (New_If); 5622 5623 New_N := 5624 Make_Explicit_Dereference (Loc, 5625 Prefix => New_Occurrence_Of (Cnn, Loc)); 5626 end; 5627 5628 -- If the result is an unconstrained array and the if expression is in a 5629 -- context other than the initializing expression of the declaration of 5630 -- an object, then we pull out the if expression as follows: 5631 5632 -- Cnn : constant typ := if-expression 5633 5634 -- and then replace the if expression with an occurrence of Cnn. This 5635 -- avoids the need in the back end to create on-the-fly variable length 5636 -- temporaries (which it cannot do!) 5637 5638 -- Note that the test for being in an object declaration avoids doing an 5639 -- unnecessary expansion, and also avoids infinite recursion. 5640 5641 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) 5642 and then (Nkind (Parent (N)) /= N_Object_Declaration 5643 or else Expression (Parent (N)) /= N) 5644 then 5645 declare 5646 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); 5647 5648 begin 5649 Insert_Action (N, 5650 Make_Object_Declaration (Loc, 5651 Defining_Identifier => Cnn, 5652 Constant_Present => True, 5653 Object_Definition => New_Occurrence_Of (Typ, Loc), 5654 Expression => Relocate_Node (N), 5655 Has_Init_Expression => True)); 5656 5657 Rewrite (N, New_Occurrence_Of (Cnn, Loc)); 5658 return; 5659 end; 5660 5661 -- For other types, we only need to expand if there are other actions 5662 -- associated with either branch. 5663 5664 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then 5665 5666 -- We now wrap the actions into the appropriate expression 5667 5668 if Minimize_Expression_With_Actions 5669 and then (Is_Elementary_Type (Underlying_Type (Typ)) 5670 or else Is_Constrained (Underlying_Type (Typ))) 5671 then 5672 -- If we can't use N_Expression_With_Actions nodes, then we insert 5673 -- the following sequence of actions (using Insert_Actions): 5674 5675 -- Cnn : typ; 5676 -- if cond then 5677 -- <<then actions>> 5678 -- Cnn := then-expr; 5679 -- else 5680 -- <<else actions>> 5681 -- Cnn := else-expr 5682 -- end if; 5683 5684 -- and replace the if expression by a reference to Cnn 5685 5686 declare 5687 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); 5688 5689 begin 5690 Decl := 5691 Make_Object_Declaration (Loc, 5692 Defining_Identifier => Cnn, 5693 Object_Definition => New_Occurrence_Of (Typ, Loc)); 5694 5695 New_If := 5696 Make_Implicit_If_Statement (N, 5697 Condition => Relocate_Node (Cond), 5698 5699 Then_Statements => New_List ( 5700 Make_Assignment_Statement (Sloc (Thenx), 5701 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 5702 Expression => Relocate_Node (Thenx))), 5703 5704 Else_Statements => New_List ( 5705 Make_Assignment_Statement (Sloc (Elsex), 5706 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 5707 Expression => Relocate_Node (Elsex)))); 5708 5709 Set_Assignment_OK (Name (First (Then_Statements (New_If)))); 5710 Set_Assignment_OK (Name (First (Else_Statements (New_If)))); 5711 5712 New_N := New_Occurrence_Of (Cnn, Loc); 5713 end; 5714 5715 -- Regular path using Expression_With_Actions 5716 5717 else 5718 if Present (Then_Actions (N)) then 5719 Rewrite (Thenx, 5720 Make_Expression_With_Actions (Sloc (Thenx), 5721 Actions => Then_Actions (N), 5722 Expression => Relocate_Node (Thenx))); 5723 5724 Set_Then_Actions (N, No_List); 5725 Analyze_And_Resolve (Thenx, Typ); 5726 end if; 5727 5728 if Present (Else_Actions (N)) then 5729 Rewrite (Elsex, 5730 Make_Expression_With_Actions (Sloc (Elsex), 5731 Actions => Else_Actions (N), 5732 Expression => Relocate_Node (Elsex))); 5733 5734 Set_Else_Actions (N, No_List); 5735 Analyze_And_Resolve (Elsex, Typ); 5736 end if; 5737 5738 return; 5739 end if; 5740 5741 -- If no actions then no expansion needed, gigi will handle it using the 5742 -- same approach as a C conditional expression. 5743 5744 else 5745 return; 5746 end if; 5747 5748 -- Fall through here for either the limited expansion, or the case of 5749 -- inserting actions for nonlimited types. In both these cases, we must 5750 -- move the SLOC of the parent If statement to the newly created one and 5751 -- change it to the SLOC of the expression which, after expansion, will 5752 -- correspond to what is being evaluated. 5753 5754 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then 5755 Set_Sloc (New_If, Sloc (Parent (N))); 5756 Set_Sloc (Parent (N), Loc); 5757 end if; 5758 5759 -- Make sure Then_Actions and Else_Actions are appropriately moved 5760 -- to the new if statement. 5761 5762 if Present (Then_Actions (N)) then 5763 Insert_List_Before 5764 (First (Then_Statements (New_If)), Then_Actions (N)); 5765 end if; 5766 5767 if Present (Else_Actions (N)) then 5768 Insert_List_Before 5769 (First (Else_Statements (New_If)), Else_Actions (N)); 5770 end if; 5771 5772 Insert_Action (N, Decl); 5773 Insert_Action (N, New_If); 5774 Rewrite (N, New_N); 5775 Analyze_And_Resolve (N, Typ); 5776 end Expand_N_If_Expression; 5777 5778 ----------------- 5779 -- Expand_N_In -- 5780 ----------------- 5781 5782 procedure Expand_N_In (N : Node_Id) is 5783 Loc : constant Source_Ptr := Sloc (N); 5784 Restyp : constant Entity_Id := Etype (N); 5785 Lop : constant Node_Id := Left_Opnd (N); 5786 Rop : constant Node_Id := Right_Opnd (N); 5787 Static : constant Boolean := Is_OK_Static_Expression (N); 5788 5789 procedure Substitute_Valid_Check; 5790 -- Replaces node N by Lop'Valid. This is done when we have an explicit 5791 -- test for the left operand being in range of its subtype. 5792 5793 ---------------------------- 5794 -- Substitute_Valid_Check -- 5795 ---------------------------- 5796 5797 procedure Substitute_Valid_Check is 5798 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean; 5799 -- Determine whether arbitrary node Nod denotes a source object that 5800 -- may safely act as prefix of attribute 'Valid. 5801 5802 ---------------------------- 5803 -- Is_OK_Object_Reference -- 5804 ---------------------------- 5805 5806 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is 5807 Obj_Ref : Node_Id; 5808 5809 begin 5810 -- Inspect the original operand 5811 5812 Obj_Ref := Original_Node (Nod); 5813 5814 -- The object reference must be a source construct, otherwise the 5815 -- codefix suggestion may refer to nonexistent code from a user 5816 -- perspective. 5817 5818 if Comes_From_Source (Obj_Ref) then 5819 5820 -- Recover the actual object reference. There may be more cases 5821 -- to consider??? 5822 5823 loop 5824 if Nkind_In (Obj_Ref, N_Type_Conversion, 5825 N_Unchecked_Type_Conversion) 5826 then 5827 Obj_Ref := Expression (Obj_Ref); 5828 else 5829 exit; 5830 end if; 5831 end loop; 5832 5833 return Is_Object_Reference (Obj_Ref); 5834 end if; 5835 5836 return False; 5837 end Is_OK_Object_Reference; 5838 5839 -- Start of processing for Substitute_Valid_Check 5840 5841 begin 5842 Rewrite (N, 5843 Make_Attribute_Reference (Loc, 5844 Prefix => Relocate_Node (Lop), 5845 Attribute_Name => Name_Valid)); 5846 5847 Analyze_And_Resolve (N, Restyp); 5848 5849 -- Emit a warning when the left-hand operand of the membership test 5850 -- is a source object, otherwise the use of attribute 'Valid would be 5851 -- illegal. The warning is not given when overflow checking is either 5852 -- MINIMIZED or ELIMINATED, as the danger of optimization has been 5853 -- eliminated above. 5854 5855 if Is_OK_Object_Reference (Lop) 5856 and then Overflow_Check_Mode not in Minimized_Or_Eliminated 5857 then 5858 Error_Msg_N 5859 ("??explicit membership test may be optimized away", N); 5860 Error_Msg_N -- CODEFIX 5861 ("\??use ''Valid attribute instead", N); 5862 end if; 5863 end Substitute_Valid_Check; 5864 5865 -- Local variables 5866 5867 Ltyp : Entity_Id; 5868 Rtyp : Entity_Id; 5869 5870 -- Start of processing for Expand_N_In 5871 5872 begin 5873 -- If set membership case, expand with separate procedure 5874 5875 if Present (Alternatives (N)) then 5876 Expand_Set_Membership (N); 5877 return; 5878 end if; 5879 5880 -- Not set membership, proceed with expansion 5881 5882 Ltyp := Etype (Left_Opnd (N)); 5883 Rtyp := Etype (Right_Opnd (N)); 5884 5885 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer 5886 -- type, then expand with a separate procedure. Note the use of the 5887 -- flag No_Minimize_Eliminate to prevent infinite recursion. 5888 5889 if Overflow_Check_Mode in Minimized_Or_Eliminated 5890 and then Is_Signed_Integer_Type (Ltyp) 5891 and then not No_Minimize_Eliminate (N) 5892 then 5893 Expand_Membership_Minimize_Eliminate_Overflow (N); 5894 return; 5895 end if; 5896 5897 -- Check case of explicit test for an expression in range of its 5898 -- subtype. This is suspicious usage and we replace it with a 'Valid 5899 -- test and give a warning for scalar types. 5900 5901 if Is_Scalar_Type (Ltyp) 5902 5903 -- Only relevant for source comparisons 5904 5905 and then Comes_From_Source (N) 5906 5907 -- In floating-point this is a standard way to check for finite values 5908 -- and using 'Valid would typically be a pessimization. 5909 5910 and then not Is_Floating_Point_Type (Ltyp) 5911 5912 -- Don't give the message unless right operand is a type entity and 5913 -- the type of the left operand matches this type. Note that this 5914 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow 5915 -- checks have changed the type of the left operand. 5916 5917 and then Nkind (Rop) in N_Has_Entity 5918 and then Ltyp = Entity (Rop) 5919 5920 -- Skip this for predicated types, where such expressions are a 5921 -- reasonable way of testing if something meets the predicate. 5922 5923 and then not Present (Predicate_Function (Ltyp)) 5924 then 5925 Substitute_Valid_Check; 5926 return; 5927 end if; 5928 5929 -- Do validity check on operands 5930 5931 if Validity_Checks_On and Validity_Check_Operands then 5932 Ensure_Valid (Left_Opnd (N)); 5933 Validity_Check_Range (Right_Opnd (N)); 5934 end if; 5935 5936 -- Case of explicit range 5937 5938 if Nkind (Rop) = N_Range then 5939 declare 5940 Lo : constant Node_Id := Low_Bound (Rop); 5941 Hi : constant Node_Id := High_Bound (Rop); 5942 5943 Lo_Orig : constant Node_Id := Original_Node (Lo); 5944 Hi_Orig : constant Node_Id := Original_Node (Hi); 5945 5946 Lcheck : Compare_Result; 5947 Ucheck : Compare_Result; 5948 5949 Warn1 : constant Boolean := 5950 Constant_Condition_Warnings 5951 and then Comes_From_Source (N) 5952 and then not In_Instance; 5953 -- This must be true for any of the optimization warnings, we 5954 -- clearly want to give them only for source with the flag on. We 5955 -- also skip these warnings in an instance since it may be the 5956 -- case that different instantiations have different ranges. 5957 5958 Warn2 : constant Boolean := 5959 Warn1 5960 and then Nkind (Original_Node (Rop)) = N_Range 5961 and then Is_Integer_Type (Etype (Lo)); 5962 -- For the case where only one bound warning is elided, we also 5963 -- insist on an explicit range and an integer type. The reason is 5964 -- that the use of enumeration ranges including an end point is 5965 -- common, as is the use of a subtype name, one of whose bounds is 5966 -- the same as the type of the expression. 5967 5968 begin 5969 -- If test is explicit x'First .. x'Last, replace by valid check 5970 5971 -- Could use some individual comments for this complex test ??? 5972 5973 if Is_Scalar_Type (Ltyp) 5974 5975 -- And left operand is X'First where X matches left operand 5976 -- type (this eliminates cases of type mismatch, including 5977 -- the cases where ELIMINATED/MINIMIZED mode has changed the 5978 -- type of the left operand. 5979 5980 and then Nkind (Lo_Orig) = N_Attribute_Reference 5981 and then Attribute_Name (Lo_Orig) = Name_First 5982 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity 5983 and then Entity (Prefix (Lo_Orig)) = Ltyp 5984 5985 -- Same tests for right operand 5986 5987 and then Nkind (Hi_Orig) = N_Attribute_Reference 5988 and then Attribute_Name (Hi_Orig) = Name_Last 5989 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity 5990 and then Entity (Prefix (Hi_Orig)) = Ltyp 5991 5992 -- Relevant only for source cases 5993 5994 and then Comes_From_Source (N) 5995 then 5996 Substitute_Valid_Check; 5997 goto Leave; 5998 end if; 5999 6000 -- If bounds of type are known at compile time, and the end points 6001 -- are known at compile time and identical, this is another case 6002 -- for substituting a valid test. We only do this for discrete 6003 -- types, since it won't arise in practice for float types. 6004 6005 if Comes_From_Source (N) 6006 and then Is_Discrete_Type (Ltyp) 6007 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) 6008 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) 6009 and then Compile_Time_Known_Value (Lo) 6010 and then Compile_Time_Known_Value (Hi) 6011 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) 6012 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) 6013 6014 -- Kill warnings in instances, since they may be cases where we 6015 -- have a test in the generic that makes sense with some types 6016 -- and not with other types. 6017 6018 -- Similarly, do not rewrite membership as a validity check if 6019 -- within the predicate function for the type. 6020 6021 then 6022 if In_Instance 6023 or else (Ekind (Current_Scope) = E_Function 6024 and then Is_Predicate_Function (Current_Scope)) 6025 then 6026 null; 6027 6028 else 6029 Substitute_Valid_Check; 6030 goto Leave; 6031 end if; 6032 end if; 6033 6034 -- If we have an explicit range, do a bit of optimization based on 6035 -- range analysis (we may be able to kill one or both checks). 6036 6037 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); 6038 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); 6039 6040 -- If either check is known to fail, replace result by False since 6041 -- the other check does not matter. Preserve the static flag for 6042 -- legality checks, because we are constant-folding beyond RM 4.9. 6043 6044 if Lcheck = LT or else Ucheck = GT then 6045 if Warn1 then 6046 Error_Msg_N ("?c?range test optimized away", N); 6047 Error_Msg_N ("\?c?value is known to be out of range", N); 6048 end if; 6049 6050 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6051 Analyze_And_Resolve (N, Restyp); 6052 Set_Is_Static_Expression (N, Static); 6053 goto Leave; 6054 6055 -- If both checks are known to succeed, replace result by True, 6056 -- since we know we are in range. 6057 6058 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 6059 if Warn1 then 6060 Error_Msg_N ("?c?range test optimized away", N); 6061 Error_Msg_N ("\?c?value is known to be in range", N); 6062 end if; 6063 6064 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6065 Analyze_And_Resolve (N, Restyp); 6066 Set_Is_Static_Expression (N, Static); 6067 goto Leave; 6068 6069 -- If lower bound check succeeds and upper bound check is not 6070 -- known to succeed or fail, then replace the range check with 6071 -- a comparison against the upper bound. 6072 6073 elsif Lcheck in Compare_GE then 6074 if Warn2 and then not In_Instance then 6075 Error_Msg_N ("??lower bound test optimized away", Lo); 6076 Error_Msg_N ("\??value is known to be in range", Lo); 6077 end if; 6078 6079 Rewrite (N, 6080 Make_Op_Le (Loc, 6081 Left_Opnd => Lop, 6082 Right_Opnd => High_Bound (Rop))); 6083 Analyze_And_Resolve (N, Restyp); 6084 goto Leave; 6085 6086 -- If upper bound check succeeds and lower bound check is not 6087 -- known to succeed or fail, then replace the range check with 6088 -- a comparison against the lower bound. 6089 6090 elsif Ucheck in Compare_LE then 6091 if Warn2 and then not In_Instance then 6092 Error_Msg_N ("??upper bound test optimized away", Hi); 6093 Error_Msg_N ("\??value is known to be in range", Hi); 6094 end if; 6095 6096 Rewrite (N, 6097 Make_Op_Ge (Loc, 6098 Left_Opnd => Lop, 6099 Right_Opnd => Low_Bound (Rop))); 6100 Analyze_And_Resolve (N, Restyp); 6101 goto Leave; 6102 end if; 6103 6104 -- We couldn't optimize away the range check, but there is one 6105 -- more issue. If we are checking constant conditionals, then we 6106 -- see if we can determine the outcome assuming everything is 6107 -- valid, and if so give an appropriate warning. 6108 6109 if Warn1 and then not Assume_No_Invalid_Values then 6110 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True); 6111 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True); 6112 6113 -- Result is out of range for valid value 6114 6115 if Lcheck = LT or else Ucheck = GT then 6116 Error_Msg_N 6117 ("?c?value can only be in range if it is invalid", N); 6118 6119 -- Result is in range for valid value 6120 6121 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 6122 Error_Msg_N 6123 ("?c?value can only be out of range if it is invalid", N); 6124 6125 -- Lower bound check succeeds if value is valid 6126 6127 elsif Warn2 and then Lcheck in Compare_GE then 6128 Error_Msg_N 6129 ("?c?lower bound check only fails if it is invalid", Lo); 6130 6131 -- Upper bound check succeeds if value is valid 6132 6133 elsif Warn2 and then Ucheck in Compare_LE then 6134 Error_Msg_N 6135 ("?c?upper bound check only fails for invalid values", Hi); 6136 end if; 6137 end if; 6138 end; 6139 6140 -- For all other cases of an explicit range, nothing to be done 6141 6142 goto Leave; 6143 6144 -- Here right operand is a subtype mark 6145 6146 else 6147 declare 6148 Typ : Entity_Id := Etype (Rop); 6149 Is_Acc : constant Boolean := Is_Access_Type (Typ); 6150 Cond : Node_Id := Empty; 6151 New_N : Node_Id; 6152 Obj : Node_Id := Lop; 6153 SCIL_Node : Node_Id; 6154 6155 begin 6156 Remove_Side_Effects (Obj); 6157 6158 -- For tagged type, do tagged membership operation 6159 6160 if Is_Tagged_Type (Typ) then 6161 6162 -- No expansion will be performed for VM targets, as the VM 6163 -- back ends will handle the membership tests directly. 6164 6165 if Tagged_Type_Expansion then 6166 Tagged_Membership (N, SCIL_Node, New_N); 6167 Rewrite (N, New_N); 6168 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks); 6169 6170 -- Update decoration of relocated node referenced by the 6171 -- SCIL node. 6172 6173 if Generate_SCIL and then Present (SCIL_Node) then 6174 Set_SCIL_Node (N, SCIL_Node); 6175 end if; 6176 end if; 6177 6178 goto Leave; 6179 6180 -- If type is scalar type, rewrite as x in t'First .. t'Last. 6181 -- This reason we do this is that the bounds may have the wrong 6182 -- type if they come from the original type definition. Also this 6183 -- way we get all the processing above for an explicit range. 6184 6185 -- Don't do this for predicated types, since in this case we 6186 -- want to check the predicate. 6187 6188 elsif Is_Scalar_Type (Typ) then 6189 if No (Predicate_Function (Typ)) then 6190 Rewrite (Rop, 6191 Make_Range (Loc, 6192 Low_Bound => 6193 Make_Attribute_Reference (Loc, 6194 Attribute_Name => Name_First, 6195 Prefix => New_Occurrence_Of (Typ, Loc)), 6196 6197 High_Bound => 6198 Make_Attribute_Reference (Loc, 6199 Attribute_Name => Name_Last, 6200 Prefix => New_Occurrence_Of (Typ, Loc)))); 6201 Analyze_And_Resolve (N, Restyp); 6202 end if; 6203 6204 goto Leave; 6205 6206 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 6207 -- a membership test if the subtype mark denotes a constrained 6208 -- Unchecked_Union subtype and the expression lacks inferable 6209 -- discriminants. 6210 6211 elsif Is_Unchecked_Union (Base_Type (Typ)) 6212 and then Is_Constrained (Typ) 6213 and then not Has_Inferable_Discriminants (Lop) 6214 then 6215 Insert_Action (N, 6216 Make_Raise_Program_Error (Loc, 6217 Reason => PE_Unchecked_Union_Restriction)); 6218 6219 -- Prevent Gigi from generating incorrect code by rewriting the 6220 -- test as False. What is this undocumented thing about ??? 6221 6222 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6223 goto Leave; 6224 end if; 6225 6226 -- Here we have a non-scalar type 6227 6228 if Is_Acc then 6229 Typ := Designated_Type (Typ); 6230 end if; 6231 6232 if not Is_Constrained (Typ) then 6233 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6234 Analyze_And_Resolve (N, Restyp); 6235 6236 -- For the constrained array case, we have to check the subscripts 6237 -- for an exact match if the lengths are non-zero (the lengths 6238 -- must match in any case). 6239 6240 elsif Is_Array_Type (Typ) then 6241 Check_Subscripts : declare 6242 function Build_Attribute_Reference 6243 (E : Node_Id; 6244 Nam : Name_Id; 6245 Dim : Nat) return Node_Id; 6246 -- Build attribute reference E'Nam (Dim) 6247 6248 ------------------------------- 6249 -- Build_Attribute_Reference -- 6250 ------------------------------- 6251 6252 function Build_Attribute_Reference 6253 (E : Node_Id; 6254 Nam : Name_Id; 6255 Dim : Nat) return Node_Id 6256 is 6257 begin 6258 return 6259 Make_Attribute_Reference (Loc, 6260 Prefix => E, 6261 Attribute_Name => Nam, 6262 Expressions => New_List ( 6263 Make_Integer_Literal (Loc, Dim))); 6264 end Build_Attribute_Reference; 6265 6266 -- Start of processing for Check_Subscripts 6267 6268 begin 6269 for J in 1 .. Number_Dimensions (Typ) loop 6270 Evolve_And_Then (Cond, 6271 Make_Op_Eq (Loc, 6272 Left_Opnd => 6273 Build_Attribute_Reference 6274 (Duplicate_Subexpr_No_Checks (Obj), 6275 Name_First, J), 6276 Right_Opnd => 6277 Build_Attribute_Reference 6278 (New_Occurrence_Of (Typ, Loc), Name_First, J))); 6279 6280 Evolve_And_Then (Cond, 6281 Make_Op_Eq (Loc, 6282 Left_Opnd => 6283 Build_Attribute_Reference 6284 (Duplicate_Subexpr_No_Checks (Obj), 6285 Name_Last, J), 6286 Right_Opnd => 6287 Build_Attribute_Reference 6288 (New_Occurrence_Of (Typ, Loc), Name_Last, J))); 6289 end loop; 6290 6291 if Is_Acc then 6292 Cond := 6293 Make_Or_Else (Loc, 6294 Left_Opnd => 6295 Make_Op_Eq (Loc, 6296 Left_Opnd => Obj, 6297 Right_Opnd => Make_Null (Loc)), 6298 Right_Opnd => Cond); 6299 end if; 6300 6301 Rewrite (N, Cond); 6302 Analyze_And_Resolve (N, Restyp); 6303 end Check_Subscripts; 6304 6305 -- These are the cases where constraint checks may be required, 6306 -- e.g. records with possible discriminants 6307 6308 else 6309 -- Expand the test into a series of discriminant comparisons. 6310 -- The expression that is built is the negation of the one that 6311 -- is used for checking discriminant constraints. 6312 6313 Obj := Relocate_Node (Left_Opnd (N)); 6314 6315 if Has_Discriminants (Typ) then 6316 Cond := Make_Op_Not (Loc, 6317 Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); 6318 6319 if Is_Acc then 6320 Cond := Make_Or_Else (Loc, 6321 Left_Opnd => 6322 Make_Op_Eq (Loc, 6323 Left_Opnd => Obj, 6324 Right_Opnd => Make_Null (Loc)), 6325 Right_Opnd => Cond); 6326 end if; 6327 6328 else 6329 Cond := New_Occurrence_Of (Standard_True, Loc); 6330 end if; 6331 6332 Rewrite (N, Cond); 6333 Analyze_And_Resolve (N, Restyp); 6334 end if; 6335 6336 -- Ada 2012 (AI05-0149): Handle membership tests applied to an 6337 -- expression of an anonymous access type. This can involve an 6338 -- accessibility test and a tagged type membership test in the 6339 -- case of tagged designated types. 6340 6341 if Ada_Version >= Ada_2012 6342 and then Is_Acc 6343 and then Ekind (Ltyp) = E_Anonymous_Access_Type 6344 then 6345 declare 6346 Expr_Entity : Entity_Id := Empty; 6347 New_N : Node_Id; 6348 Param_Level : Node_Id; 6349 Type_Level : Node_Id; 6350 6351 begin 6352 if Is_Entity_Name (Lop) then 6353 Expr_Entity := Param_Entity (Lop); 6354 6355 if not Present (Expr_Entity) then 6356 Expr_Entity := Entity (Lop); 6357 end if; 6358 end if; 6359 6360 -- If a conversion of the anonymous access value to the 6361 -- tested type would be illegal, then the result is False. 6362 6363 if not Valid_Conversion 6364 (Lop, Rtyp, Lop, Report_Errs => False) 6365 then 6366 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6367 Analyze_And_Resolve (N, Restyp); 6368 6369 -- Apply an accessibility check if the access object has an 6370 -- associated access level and when the level of the type is 6371 -- less deep than the level of the access parameter. This 6372 -- only occur for access parameters and stand-alone objects 6373 -- of an anonymous access type. 6374 6375 else 6376 if Present (Expr_Entity) 6377 and then 6378 Present 6379 (Effective_Extra_Accessibility (Expr_Entity)) 6380 and then UI_Gt (Object_Access_Level (Lop), 6381 Type_Access_Level (Rtyp)) 6382 then 6383 Param_Level := 6384 New_Occurrence_Of 6385 (Effective_Extra_Accessibility (Expr_Entity), Loc); 6386 6387 Type_Level := 6388 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); 6389 6390 -- Return True only if the accessibility level of the 6391 -- expression entity is not deeper than the level of 6392 -- the tested access type. 6393 6394 Rewrite (N, 6395 Make_And_Then (Loc, 6396 Left_Opnd => Relocate_Node (N), 6397 Right_Opnd => Make_Op_Le (Loc, 6398 Left_Opnd => Param_Level, 6399 Right_Opnd => Type_Level))); 6400 6401 Analyze_And_Resolve (N); 6402 end if; 6403 6404 -- If the designated type is tagged, do tagged membership 6405 -- operation. 6406 6407 -- *** NOTE: we have to check not null before doing the 6408 -- tagged membership test (but maybe that can be done 6409 -- inside Tagged_Membership?). 6410 6411 if Is_Tagged_Type (Typ) then 6412 Rewrite (N, 6413 Make_And_Then (Loc, 6414 Left_Opnd => Relocate_Node (N), 6415 Right_Opnd => 6416 Make_Op_Ne (Loc, 6417 Left_Opnd => Obj, 6418 Right_Opnd => Make_Null (Loc)))); 6419 6420 -- No expansion will be performed for VM targets, as 6421 -- the VM back ends will handle the membership tests 6422 -- directly. 6423 6424 if Tagged_Type_Expansion then 6425 6426 -- Note that we have to pass Original_Node, because 6427 -- the membership test might already have been 6428 -- rewritten by earlier parts of membership test. 6429 6430 Tagged_Membership 6431 (Original_Node (N), SCIL_Node, New_N); 6432 6433 -- Update decoration of relocated node referenced 6434 -- by the SCIL node. 6435 6436 if Generate_SCIL and then Present (SCIL_Node) then 6437 Set_SCIL_Node (New_N, SCIL_Node); 6438 end if; 6439 6440 Rewrite (N, 6441 Make_And_Then (Loc, 6442 Left_Opnd => Relocate_Node (N), 6443 Right_Opnd => New_N)); 6444 6445 Analyze_And_Resolve (N, Restyp); 6446 end if; 6447 end if; 6448 end if; 6449 end; 6450 end if; 6451 end; 6452 end if; 6453 6454 -- At this point, we have done the processing required for the basic 6455 -- membership test, but not yet dealt with the predicate. 6456 6457 <<Leave>> 6458 6459 -- If a predicate is present, then we do the predicate test, but we 6460 -- most certainly want to omit this if we are within the predicate 6461 -- function itself, since otherwise we have an infinite recursion. 6462 -- The check should also not be emitted when testing against a range 6463 -- (the check is only done when the right operand is a subtype; see 6464 -- RM12-4.5.2 (28.1/3-30/3)). 6465 6466 Predicate_Check : declare 6467 function In_Range_Check return Boolean; 6468 -- Within an expanded range check that may raise Constraint_Error do 6469 -- not generate a predicate check as well. It is redundant because 6470 -- the context will add an explicit predicate check, and it will 6471 -- raise the wrong exception if it fails. 6472 6473 -------------------- 6474 -- In_Range_Check -- 6475 -------------------- 6476 6477 function In_Range_Check return Boolean is 6478 P : Node_Id; 6479 begin 6480 P := Parent (N); 6481 while Present (P) loop 6482 if Nkind (P) = N_Raise_Constraint_Error then 6483 return True; 6484 6485 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call 6486 or else Nkind (P) = N_Procedure_Call_Statement 6487 or else Nkind (P) in N_Declaration 6488 then 6489 return False; 6490 end if; 6491 6492 P := Parent (P); 6493 end loop; 6494 6495 return False; 6496 end In_Range_Check; 6497 6498 -- Local variables 6499 6500 PFunc : constant Entity_Id := Predicate_Function (Rtyp); 6501 R_Op : Node_Id; 6502 6503 -- Start of processing for Predicate_Check 6504 6505 begin 6506 if Present (PFunc) 6507 and then Current_Scope /= PFunc 6508 and then Nkind (Rop) /= N_Range 6509 then 6510 if not In_Range_Check then 6511 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True); 6512 else 6513 R_Op := New_Occurrence_Of (Standard_True, Loc); 6514 end if; 6515 6516 Rewrite (N, 6517 Make_And_Then (Loc, 6518 Left_Opnd => Relocate_Node (N), 6519 Right_Opnd => R_Op)); 6520 6521 -- Analyze new expression, mark left operand as analyzed to 6522 -- avoid infinite recursion adding predicate calls. Similarly, 6523 -- suppress further range checks on the call. 6524 6525 Set_Analyzed (Left_Opnd (N)); 6526 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 6527 6528 -- All done, skip attempt at compile time determination of result 6529 6530 return; 6531 end if; 6532 end Predicate_Check; 6533 end Expand_N_In; 6534 6535 -------------------------------- 6536 -- Expand_N_Indexed_Component -- 6537 -------------------------------- 6538 6539 procedure Expand_N_Indexed_Component (N : Node_Id) is 6540 Loc : constant Source_Ptr := Sloc (N); 6541 Typ : constant Entity_Id := Etype (N); 6542 P : constant Node_Id := Prefix (N); 6543 T : constant Entity_Id := Etype (P); 6544 Atp : Entity_Id; 6545 6546 begin 6547 -- A special optimization, if we have an indexed component that is 6548 -- selecting from a slice, then we can eliminate the slice, since, for 6549 -- example, x (i .. j)(k) is identical to x(k). The only difference is 6550 -- the range check required by the slice. The range check for the slice 6551 -- itself has already been generated. The range check for the 6552 -- subscripting operation is ensured by converting the subject to 6553 -- the subtype of the slice. 6554 6555 -- This optimization not only generates better code, avoiding slice 6556 -- messing especially in the packed case, but more importantly bypasses 6557 -- some problems in handling this peculiar case, for example, the issue 6558 -- of dealing specially with object renamings. 6559 6560 if Nkind (P) = N_Slice 6561 6562 -- This optimization is disabled for CodePeer because it can transform 6563 -- an index-check constraint_error into a range-check constraint_error 6564 -- and CodePeer cares about that distinction. 6565 6566 and then not CodePeer_Mode 6567 then 6568 Rewrite (N, 6569 Make_Indexed_Component (Loc, 6570 Prefix => Prefix (P), 6571 Expressions => New_List ( 6572 Convert_To 6573 (Etype (First_Index (Etype (P))), 6574 First (Expressions (N)))))); 6575 Analyze_And_Resolve (N, Typ); 6576 return; 6577 end if; 6578 6579 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 6580 -- function, then additional actuals must be passed. 6581 6582 if Is_Build_In_Place_Function_Call (P) then 6583 Make_Build_In_Place_Call_In_Anonymous_Context (P); 6584 6585 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 6586 -- containing build-in-place function calls whose returned object covers 6587 -- interface types. 6588 6589 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then 6590 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); 6591 end if; 6592 6593 -- If the prefix is an access type, then we unconditionally rewrite if 6594 -- as an explicit dereference. This simplifies processing for several 6595 -- cases, including packed array cases and certain cases in which checks 6596 -- must be generated. We used to try to do this only when it was 6597 -- necessary, but it cleans up the code to do it all the time. 6598 6599 if Is_Access_Type (T) then 6600 Insert_Explicit_Dereference (P); 6601 Analyze_And_Resolve (P, Designated_Type (T)); 6602 Atp := Designated_Type (T); 6603 else 6604 Atp := T; 6605 end if; 6606 6607 -- Generate index and validity checks 6608 6609 Generate_Index_Checks (N); 6610 6611 if Validity_Checks_On and then Validity_Check_Subscripts then 6612 Apply_Subscript_Validity_Checks (N); 6613 end if; 6614 6615 -- If selecting from an array with atomic components, and atomic sync 6616 -- is not suppressed for this array type, set atomic sync flag. 6617 6618 if (Has_Atomic_Components (Atp) 6619 and then not Atomic_Synchronization_Disabled (Atp)) 6620 or else (Is_Atomic (Typ) 6621 and then not Atomic_Synchronization_Disabled (Typ)) 6622 or else (Is_Entity_Name (P) 6623 and then Has_Atomic_Components (Entity (P)) 6624 and then not Atomic_Synchronization_Disabled (Entity (P))) 6625 then 6626 Activate_Atomic_Synchronization (N); 6627 end if; 6628 6629 -- All done if the prefix is not a packed array implemented specially 6630 6631 if not (Is_Packed (Etype (Prefix (N))) 6632 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N))))) 6633 then 6634 return; 6635 end if; 6636 6637 -- For packed arrays that are not bit-packed (i.e. the case of an array 6638 -- with one or more index types with a non-contiguous enumeration type), 6639 -- we can always use the normal packed element get circuit. 6640 6641 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then 6642 Expand_Packed_Element_Reference (N); 6643 return; 6644 end if; 6645 6646 -- For a reference to a component of a bit packed array, we convert it 6647 -- to a reference to the corresponding Packed_Array_Impl_Type. We only 6648 -- want to do this for simple references, and not for: 6649 6650 -- Left side of assignment, or prefix of left side of assignment, or 6651 -- prefix of the prefix, to handle packed arrays of packed arrays, 6652 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement 6653 6654 -- Renaming objects in renaming associations 6655 -- This case is handled when a use of the renamed variable occurs 6656 6657 -- Actual parameters for a procedure call 6658 -- This case is handled in Exp_Ch6.Expand_Actuals 6659 6660 -- The second expression in a 'Read attribute reference 6661 6662 -- The prefix of an address or bit or size attribute reference 6663 6664 -- The following circuit detects these exceptions. Note that we need to 6665 -- deal with implicit dereferences when climbing up the parent chain, 6666 -- with the additional difficulty that the type of parents may have yet 6667 -- to be resolved since prefixes are usually resolved first. 6668 6669 declare 6670 Child : Node_Id := N; 6671 Parnt : Node_Id := Parent (N); 6672 6673 begin 6674 loop 6675 if Nkind (Parnt) = N_Unchecked_Expression then 6676 null; 6677 6678 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration, 6679 N_Procedure_Call_Statement) 6680 or else (Nkind (Parnt) = N_Parameter_Association 6681 and then 6682 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) 6683 then 6684 return; 6685 6686 elsif Nkind (Parnt) = N_Attribute_Reference 6687 and then Nam_In (Attribute_Name (Parnt), Name_Address, 6688 Name_Bit, 6689 Name_Size) 6690 and then Prefix (Parnt) = Child 6691 then 6692 return; 6693 6694 elsif Nkind (Parnt) = N_Assignment_Statement 6695 and then Name (Parnt) = Child 6696 then 6697 return; 6698 6699 -- If the expression is an index of an indexed component, it must 6700 -- be expanded regardless of context. 6701 6702 elsif Nkind (Parnt) = N_Indexed_Component 6703 and then Child /= Prefix (Parnt) 6704 then 6705 Expand_Packed_Element_Reference (N); 6706 return; 6707 6708 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement 6709 and then Name (Parent (Parnt)) = Parnt 6710 then 6711 return; 6712 6713 elsif Nkind (Parnt) = N_Attribute_Reference 6714 and then Attribute_Name (Parnt) = Name_Read 6715 and then Next (First (Expressions (Parnt))) = Child 6716 then 6717 return; 6718 6719 elsif Nkind (Parnt) = N_Indexed_Component 6720 and then Prefix (Parnt) = Child 6721 then 6722 null; 6723 6724 elsif Nkind (Parnt) = N_Selected_Component 6725 and then Prefix (Parnt) = Child 6726 and then not (Present (Etype (Selector_Name (Parnt))) 6727 and then 6728 Is_Access_Type (Etype (Selector_Name (Parnt)))) 6729 then 6730 null; 6731 6732 -- If the parent is a dereference, either implicit or explicit, 6733 -- then the packed reference needs to be expanded. 6734 6735 else 6736 Expand_Packed_Element_Reference (N); 6737 return; 6738 end if; 6739 6740 -- Keep looking up tree for unchecked expression, or if we are the 6741 -- prefix of a possible assignment left side. 6742 6743 Child := Parnt; 6744 Parnt := Parent (Child); 6745 end loop; 6746 end; 6747 end Expand_N_Indexed_Component; 6748 6749 --------------------- 6750 -- Expand_N_Not_In -- 6751 --------------------- 6752 6753 -- Replace a not in b by not (a in b) so that the expansions for (a in b) 6754 -- can be done. This avoids needing to duplicate this expansion code. 6755 6756 procedure Expand_N_Not_In (N : Node_Id) is 6757 Loc : constant Source_Ptr := Sloc (N); 6758 Typ : constant Entity_Id := Etype (N); 6759 Cfs : constant Boolean := Comes_From_Source (N); 6760 6761 begin 6762 Rewrite (N, 6763 Make_Op_Not (Loc, 6764 Right_Opnd => 6765 Make_In (Loc, 6766 Left_Opnd => Left_Opnd (N), 6767 Right_Opnd => Right_Opnd (N)))); 6768 6769 -- If this is a set membership, preserve list of alternatives 6770 6771 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); 6772 6773 -- We want this to appear as coming from source if original does (see 6774 -- transformations in Expand_N_In). 6775 6776 Set_Comes_From_Source (N, Cfs); 6777 Set_Comes_From_Source (Right_Opnd (N), Cfs); 6778 6779 -- Now analyze transformed node 6780 6781 Analyze_And_Resolve (N, Typ); 6782 end Expand_N_Not_In; 6783 6784 ------------------- 6785 -- Expand_N_Null -- 6786 ------------------- 6787 6788 -- The only replacement required is for the case of a null of a type that 6789 -- is an access to protected subprogram, or a subtype thereof. We represent 6790 -- such access values as a record, and so we must replace the occurrence of 6791 -- null by the equivalent record (with a null address and a null pointer in 6792 -- it), so that the back end creates the proper value. 6793 6794 procedure Expand_N_Null (N : Node_Id) is 6795 Loc : constant Source_Ptr := Sloc (N); 6796 Typ : constant Entity_Id := Base_Type (Etype (N)); 6797 Agg : Node_Id; 6798 6799 begin 6800 if Is_Access_Protected_Subprogram_Type (Typ) then 6801 Agg := 6802 Make_Aggregate (Loc, 6803 Expressions => New_List ( 6804 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 6805 Make_Null (Loc))); 6806 6807 Rewrite (N, Agg); 6808 Analyze_And_Resolve (N, Equivalent_Type (Typ)); 6809 6810 -- For subsequent semantic analysis, the node must retain its type. 6811 -- Gigi in any case replaces this type by the corresponding record 6812 -- type before processing the node. 6813 6814 Set_Etype (N, Typ); 6815 end if; 6816 6817 exception 6818 when RE_Not_Available => 6819 return; 6820 end Expand_N_Null; 6821 6822 --------------------- 6823 -- Expand_N_Op_Abs -- 6824 --------------------- 6825 6826 procedure Expand_N_Op_Abs (N : Node_Id) is 6827 Loc : constant Source_Ptr := Sloc (N); 6828 Expr : constant Node_Id := Right_Opnd (N); 6829 6830 begin 6831 Unary_Op_Validity_Checks (N); 6832 6833 -- Check for MINIMIZED/ELIMINATED overflow mode 6834 6835 if Minimized_Eliminated_Overflow_Check (N) then 6836 Apply_Arithmetic_Overflow_Check (N); 6837 return; 6838 end if; 6839 6840 -- Deal with software overflow checking 6841 6842 if not Backend_Overflow_Checks_On_Target 6843 and then Is_Signed_Integer_Type (Etype (N)) 6844 and then Do_Overflow_Check (N) 6845 then 6846 -- The only case to worry about is when the argument is equal to the 6847 -- largest negative number, so what we do is to insert the check: 6848 6849 -- [constraint_error when Expr = typ'Base'First] 6850 6851 -- with the usual Duplicate_Subexpr use coding for expr 6852 6853 Insert_Action (N, 6854 Make_Raise_Constraint_Error (Loc, 6855 Condition => 6856 Make_Op_Eq (Loc, 6857 Left_Opnd => Duplicate_Subexpr (Expr), 6858 Right_Opnd => 6859 Make_Attribute_Reference (Loc, 6860 Prefix => 6861 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), 6862 Attribute_Name => Name_First)), 6863 Reason => CE_Overflow_Check_Failed)); 6864 end if; 6865 end Expand_N_Op_Abs; 6866 6867 --------------------- 6868 -- Expand_N_Op_Add -- 6869 --------------------- 6870 6871 procedure Expand_N_Op_Add (N : Node_Id) is 6872 Typ : constant Entity_Id := Etype (N); 6873 6874 begin 6875 Binary_Op_Validity_Checks (N); 6876 6877 -- Check for MINIMIZED/ELIMINATED overflow mode 6878 6879 if Minimized_Eliminated_Overflow_Check (N) then 6880 Apply_Arithmetic_Overflow_Check (N); 6881 return; 6882 end if; 6883 6884 -- N + 0 = 0 + N = N for integer types 6885 6886 if Is_Integer_Type (Typ) then 6887 if Compile_Time_Known_Value (Right_Opnd (N)) 6888 and then Expr_Value (Right_Opnd (N)) = Uint_0 6889 then 6890 Rewrite (N, Left_Opnd (N)); 6891 return; 6892 6893 elsif Compile_Time_Known_Value (Left_Opnd (N)) 6894 and then Expr_Value (Left_Opnd (N)) = Uint_0 6895 then 6896 Rewrite (N, Right_Opnd (N)); 6897 return; 6898 end if; 6899 end if; 6900 6901 -- Arithmetic overflow checks for signed integer/fixed point types 6902 6903 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then 6904 Apply_Arithmetic_Overflow_Check (N); 6905 return; 6906 end if; 6907 6908 -- Overflow checks for floating-point if -gnateF mode active 6909 6910 Check_Float_Op_Overflow (N); 6911 6912 Expand_Nonbinary_Modular_Op (N); 6913 end Expand_N_Op_Add; 6914 6915 --------------------- 6916 -- Expand_N_Op_And -- 6917 --------------------- 6918 6919 procedure Expand_N_Op_And (N : Node_Id) is 6920 Typ : constant Entity_Id := Etype (N); 6921 6922 begin 6923 Binary_Op_Validity_Checks (N); 6924 6925 if Is_Array_Type (Etype (N)) then 6926 Expand_Boolean_Operator (N); 6927 6928 elsif Is_Boolean_Type (Etype (N)) then 6929 Adjust_Condition (Left_Opnd (N)); 6930 Adjust_Condition (Right_Opnd (N)); 6931 Set_Etype (N, Standard_Boolean); 6932 Adjust_Result_Type (N, Typ); 6933 6934 elsif Is_Intrinsic_Subprogram (Entity (N)) then 6935 Expand_Intrinsic_Call (N, Entity (N)); 6936 end if; 6937 6938 Expand_Nonbinary_Modular_Op (N); 6939 end Expand_N_Op_And; 6940 6941 ------------------------ 6942 -- Expand_N_Op_Concat -- 6943 ------------------------ 6944 6945 procedure Expand_N_Op_Concat (N : Node_Id) is 6946 Opnds : List_Id; 6947 -- List of operands to be concatenated 6948 6949 Cnode : Node_Id; 6950 -- Node which is to be replaced by the result of concatenating the nodes 6951 -- in the list Opnds. 6952 6953 begin 6954 -- Ensure validity of both operands 6955 6956 Binary_Op_Validity_Checks (N); 6957 6958 -- If we are the left operand of a concatenation higher up the tree, 6959 -- then do nothing for now, since we want to deal with a series of 6960 -- concatenations as a unit. 6961 6962 if Nkind (Parent (N)) = N_Op_Concat 6963 and then N = Left_Opnd (Parent (N)) 6964 then 6965 return; 6966 end if; 6967 6968 -- We get here with a concatenation whose left operand may be a 6969 -- concatenation itself with a consistent type. We need to process 6970 -- these concatenation operands from left to right, which means 6971 -- from the deepest node in the tree to the highest node. 6972 6973 Cnode := N; 6974 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop 6975 Cnode := Left_Opnd (Cnode); 6976 end loop; 6977 6978 -- Now Cnode is the deepest concatenation, and its parents are the 6979 -- concatenation nodes above, so now we process bottom up, doing the 6980 -- operands. 6981 6982 -- The outer loop runs more than once if more than one concatenation 6983 -- type is involved. 6984 6985 Outer : loop 6986 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); 6987 Set_Parent (Opnds, N); 6988 6989 -- The inner loop gathers concatenation operands 6990 6991 Inner : while Cnode /= N 6992 and then Base_Type (Etype (Cnode)) = 6993 Base_Type (Etype (Parent (Cnode))) 6994 loop 6995 Cnode := Parent (Cnode); 6996 Append (Right_Opnd (Cnode), Opnds); 6997 end loop Inner; 6998 6999 -- Note: The following code is a temporary workaround for N731-034 7000 -- and N829-028 and will be kept until the general issue of internal 7001 -- symbol serialization is addressed. The workaround is kept under a 7002 -- debug switch to avoid permiating into the general case. 7003 7004 -- Wrap the node to concatenate into an expression actions node to 7005 -- keep it nicely packaged. This is useful in the case of an assert 7006 -- pragma with a concatenation where we want to be able to delete 7007 -- the concatenation and all its expansion stuff. 7008 7009 if Debug_Flag_Dot_H then 7010 declare 7011 Cnod : constant Node_Id := New_Copy_Tree (Cnode); 7012 Typ : constant Entity_Id := Base_Type (Etype (Cnode)); 7013 7014 begin 7015 -- Note: use Rewrite rather than Replace here, so that for 7016 -- example Why_Not_Static can find the original concatenation 7017 -- node OK! 7018 7019 Rewrite (Cnode, 7020 Make_Expression_With_Actions (Sloc (Cnode), 7021 Actions => New_List (Make_Null_Statement (Sloc (Cnode))), 7022 Expression => Cnod)); 7023 7024 Expand_Concatenate (Cnod, Opnds); 7025 Analyze_And_Resolve (Cnode, Typ); 7026 end; 7027 7028 -- Default case 7029 7030 else 7031 Expand_Concatenate (Cnode, Opnds); 7032 end if; 7033 7034 exit Outer when Cnode = N; 7035 Cnode := Parent (Cnode); 7036 end loop Outer; 7037 end Expand_N_Op_Concat; 7038 7039 ------------------------ 7040 -- Expand_N_Op_Divide -- 7041 ------------------------ 7042 7043 procedure Expand_N_Op_Divide (N : Node_Id) is 7044 Loc : constant Source_Ptr := Sloc (N); 7045 Lopnd : constant Node_Id := Left_Opnd (N); 7046 Ropnd : constant Node_Id := Right_Opnd (N); 7047 Ltyp : constant Entity_Id := Etype (Lopnd); 7048 Rtyp : constant Entity_Id := Etype (Ropnd); 7049 Typ : Entity_Id := Etype (N); 7050 Rknow : constant Boolean := Is_Integer_Type (Typ) 7051 and then 7052 Compile_Time_Known_Value (Ropnd); 7053 Rval : Uint; 7054 7055 begin 7056 Binary_Op_Validity_Checks (N); 7057 7058 -- Check for MINIMIZED/ELIMINATED overflow mode 7059 7060 if Minimized_Eliminated_Overflow_Check (N) then 7061 Apply_Arithmetic_Overflow_Check (N); 7062 return; 7063 end if; 7064 7065 -- Otherwise proceed with expansion of division 7066 7067 if Rknow then 7068 Rval := Expr_Value (Ropnd); 7069 end if; 7070 7071 -- N / 1 = N for integer types 7072 7073 if Rknow and then Rval = Uint_1 then 7074 Rewrite (N, Lopnd); 7075 return; 7076 end if; 7077 7078 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that 7079 -- Is_Power_Of_2_For_Shift is set means that we know that our left 7080 -- operand is an unsigned integer, as required for this to work. 7081 7082 if Nkind (Ropnd) = N_Op_Expon 7083 and then Is_Power_Of_2_For_Shift (Ropnd) 7084 7085 -- We cannot do this transformation in configurable run time mode if we 7086 -- have 64-bit integers and long shifts are not available. 7087 7088 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target) 7089 then 7090 Rewrite (N, 7091 Make_Op_Shift_Right (Loc, 7092 Left_Opnd => Lopnd, 7093 Right_Opnd => 7094 Convert_To (Standard_Natural, Right_Opnd (Ropnd)))); 7095 Analyze_And_Resolve (N, Typ); 7096 return; 7097 end if; 7098 7099 -- Do required fixup of universal fixed operation 7100 7101 if Typ = Universal_Fixed then 7102 Fixup_Universal_Fixed_Operation (N); 7103 Typ := Etype (N); 7104 end if; 7105 7106 -- Divisions with fixed-point results 7107 7108 if Is_Fixed_Point_Type (Typ) then 7109 7110 -- No special processing if Treat_Fixed_As_Integer is set, since 7111 -- from a semantic point of view such operations are simply integer 7112 -- operations and will be treated that way. 7113 7114 if not Treat_Fixed_As_Integer (N) then 7115 if Is_Integer_Type (Rtyp) then 7116 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); 7117 else 7118 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); 7119 end if; 7120 end if; 7121 7122 -- Deal with divide-by-zero check if back end cannot handle them 7123 -- and the flag is set indicating that we need such a check. Note 7124 -- that we don't need to bother here with the case of mixed-mode 7125 -- (Right operand an integer type), since these will be rewritten 7126 -- with conversions to a divide with a fixed-point right operand. 7127 7128 if Nkind (N) = N_Op_Divide 7129 and then Do_Division_Check (N) 7130 and then not Backend_Divide_Checks_On_Target 7131 and then not Is_Integer_Type (Rtyp) 7132 then 7133 Set_Do_Division_Check (N, False); 7134 Insert_Action (N, 7135 Make_Raise_Constraint_Error (Loc, 7136 Condition => 7137 Make_Op_Eq (Loc, 7138 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd), 7139 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 7140 Reason => CE_Divide_By_Zero)); 7141 end if; 7142 7143 -- Other cases of division of fixed-point operands. Again we exclude the 7144 -- case where Treat_Fixed_As_Integer is set. 7145 7146 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) 7147 and then not Treat_Fixed_As_Integer (N) 7148 then 7149 if Is_Integer_Type (Typ) then 7150 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); 7151 else 7152 pragma Assert (Is_Floating_Point_Type (Typ)); 7153 Expand_Divide_Fixed_By_Fixed_Giving_Float (N); 7154 end if; 7155 7156 -- Mixed-mode operations can appear in a non-static universal context, 7157 -- in which case the integer argument must be converted explicitly. 7158 7159 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then 7160 Rewrite (Ropnd, 7161 Convert_To (Universal_Real, Relocate_Node (Ropnd))); 7162 7163 Analyze_And_Resolve (Ropnd, Universal_Real); 7164 7165 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then 7166 Rewrite (Lopnd, 7167 Convert_To (Universal_Real, Relocate_Node (Lopnd))); 7168 7169 Analyze_And_Resolve (Lopnd, Universal_Real); 7170 7171 -- Non-fixed point cases, do integer zero divide and overflow checks 7172 7173 elsif Is_Integer_Type (Typ) then 7174 Apply_Divide_Checks (N); 7175 end if; 7176 7177 -- Overflow checks for floating-point if -gnateF mode active 7178 7179 Check_Float_Op_Overflow (N); 7180 7181 Expand_Nonbinary_Modular_Op (N); 7182 end Expand_N_Op_Divide; 7183 7184 -------------------- 7185 -- Expand_N_Op_Eq -- 7186 -------------------- 7187 7188 procedure Expand_N_Op_Eq (N : Node_Id) is 7189 Loc : constant Source_Ptr := Sloc (N); 7190 Typ : constant Entity_Id := Etype (N); 7191 Lhs : constant Node_Id := Left_Opnd (N); 7192 Rhs : constant Node_Id := Right_Opnd (N); 7193 Bodies : constant List_Id := New_List; 7194 A_Typ : constant Entity_Id := Etype (Lhs); 7195 7196 Typl : Entity_Id := A_Typ; 7197 Op_Name : Entity_Id; 7198 Prim : Elmt_Id; 7199 7200 procedure Build_Equality_Call (Eq : Entity_Id); 7201 -- If a constructed equality exists for the type or for its parent, 7202 -- build and analyze call, adding conversions if the operation is 7203 -- inherited. 7204 7205 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; 7206 -- Determines whether a type has a subcomponent of an unconstrained 7207 -- Unchecked_Union subtype. Typ is a record type. 7208 7209 ------------------------- 7210 -- Build_Equality_Call -- 7211 ------------------------- 7212 7213 procedure Build_Equality_Call (Eq : Entity_Id) is 7214 Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); 7215 L_Exp : Node_Id := Relocate_Node (Lhs); 7216 R_Exp : Node_Id := Relocate_Node (Rhs); 7217 7218 begin 7219 -- Adjust operands if necessary to comparison type 7220 7221 if Base_Type (Op_Type) /= Base_Type (A_Typ) 7222 and then not Is_Class_Wide_Type (A_Typ) 7223 then 7224 L_Exp := OK_Convert_To (Op_Type, L_Exp); 7225 R_Exp := OK_Convert_To (Op_Type, R_Exp); 7226 end if; 7227 7228 -- If we have an Unchecked_Union, we need to add the inferred 7229 -- discriminant values as actuals in the function call. At this 7230 -- point, the expansion has determined that both operands have 7231 -- inferable discriminants. 7232 7233 if Is_Unchecked_Union (Op_Type) then 7234 declare 7235 Lhs_Type : constant Node_Id := Etype (L_Exp); 7236 Rhs_Type : constant Node_Id := Etype (R_Exp); 7237 7238 Lhs_Discr_Vals : Elist_Id; 7239 -- List of inferred discriminant values for left operand. 7240 7241 Rhs_Discr_Vals : Elist_Id; 7242 -- List of inferred discriminant values for right operand. 7243 7244 Discr : Entity_Id; 7245 7246 begin 7247 Lhs_Discr_Vals := New_Elmt_List; 7248 Rhs_Discr_Vals := New_Elmt_List; 7249 7250 -- Per-object constrained selected components require special 7251 -- attention. If the enclosing scope of the component is an 7252 -- Unchecked_Union, we cannot reference its discriminants 7253 -- directly. This is why we use the extra parameters of the 7254 -- equality function of the enclosing Unchecked_Union. 7255 7256 -- type UU_Type (Discr : Integer := 0) is 7257 -- . . . 7258 -- end record; 7259 -- pragma Unchecked_Union (UU_Type); 7260 7261 -- 1. Unchecked_Union enclosing record: 7262 7263 -- type Enclosing_UU_Type (Discr : Integer := 0) is record 7264 -- . . . 7265 -- Comp : UU_Type (Discr); 7266 -- . . . 7267 -- end Enclosing_UU_Type; 7268 -- pragma Unchecked_Union (Enclosing_UU_Type); 7269 7270 -- Obj1 : Enclosing_UU_Type; 7271 -- Obj2 : Enclosing_UU_Type (1); 7272 7273 -- [. . .] Obj1 = Obj2 [. . .] 7274 7275 -- Generated code: 7276 7277 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then 7278 7279 -- A and B are the formal parameters of the equality function 7280 -- of Enclosing_UU_Type. The function always has two extra 7281 -- formals to capture the inferred discriminant values for 7282 -- each discriminant of the type. 7283 7284 -- 2. Non-Unchecked_Union enclosing record: 7285 7286 -- type 7287 -- Enclosing_Non_UU_Type (Discr : Integer := 0) 7288 -- is record 7289 -- . . . 7290 -- Comp : UU_Type (Discr); 7291 -- . . . 7292 -- end Enclosing_Non_UU_Type; 7293 7294 -- Obj1 : Enclosing_Non_UU_Type; 7295 -- Obj2 : Enclosing_Non_UU_Type (1); 7296 7297 -- ... Obj1 = Obj2 ... 7298 7299 -- Generated code: 7300 7301 -- if not (uu_typeEQ (obj1.comp, obj2.comp, 7302 -- obj1.discr, obj2.discr)) then 7303 7304 -- In this case we can directly reference the discriminants of 7305 -- the enclosing record. 7306 7307 -- Process left operand of equality 7308 7309 if Nkind (Lhs) = N_Selected_Component 7310 and then 7311 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs))) 7312 then 7313 -- If enclosing record is an Unchecked_Union, use formals 7314 -- corresponding to each discriminant. The name of the 7315 -- formal is that of the discriminant, with added suffix, 7316 -- see Exp_Ch3.Build_Record_Equality for details. 7317 7318 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs)))) 7319 then 7320 Discr := 7321 First_Discriminant 7322 (Scope (Entity (Selector_Name (Lhs)))); 7323 while Present (Discr) loop 7324 Append_Elmt 7325 (Make_Identifier (Loc, 7326 Chars => New_External_Name (Chars (Discr), 'A')), 7327 To => Lhs_Discr_Vals); 7328 Next_Discriminant (Discr); 7329 end loop; 7330 7331 -- If enclosing record is of a non-Unchecked_Union type, it 7332 -- is possible to reference its discriminants directly. 7333 7334 else 7335 Discr := First_Discriminant (Lhs_Type); 7336 while Present (Discr) loop 7337 Append_Elmt 7338 (Make_Selected_Component (Loc, 7339 Prefix => Prefix (Lhs), 7340 Selector_Name => 7341 New_Copy 7342 (Get_Discriminant_Value (Discr, 7343 Lhs_Type, 7344 Stored_Constraint (Lhs_Type)))), 7345 To => Lhs_Discr_Vals); 7346 Next_Discriminant (Discr); 7347 end loop; 7348 end if; 7349 7350 -- Otherwise operand is on object with a constrained type. 7351 -- Infer the discriminant values from the constraint. 7352 7353 else 7354 7355 Discr := First_Discriminant (Lhs_Type); 7356 while Present (Discr) loop 7357 Append_Elmt 7358 (New_Copy 7359 (Get_Discriminant_Value (Discr, 7360 Lhs_Type, 7361 Stored_Constraint (Lhs_Type))), 7362 To => Lhs_Discr_Vals); 7363 Next_Discriminant (Discr); 7364 end loop; 7365 end if; 7366 7367 -- Similar processing for right operand of equality 7368 7369 if Nkind (Rhs) = N_Selected_Component 7370 and then 7371 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs))) 7372 then 7373 if Is_Unchecked_Union 7374 (Scope (Entity (Selector_Name (Rhs)))) 7375 then 7376 Discr := 7377 First_Discriminant 7378 (Scope (Entity (Selector_Name (Rhs)))); 7379 while Present (Discr) loop 7380 Append_Elmt 7381 (Make_Identifier (Loc, 7382 Chars => New_External_Name (Chars (Discr), 'B')), 7383 To => Rhs_Discr_Vals); 7384 Next_Discriminant (Discr); 7385 end loop; 7386 7387 else 7388 Discr := First_Discriminant (Rhs_Type); 7389 while Present (Discr) loop 7390 Append_Elmt 7391 (Make_Selected_Component (Loc, 7392 Prefix => Prefix (Rhs), 7393 Selector_Name => 7394 New_Copy (Get_Discriminant_Value 7395 (Discr, 7396 Rhs_Type, 7397 Stored_Constraint (Rhs_Type)))), 7398 To => Rhs_Discr_Vals); 7399 Next_Discriminant (Discr); 7400 end loop; 7401 end if; 7402 7403 else 7404 Discr := First_Discriminant (Rhs_Type); 7405 while Present (Discr) loop 7406 Append_Elmt 7407 (New_Copy (Get_Discriminant_Value 7408 (Discr, 7409 Rhs_Type, 7410 Stored_Constraint (Rhs_Type))), 7411 To => Rhs_Discr_Vals); 7412 Next_Discriminant (Discr); 7413 end loop; 7414 end if; 7415 7416 -- Now merge the list of discriminant values so that values 7417 -- of corresponding discriminants are adjacent. 7418 7419 declare 7420 Params : List_Id; 7421 L_Elmt : Elmt_Id; 7422 R_Elmt : Elmt_Id; 7423 7424 begin 7425 Params := New_List (L_Exp, R_Exp); 7426 L_Elmt := First_Elmt (Lhs_Discr_Vals); 7427 R_Elmt := First_Elmt (Rhs_Discr_Vals); 7428 while Present (L_Elmt) loop 7429 Append_To (Params, Node (L_Elmt)); 7430 Append_To (Params, Node (R_Elmt)); 7431 Next_Elmt (L_Elmt); 7432 Next_Elmt (R_Elmt); 7433 end loop; 7434 7435 Rewrite (N, 7436 Make_Function_Call (Loc, 7437 Name => New_Occurrence_Of (Eq, Loc), 7438 Parameter_Associations => Params)); 7439 end; 7440 end; 7441 7442 -- Normal case, not an unchecked union 7443 7444 else 7445 Rewrite (N, 7446 Make_Function_Call (Loc, 7447 Name => New_Occurrence_Of (Eq, Loc), 7448 Parameter_Associations => New_List (L_Exp, R_Exp))); 7449 end if; 7450 7451 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7452 end Build_Equality_Call; 7453 7454 ------------------------------------ 7455 -- Has_Unconstrained_UU_Component -- 7456 ------------------------------------ 7457 7458 function Has_Unconstrained_UU_Component 7459 (Typ : Node_Id) return Boolean 7460 is 7461 Tdef : constant Node_Id := 7462 Type_Definition (Declaration_Node (Base_Type (Typ))); 7463 Clist : Node_Id; 7464 Vpart : Node_Id; 7465 7466 function Component_Is_Unconstrained_UU 7467 (Comp : Node_Id) return Boolean; 7468 -- Determines whether the subtype of the component is an 7469 -- unconstrained Unchecked_Union. 7470 7471 function Variant_Is_Unconstrained_UU 7472 (Variant : Node_Id) return Boolean; 7473 -- Determines whether a component of the variant has an unconstrained 7474 -- Unchecked_Union subtype. 7475 7476 ----------------------------------- 7477 -- Component_Is_Unconstrained_UU -- 7478 ----------------------------------- 7479 7480 function Component_Is_Unconstrained_UU 7481 (Comp : Node_Id) return Boolean 7482 is 7483 begin 7484 if Nkind (Comp) /= N_Component_Declaration then 7485 return False; 7486 end if; 7487 7488 declare 7489 Sindic : constant Node_Id := 7490 Subtype_Indication (Component_Definition (Comp)); 7491 7492 begin 7493 -- Unconstrained nominal type. In the case of a constraint 7494 -- present, the node kind would have been N_Subtype_Indication. 7495 7496 if Nkind (Sindic) = N_Identifier then 7497 return Is_Unchecked_Union (Base_Type (Etype (Sindic))); 7498 end if; 7499 7500 return False; 7501 end; 7502 end Component_Is_Unconstrained_UU; 7503 7504 --------------------------------- 7505 -- Variant_Is_Unconstrained_UU -- 7506 --------------------------------- 7507 7508 function Variant_Is_Unconstrained_UU 7509 (Variant : Node_Id) return Boolean 7510 is 7511 Clist : constant Node_Id := Component_List (Variant); 7512 7513 begin 7514 if Is_Empty_List (Component_Items (Clist)) then 7515 return False; 7516 end if; 7517 7518 -- We only need to test one component 7519 7520 declare 7521 Comp : Node_Id := First (Component_Items (Clist)); 7522 7523 begin 7524 while Present (Comp) loop 7525 if Component_Is_Unconstrained_UU (Comp) then 7526 return True; 7527 end if; 7528 7529 Next (Comp); 7530 end loop; 7531 end; 7532 7533 -- None of the components withing the variant were of 7534 -- unconstrained Unchecked_Union type. 7535 7536 return False; 7537 end Variant_Is_Unconstrained_UU; 7538 7539 -- Start of processing for Has_Unconstrained_UU_Component 7540 7541 begin 7542 if Null_Present (Tdef) then 7543 return False; 7544 end if; 7545 7546 Clist := Component_List (Tdef); 7547 Vpart := Variant_Part (Clist); 7548 7549 -- Inspect available components 7550 7551 if Present (Component_Items (Clist)) then 7552 declare 7553 Comp : Node_Id := First (Component_Items (Clist)); 7554 7555 begin 7556 while Present (Comp) loop 7557 7558 -- One component is sufficient 7559 7560 if Component_Is_Unconstrained_UU (Comp) then 7561 return True; 7562 end if; 7563 7564 Next (Comp); 7565 end loop; 7566 end; 7567 end if; 7568 7569 -- Inspect available components withing variants 7570 7571 if Present (Vpart) then 7572 declare 7573 Variant : Node_Id := First (Variants (Vpart)); 7574 7575 begin 7576 while Present (Variant) loop 7577 7578 -- One component within a variant is sufficient 7579 7580 if Variant_Is_Unconstrained_UU (Variant) then 7581 return True; 7582 end if; 7583 7584 Next (Variant); 7585 end loop; 7586 end; 7587 end if; 7588 7589 -- Neither the available components, nor the components inside the 7590 -- variant parts were of an unconstrained Unchecked_Union subtype. 7591 7592 return False; 7593 end Has_Unconstrained_UU_Component; 7594 7595 -- Start of processing for Expand_N_Op_Eq 7596 7597 begin 7598 Binary_Op_Validity_Checks (N); 7599 7600 -- Deal with private types 7601 7602 if Ekind (Typl) = E_Private_Type then 7603 Typl := Underlying_Type (Typl); 7604 elsif Ekind (Typl) = E_Private_Subtype then 7605 Typl := Underlying_Type (Base_Type (Typl)); 7606 else 7607 null; 7608 end if; 7609 7610 -- It may happen in error situations that the underlying type is not 7611 -- set. The error will be detected later, here we just defend the 7612 -- expander code. 7613 7614 if No (Typl) then 7615 return; 7616 end if; 7617 7618 -- Now get the implementation base type (note that plain Base_Type here 7619 -- might lead us back to the private type, which is not what we want!) 7620 7621 Typl := Implementation_Base_Type (Typl); 7622 7623 -- Equality between variant records results in a call to a routine 7624 -- that has conditional tests of the discriminant value(s), and hence 7625 -- violates the No_Implicit_Conditionals restriction. 7626 7627 if Has_Variant_Part (Typl) then 7628 declare 7629 Msg : Boolean; 7630 7631 begin 7632 Check_Restriction (Msg, No_Implicit_Conditionals, N); 7633 7634 if Msg then 7635 Error_Msg_N 7636 ("\comparison of variant records tests discriminants", N); 7637 return; 7638 end if; 7639 end; 7640 end if; 7641 7642 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 7643 -- means we no longer have a comparison operation, we are all done. 7644 7645 Expand_Compare_Minimize_Eliminate_Overflow (N); 7646 7647 if Nkind (N) /= N_Op_Eq then 7648 return; 7649 end if; 7650 7651 -- Boolean types (requiring handling of non-standard case) 7652 7653 if Is_Boolean_Type (Typl) then 7654 Adjust_Condition (Left_Opnd (N)); 7655 Adjust_Condition (Right_Opnd (N)); 7656 Set_Etype (N, Standard_Boolean); 7657 Adjust_Result_Type (N, Typ); 7658 7659 -- Array types 7660 7661 elsif Is_Array_Type (Typl) then 7662 7663 -- If we are doing full validity checking, and it is possible for the 7664 -- array elements to be invalid then expand out array comparisons to 7665 -- make sure that we check the array elements. 7666 7667 if Validity_Check_Operands 7668 and then not Is_Known_Valid (Component_Type (Typl)) 7669 then 7670 declare 7671 Save_Force_Validity_Checks : constant Boolean := 7672 Force_Validity_Checks; 7673 begin 7674 Force_Validity_Checks := True; 7675 Rewrite (N, 7676 Expand_Array_Equality 7677 (N, 7678 Relocate_Node (Lhs), 7679 Relocate_Node (Rhs), 7680 Bodies, 7681 Typl)); 7682 Insert_Actions (N, Bodies); 7683 Analyze_And_Resolve (N, Standard_Boolean); 7684 Force_Validity_Checks := Save_Force_Validity_Checks; 7685 end; 7686 7687 -- Packed case where both operands are known aligned 7688 7689 elsif Is_Bit_Packed_Array (Typl) 7690 and then not Is_Possibly_Unaligned_Object (Lhs) 7691 and then not Is_Possibly_Unaligned_Object (Rhs) 7692 then 7693 Expand_Packed_Eq (N); 7694 7695 -- Where the component type is elementary we can use a block bit 7696 -- comparison (if supported on the target) exception in the case 7697 -- of floating-point (negative zero issues require element by 7698 -- element comparison), and atomic/VFA types (where we must be sure 7699 -- to load elements independently) and possibly unaligned arrays. 7700 7701 elsif Is_Elementary_Type (Component_Type (Typl)) 7702 and then not Is_Floating_Point_Type (Component_Type (Typl)) 7703 and then not Is_Atomic_Or_VFA (Component_Type (Typl)) 7704 and then not Is_Possibly_Unaligned_Object (Lhs) 7705 and then not Is_Possibly_Unaligned_Object (Rhs) 7706 and then Support_Composite_Compare_On_Target 7707 then 7708 null; 7709 7710 -- For composite and floating-point cases, expand equality loop to 7711 -- make sure of using proper comparisons for tagged types, and 7712 -- correctly handling the floating-point case. 7713 7714 else 7715 Rewrite (N, 7716 Expand_Array_Equality 7717 (N, 7718 Relocate_Node (Lhs), 7719 Relocate_Node (Rhs), 7720 Bodies, 7721 Typl)); 7722 Insert_Actions (N, Bodies, Suppress => All_Checks); 7723 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7724 end if; 7725 7726 -- Record Types 7727 7728 elsif Is_Record_Type (Typl) then 7729 7730 -- For tagged types, use the primitive "=" 7731 7732 if Is_Tagged_Type (Typl) then 7733 7734 -- No need to do anything else compiling under restriction 7735 -- No_Dispatching_Calls. During the semantic analysis we 7736 -- already notified such violation. 7737 7738 if Restriction_Active (No_Dispatching_Calls) then 7739 return; 7740 end if; 7741 7742 -- If this is derived from an untagged private type completed with 7743 -- a tagged type, it does not have a full view, so we use the 7744 -- primitive operations of the private type. This check should no 7745 -- longer be necessary when these types get their full views??? 7746 7747 if Is_Private_Type (A_Typ) 7748 and then not Is_Tagged_Type (A_Typ) 7749 and then Is_Derived_Type (A_Typ) 7750 and then No (Full_View (A_Typ)) 7751 then 7752 -- Search for equality operation, checking that the operands 7753 -- have the same type. Note that we must find a matching entry, 7754 -- or something is very wrong. 7755 7756 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); 7757 7758 while Present (Prim) loop 7759 exit when Chars (Node (Prim)) = Name_Op_Eq 7760 and then Etype (First_Formal (Node (Prim))) = 7761 Etype (Next_Formal (First_Formal (Node (Prim)))) 7762 and then 7763 Base_Type (Etype (Node (Prim))) = Standard_Boolean; 7764 7765 Next_Elmt (Prim); 7766 end loop; 7767 7768 pragma Assert (Present (Prim)); 7769 Op_Name := Node (Prim); 7770 7771 -- Find the type's predefined equality or an overriding 7772 -- user-defined equality. The reason for not simply calling 7773 -- Find_Prim_Op here is that there may be a user-defined 7774 -- overloaded equality op that precedes the equality that we 7775 -- want, so we have to explicitly search (e.g., there could be 7776 -- an equality with two different parameter types). 7777 7778 else 7779 if Is_Class_Wide_Type (Typl) then 7780 Typl := Find_Specific_Type (Typl); 7781 end if; 7782 7783 Prim := First_Elmt (Primitive_Operations (Typl)); 7784 while Present (Prim) loop 7785 exit when Chars (Node (Prim)) = Name_Op_Eq 7786 and then Etype (First_Formal (Node (Prim))) = 7787 Etype (Next_Formal (First_Formal (Node (Prim)))) 7788 and then 7789 Base_Type (Etype (Node (Prim))) = Standard_Boolean; 7790 7791 Next_Elmt (Prim); 7792 end loop; 7793 7794 pragma Assert (Present (Prim)); 7795 Op_Name := Node (Prim); 7796 end if; 7797 7798 Build_Equality_Call (Op_Name); 7799 7800 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the 7801 -- predefined equality operator for a type which has a subcomponent 7802 -- of an Unchecked_Union type whose nominal subtype is unconstrained. 7803 7804 elsif Has_Unconstrained_UU_Component (Typl) then 7805 Insert_Action (N, 7806 Make_Raise_Program_Error (Loc, 7807 Reason => PE_Unchecked_Union_Restriction)); 7808 7809 -- Prevent Gigi from generating incorrect code by rewriting the 7810 -- equality as a standard False. (is this documented somewhere???) 7811 7812 Rewrite (N, 7813 New_Occurrence_Of (Standard_False, Loc)); 7814 7815 elsif Is_Unchecked_Union (Typl) then 7816 7817 -- If we can infer the discriminants of the operands, we make a 7818 -- call to the TSS equality function. 7819 7820 if Has_Inferable_Discriminants (Lhs) 7821 and then 7822 Has_Inferable_Discriminants (Rhs) 7823 then 7824 Build_Equality_Call 7825 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 7826 7827 else 7828 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 7829 -- the predefined equality operator for an Unchecked_Union type 7830 -- if either of the operands lack inferable discriminants. 7831 7832 Insert_Action (N, 7833 Make_Raise_Program_Error (Loc, 7834 Reason => PE_Unchecked_Union_Restriction)); 7835 7836 -- Emit a warning on source equalities only, otherwise the 7837 -- message may appear out of place due to internal use. The 7838 -- warning is unconditional because it is required by the 7839 -- language. 7840 7841 if Comes_From_Source (N) then 7842 Error_Msg_N 7843 ("Unchecked_Union discriminants cannot be determined??", 7844 N); 7845 Error_Msg_N 7846 ("\Program_Error will be raised for equality operation??", 7847 N); 7848 end if; 7849 7850 -- Prevent Gigi from generating incorrect code by rewriting 7851 -- the equality as a standard False (documented where???). 7852 7853 Rewrite (N, 7854 New_Occurrence_Of (Standard_False, Loc)); 7855 end if; 7856 7857 -- If a type support function is present (for complex cases), use it 7858 7859 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then 7860 Build_Equality_Call 7861 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 7862 7863 -- When comparing two Bounded_Strings, use the primitive equality of 7864 -- the root Super_String type. 7865 7866 elsif Is_Bounded_String (Typl) then 7867 Prim := 7868 First_Elmt (Collect_Primitive_Operations (Root_Type (Typl))); 7869 7870 while Present (Prim) loop 7871 exit when Chars (Node (Prim)) = Name_Op_Eq 7872 and then Etype (First_Formal (Node (Prim))) = 7873 Etype (Next_Formal (First_Formal (Node (Prim)))) 7874 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean; 7875 7876 Next_Elmt (Prim); 7877 end loop; 7878 7879 -- A Super_String type should always have a primitive equality 7880 7881 pragma Assert (Present (Prim)); 7882 Build_Equality_Call (Node (Prim)); 7883 7884 -- Otherwise expand the component by component equality. Note that 7885 -- we never use block-bit comparisons for records, because of the 7886 -- problems with gaps. The back end will often be able to recombine 7887 -- the separate comparisons that we generate here. 7888 7889 else 7890 Remove_Side_Effects (Lhs); 7891 Remove_Side_Effects (Rhs); 7892 Rewrite (N, 7893 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); 7894 7895 Insert_Actions (N, Bodies, Suppress => All_Checks); 7896 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7897 end if; 7898 end if; 7899 7900 -- Test if result is known at compile time 7901 7902 Rewrite_Comparison (N); 7903 7904 -- Special optimization of length comparison 7905 7906 Optimize_Length_Comparison (N); 7907 7908 -- One more special case: if we have a comparison of X'Result = expr 7909 -- in floating-point, then if not already there, change expr to be 7910 -- f'Machine (expr) to eliminate surprise from extra precision. 7911 7912 if Is_Floating_Point_Type (Typl) 7913 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference 7914 and then Attribute_Name (Original_Node (Lhs)) = Name_Result 7915 then 7916 -- Stick in the Typ'Machine call if not already there 7917 7918 if Nkind (Rhs) /= N_Attribute_Reference 7919 or else Attribute_Name (Rhs) /= Name_Machine 7920 then 7921 Rewrite (Rhs, 7922 Make_Attribute_Reference (Loc, 7923 Prefix => New_Occurrence_Of (Typl, Loc), 7924 Attribute_Name => Name_Machine, 7925 Expressions => New_List (Relocate_Node (Rhs)))); 7926 Analyze_And_Resolve (Rhs, Typl); 7927 end if; 7928 end if; 7929 end Expand_N_Op_Eq; 7930 7931 ----------------------- 7932 -- Expand_N_Op_Expon -- 7933 ----------------------- 7934 7935 procedure Expand_N_Op_Expon (N : Node_Id) is 7936 Loc : constant Source_Ptr := Sloc (N); 7937 Ovflo : constant Boolean := Do_Overflow_Check (N); 7938 Typ : constant Entity_Id := Etype (N); 7939 Rtyp : constant Entity_Id := Root_Type (Typ); 7940 7941 Bastyp : Entity_Id; 7942 7943 function Wrap_MA (Exp : Node_Id) return Node_Id; 7944 -- Given an expression Exp, if the root type is Float or Long_Float, 7945 -- then wrap the expression in a call of Bastyp'Machine, to stop any 7946 -- extra precision. This is done to ensure that X**A = X**B when A is 7947 -- a static constant and B is a variable with the same value. For any 7948 -- other type, the node Exp is returned unchanged. 7949 7950 ------------- 7951 -- Wrap_MA -- 7952 ------------- 7953 7954 function Wrap_MA (Exp : Node_Id) return Node_Id is 7955 Loc : constant Source_Ptr := Sloc (Exp); 7956 7957 begin 7958 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then 7959 return 7960 Make_Attribute_Reference (Loc, 7961 Attribute_Name => Name_Machine, 7962 Prefix => New_Occurrence_Of (Bastyp, Loc), 7963 Expressions => New_List (Relocate_Node (Exp))); 7964 else 7965 return Exp; 7966 end if; 7967 end Wrap_MA; 7968 7969 -- Local variables 7970 7971 Base : Node_Id; 7972 Ent : Entity_Id; 7973 Etyp : Entity_Id; 7974 Exp : Node_Id; 7975 Exptyp : Entity_Id; 7976 Expv : Uint; 7977 Rent : RE_Id; 7978 Temp : Node_Id; 7979 Xnode : Node_Id; 7980 7981 -- Start of processing for Expand_N_Op_Expon 7982 7983 begin 7984 Binary_Op_Validity_Checks (N); 7985 7986 -- CodePeer wants to see the unexpanded N_Op_Expon node 7987 7988 if CodePeer_Mode then 7989 return; 7990 end if; 7991 7992 -- Relocation of left and right operands must be done after performing 7993 -- the validity checks since the generation of validation checks may 7994 -- remove side effects. 7995 7996 Base := Relocate_Node (Left_Opnd (N)); 7997 Bastyp := Etype (Base); 7998 Exp := Relocate_Node (Right_Opnd (N)); 7999 Exptyp := Etype (Exp); 8000 8001 -- If either operand is of a private type, then we have the use of an 8002 -- intrinsic operator, and we get rid of the privateness, by using root 8003 -- types of underlying types for the actual operation. Otherwise the 8004 -- private types will cause trouble if we expand multiplications or 8005 -- shifts etc. We also do this transformation if the result type is 8006 -- different from the base type. 8007 8008 if Is_Private_Type (Etype (Base)) 8009 or else Is_Private_Type (Typ) 8010 or else Is_Private_Type (Exptyp) 8011 or else Rtyp /= Root_Type (Bastyp) 8012 then 8013 declare 8014 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); 8015 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); 8016 begin 8017 Rewrite (N, 8018 Unchecked_Convert_To (Typ, 8019 Make_Op_Expon (Loc, 8020 Left_Opnd => Unchecked_Convert_To (Bt, Base), 8021 Right_Opnd => Unchecked_Convert_To (Et, Exp)))); 8022 Analyze_And_Resolve (N, Typ); 8023 return; 8024 end; 8025 end if; 8026 8027 -- Check for MINIMIZED/ELIMINATED overflow mode 8028 8029 if Minimized_Eliminated_Overflow_Check (N) then 8030 Apply_Arithmetic_Overflow_Check (N); 8031 return; 8032 end if; 8033 8034 -- Test for case of known right argument where we can replace the 8035 -- exponentiation by an equivalent expression using multiplication. 8036 8037 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in 8038 -- configurable run-time mode, we may not have the exponentiation 8039 -- routine available, and we don't want the legality of the program 8040 -- to depend on how clever the compiler is in knowing values. 8041 8042 if CRT_Safe_Compile_Time_Known_Value (Exp) then 8043 Expv := Expr_Value (Exp); 8044 8045 -- We only fold small non-negative exponents. You might think we 8046 -- could fold small negative exponents for the real case, but we 8047 -- can't because we are required to raise Constraint_Error for 8048 -- the case of 0.0 ** (negative) even if Machine_Overflows = False. 8049 -- See ACVC test C4A012B, and it is not worth generating the test. 8050 8051 -- For small negative exponents, we return the reciprocal of 8052 -- the folding of the exponentiation for the opposite (positive) 8053 -- exponent, as required by Ada RM 4.5.6(11/3). 8054 8055 if abs Expv <= 4 then 8056 8057 -- X ** 0 = 1 (or 1.0) 8058 8059 if Expv = 0 then 8060 8061 -- Call Remove_Side_Effects to ensure that any side effects 8062 -- in the ignored left operand (in particular function calls 8063 -- to user defined functions) are properly executed. 8064 8065 Remove_Side_Effects (Base); 8066 8067 if Ekind (Typ) in Integer_Kind then 8068 Xnode := Make_Integer_Literal (Loc, Intval => 1); 8069 else 8070 Xnode := Make_Real_Literal (Loc, Ureal_1); 8071 end if; 8072 8073 -- X ** 1 = X 8074 8075 elsif Expv = 1 then 8076 Xnode := Base; 8077 8078 -- X ** 2 = X * X 8079 8080 elsif Expv = 2 then 8081 Xnode := 8082 Wrap_MA ( 8083 Make_Op_Multiply (Loc, 8084 Left_Opnd => Duplicate_Subexpr (Base), 8085 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))); 8086 8087 -- X ** 3 = X * X * X 8088 8089 elsif Expv = 3 then 8090 Xnode := 8091 Wrap_MA ( 8092 Make_Op_Multiply (Loc, 8093 Left_Opnd => 8094 Make_Op_Multiply (Loc, 8095 Left_Opnd => Duplicate_Subexpr (Base), 8096 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)), 8097 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))); 8098 8099 -- X ** 4 -> 8100 8101 -- do 8102 -- En : constant base'type := base * base; 8103 -- in 8104 -- En * En 8105 8106 elsif Expv = 4 then 8107 Temp := Make_Temporary (Loc, 'E', Base); 8108 8109 Xnode := 8110 Make_Expression_With_Actions (Loc, 8111 Actions => New_List ( 8112 Make_Object_Declaration (Loc, 8113 Defining_Identifier => Temp, 8114 Constant_Present => True, 8115 Object_Definition => New_Occurrence_Of (Typ, Loc), 8116 Expression => 8117 Wrap_MA ( 8118 Make_Op_Multiply (Loc, 8119 Left_Opnd => 8120 Duplicate_Subexpr (Base), 8121 Right_Opnd => 8122 Duplicate_Subexpr_No_Checks (Base))))), 8123 8124 Expression => 8125 Wrap_MA ( 8126 Make_Op_Multiply (Loc, 8127 Left_Opnd => New_Occurrence_Of (Temp, Loc), 8128 Right_Opnd => New_Occurrence_Of (Temp, Loc)))); 8129 8130 -- X ** N = 1.0 / X ** (-N) 8131 -- N in -4 .. -1 8132 8133 else 8134 pragma Assert 8135 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4); 8136 8137 Xnode := 8138 Make_Op_Divide (Loc, 8139 Left_Opnd => 8140 Make_Float_Literal (Loc, 8141 Radix => Uint_1, 8142 Significand => Uint_1, 8143 Exponent => Uint_0), 8144 Right_Opnd => 8145 Make_Op_Expon (Loc, 8146 Left_Opnd => Duplicate_Subexpr (Base), 8147 Right_Opnd => 8148 Make_Integer_Literal (Loc, 8149 Intval => -Expv))); 8150 end if; 8151 8152 Rewrite (N, Xnode); 8153 Analyze_And_Resolve (N, Typ); 8154 return; 8155 end if; 8156 end if; 8157 8158 -- Deal with optimizing 2 ** expression to shift where possible 8159 8160 -- Note: we used to check that Exptyp was an unsigned type. But that is 8161 -- an unnecessary check, since if Exp is negative, we have a run-time 8162 -- error that is either caught (so we get the right result) or we have 8163 -- suppressed the check, in which case the code is erroneous anyway. 8164 8165 if Is_Integer_Type (Rtyp) 8166 8167 -- The base value must be "safe compile-time known", and exactly 2 8168 8169 and then Nkind (Base) = N_Integer_Literal 8170 and then CRT_Safe_Compile_Time_Known_Value (Base) 8171 and then Expr_Value (Base) = Uint_2 8172 8173 -- We only handle cases where the right type is a integer 8174 8175 and then Is_Integer_Type (Root_Type (Exptyp)) 8176 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) 8177 8178 -- This transformation is not applicable for a modular type with a 8179 -- nonbinary modulus because we do not handle modular reduction in 8180 -- a correct manner if we attempt this transformation in this case. 8181 8182 and then not Non_Binary_Modulus (Typ) 8183 then 8184 -- Handle the cases where our parent is a division or multiplication 8185 -- specially. In these cases we can convert to using a shift at the 8186 -- parent level if we are not doing overflow checking, since it is 8187 -- too tricky to combine the overflow check at the parent level. 8188 8189 if not Ovflo 8190 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) 8191 then 8192 declare 8193 P : constant Node_Id := Parent (N); 8194 L : constant Node_Id := Left_Opnd (P); 8195 R : constant Node_Id := Right_Opnd (P); 8196 8197 begin 8198 if (Nkind (P) = N_Op_Multiply 8199 and then 8200 ((Is_Integer_Type (Etype (L)) and then R = N) 8201 or else 8202 (Is_Integer_Type (Etype (R)) and then L = N)) 8203 and then not Do_Overflow_Check (P)) 8204 8205 or else 8206 (Nkind (P) = N_Op_Divide 8207 and then Is_Integer_Type (Etype (L)) 8208 and then Is_Unsigned_Type (Etype (L)) 8209 and then R = N 8210 and then not Do_Overflow_Check (P)) 8211 then 8212 Set_Is_Power_Of_2_For_Shift (N); 8213 return; 8214 end if; 8215 end; 8216 8217 -- Here we just have 2 ** N on its own, so we can convert this to a 8218 -- shift node. We are prepared to deal with overflow here, and we 8219 -- also have to handle proper modular reduction for binary modular. 8220 8221 else 8222 declare 8223 OK : Boolean; 8224 Lo : Uint; 8225 Hi : Uint; 8226 8227 MaxS : Uint; 8228 -- Maximum shift count with no overflow 8229 8230 TestS : Boolean; 8231 -- Set True if we must test the shift count 8232 8233 Test_Gt : Node_Id; 8234 -- Node for test against TestS 8235 8236 begin 8237 -- Compute maximum shift based on the underlying size. For a 8238 -- modular type this is one less than the size. 8239 8240 if Is_Modular_Integer_Type (Typ) then 8241 8242 -- For modular integer types, this is the size of the value 8243 -- being shifted minus one. Any larger values will cause 8244 -- modular reduction to a result of zero. Note that we do 8245 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result 8246 -- of 6, since 2**7 should be reduced to zero). 8247 8248 MaxS := RM_Size (Rtyp) - 1; 8249 8250 -- For signed integer types, we use the size of the value 8251 -- being shifted minus 2. Larger values cause overflow. 8252 8253 else 8254 MaxS := Esize (Rtyp) - 2; 8255 end if; 8256 8257 -- Determine range to see if it can be larger than MaxS 8258 8259 Determine_Range 8260 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 8261 TestS := (not OK) or else Hi > MaxS; 8262 8263 -- Signed integer case 8264 8265 if Is_Signed_Integer_Type (Typ) then 8266 8267 -- Generate overflow check if overflow is active. Note that 8268 -- we can simply ignore the possibility of overflow if the 8269 -- flag is not set (means that overflow cannot happen or 8270 -- that overflow checks are suppressed). 8271 8272 if Ovflo and TestS then 8273 Insert_Action (N, 8274 Make_Raise_Constraint_Error (Loc, 8275 Condition => 8276 Make_Op_Gt (Loc, 8277 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)), 8278 Right_Opnd => Make_Integer_Literal (Loc, MaxS)), 8279 Reason => CE_Overflow_Check_Failed)); 8280 end if; 8281 8282 -- Now rewrite node as Shift_Left (1, right-operand) 8283 8284 Rewrite (N, 8285 Make_Op_Shift_Left (Loc, 8286 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8287 Right_Opnd => Right_Opnd (N))); 8288 8289 -- Modular integer case 8290 8291 else pragma Assert (Is_Modular_Integer_Type (Typ)); 8292 8293 -- If shift count can be greater than MaxS, we need to wrap 8294 -- the shift in a test that will reduce the result value to 8295 -- zero if this shift count is exceeded. 8296 8297 if TestS then 8298 8299 -- Note: build node for the comparison first, before we 8300 -- reuse the Right_Opnd, so that we have proper parents 8301 -- in place for the Duplicate_Subexpr call. 8302 8303 Test_Gt := 8304 Make_Op_Gt (Loc, 8305 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)), 8306 Right_Opnd => Make_Integer_Literal (Loc, MaxS)); 8307 8308 Rewrite (N, 8309 Make_If_Expression (Loc, 8310 Expressions => New_List ( 8311 Test_Gt, 8312 Make_Integer_Literal (Loc, Uint_0), 8313 Make_Op_Shift_Left (Loc, 8314 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8315 Right_Opnd => Right_Opnd (N))))); 8316 8317 -- If we know shift count cannot be greater than MaxS, then 8318 -- it is safe to just rewrite as a shift with no test. 8319 8320 else 8321 Rewrite (N, 8322 Make_Op_Shift_Left (Loc, 8323 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8324 Right_Opnd => Right_Opnd (N))); 8325 end if; 8326 end if; 8327 8328 Analyze_And_Resolve (N, Typ); 8329 return; 8330 end; 8331 end if; 8332 end if; 8333 8334 -- Fall through if exponentiation must be done using a runtime routine 8335 8336 -- First deal with modular case 8337 8338 if Is_Modular_Integer_Type (Rtyp) then 8339 8340 -- Nonbinary modular case, we call the special exponentiation 8341 -- routine for the nonbinary case, converting the argument to 8342 -- Long_Long_Integer and passing the modulus value. Then the 8343 -- result is converted back to the base type. 8344 8345 if Non_Binary_Modulus (Rtyp) then 8346 Rewrite (N, 8347 Convert_To (Typ, 8348 Make_Function_Call (Loc, 8349 Name => 8350 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc), 8351 Parameter_Associations => New_List ( 8352 Convert_To (RTE (RE_Unsigned), Base), 8353 Make_Integer_Literal (Loc, Modulus (Rtyp)), 8354 Exp)))); 8355 8356 -- Binary modular case, in this case, we call one of two routines, 8357 -- either the unsigned integer case, or the unsigned long long 8358 -- integer case, with a final "and" operation to do the required mod. 8359 8360 else 8361 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 8362 Ent := RTE (RE_Exp_Unsigned); 8363 else 8364 Ent := RTE (RE_Exp_Long_Long_Unsigned); 8365 end if; 8366 8367 Rewrite (N, 8368 Convert_To (Typ, 8369 Make_Op_And (Loc, 8370 Left_Opnd => 8371 Make_Function_Call (Loc, 8372 Name => New_Occurrence_Of (Ent, Loc), 8373 Parameter_Associations => New_List ( 8374 Convert_To (Etype (First_Formal (Ent)), Base), 8375 Exp)), 8376 Right_Opnd => 8377 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); 8378 8379 end if; 8380 8381 -- Common exit point for modular type case 8382 8383 Analyze_And_Resolve (N, Typ); 8384 return; 8385 8386 -- Signed integer cases, done using either Integer or Long_Long_Integer. 8387 -- It is not worth having routines for Short_[Short_]Integer, since for 8388 -- most machines it would not help, and it would generate more code that 8389 -- might need certification when a certified run time is required. 8390 8391 -- In the integer cases, we have two routines, one for when overflow 8392 -- checks are required, and one when they are not required, since there 8393 -- is a real gain in omitting checks on many machines. 8394 8395 elsif Rtyp = Base_Type (Standard_Long_Long_Integer) 8396 or else (Rtyp = Base_Type (Standard_Long_Integer) 8397 and then 8398 Esize (Standard_Long_Integer) > Esize (Standard_Integer)) 8399 or else Rtyp = Universal_Integer 8400 then 8401 Etyp := Standard_Long_Long_Integer; 8402 8403 if Ovflo then 8404 Rent := RE_Exp_Long_Long_Integer; 8405 else 8406 Rent := RE_Exn_Long_Long_Integer; 8407 end if; 8408 8409 elsif Is_Signed_Integer_Type (Rtyp) then 8410 Etyp := Standard_Integer; 8411 8412 if Ovflo then 8413 Rent := RE_Exp_Integer; 8414 else 8415 Rent := RE_Exn_Integer; 8416 end if; 8417 8418 -- Floating-point cases. We do not need separate routines for the 8419 -- overflow case here, since in the case of floating-point, we generate 8420 -- infinities anyway as a rule (either that or we automatically trap 8421 -- overflow), and if there is an infinity generated and a range check 8422 -- is required, the check will fail anyway. 8423 8424 -- Historical note: we used to convert everything to Long_Long_Float 8425 -- and call a single common routine, but this had the undesirable effect 8426 -- of giving different results for small static exponent values and the 8427 -- same dynamic values. 8428 8429 else 8430 pragma Assert (Is_Floating_Point_Type (Rtyp)); 8431 8432 if Rtyp = Standard_Float then 8433 Etyp := Standard_Float; 8434 Rent := RE_Exn_Float; 8435 8436 elsif Rtyp = Standard_Long_Float then 8437 Etyp := Standard_Long_Float; 8438 Rent := RE_Exn_Long_Float; 8439 8440 else 8441 Etyp := Standard_Long_Long_Float; 8442 Rent := RE_Exn_Long_Long_Float; 8443 end if; 8444 end if; 8445 8446 -- Common processing for integer cases and floating-point cases. 8447 -- If we are in the right type, we can call runtime routine directly 8448 8449 if Typ = Etyp 8450 and then Rtyp /= Universal_Integer 8451 and then Rtyp /= Universal_Real 8452 then 8453 Rewrite (N, 8454 Wrap_MA ( 8455 Make_Function_Call (Loc, 8456 Name => New_Occurrence_Of (RTE (Rent), Loc), 8457 Parameter_Associations => New_List (Base, Exp)))); 8458 8459 -- Otherwise we have to introduce conversions (conversions are also 8460 -- required in the universal cases, since the runtime routine is 8461 -- typed using one of the standard types). 8462 8463 else 8464 Rewrite (N, 8465 Convert_To (Typ, 8466 Make_Function_Call (Loc, 8467 Name => New_Occurrence_Of (RTE (Rent), Loc), 8468 Parameter_Associations => New_List ( 8469 Convert_To (Etyp, Base), 8470 Exp)))); 8471 end if; 8472 8473 Analyze_And_Resolve (N, Typ); 8474 return; 8475 8476 exception 8477 when RE_Not_Available => 8478 return; 8479 end Expand_N_Op_Expon; 8480 8481 -------------------- 8482 -- Expand_N_Op_Ge -- 8483 -------------------- 8484 8485 procedure Expand_N_Op_Ge (N : Node_Id) is 8486 Typ : constant Entity_Id := Etype (N); 8487 Op1 : constant Node_Id := Left_Opnd (N); 8488 Op2 : constant Node_Id := Right_Opnd (N); 8489 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 8490 8491 begin 8492 Binary_Op_Validity_Checks (N); 8493 8494 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8495 -- means we no longer have a comparison operation, we are all done. 8496 8497 Expand_Compare_Minimize_Eliminate_Overflow (N); 8498 8499 if Nkind (N) /= N_Op_Ge then 8500 return; 8501 end if; 8502 8503 -- Array type case 8504 8505 if Is_Array_Type (Typ1) then 8506 Expand_Array_Comparison (N); 8507 return; 8508 end if; 8509 8510 -- Deal with boolean operands 8511 8512 if Is_Boolean_Type (Typ1) then 8513 Adjust_Condition (Op1); 8514 Adjust_Condition (Op2); 8515 Set_Etype (N, Standard_Boolean); 8516 Adjust_Result_Type (N, Typ); 8517 end if; 8518 8519 Rewrite_Comparison (N); 8520 8521 Optimize_Length_Comparison (N); 8522 end Expand_N_Op_Ge; 8523 8524 -------------------- 8525 -- Expand_N_Op_Gt -- 8526 -------------------- 8527 8528 procedure Expand_N_Op_Gt (N : Node_Id) is 8529 Typ : constant Entity_Id := Etype (N); 8530 Op1 : constant Node_Id := Left_Opnd (N); 8531 Op2 : constant Node_Id := Right_Opnd (N); 8532 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 8533 8534 begin 8535 Binary_Op_Validity_Checks (N); 8536 8537 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8538 -- means we no longer have a comparison operation, we are all done. 8539 8540 Expand_Compare_Minimize_Eliminate_Overflow (N); 8541 8542 if Nkind (N) /= N_Op_Gt then 8543 return; 8544 end if; 8545 8546 -- Deal with array type operands 8547 8548 if Is_Array_Type (Typ1) then 8549 Expand_Array_Comparison (N); 8550 return; 8551 end if; 8552 8553 -- Deal with boolean type operands 8554 8555 if Is_Boolean_Type (Typ1) then 8556 Adjust_Condition (Op1); 8557 Adjust_Condition (Op2); 8558 Set_Etype (N, Standard_Boolean); 8559 Adjust_Result_Type (N, Typ); 8560 end if; 8561 8562 Rewrite_Comparison (N); 8563 8564 Optimize_Length_Comparison (N); 8565 end Expand_N_Op_Gt; 8566 8567 -------------------- 8568 -- Expand_N_Op_Le -- 8569 -------------------- 8570 8571 procedure Expand_N_Op_Le (N : Node_Id) is 8572 Typ : constant Entity_Id := Etype (N); 8573 Op1 : constant Node_Id := Left_Opnd (N); 8574 Op2 : constant Node_Id := Right_Opnd (N); 8575 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 8576 8577 begin 8578 Binary_Op_Validity_Checks (N); 8579 8580 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8581 -- means we no longer have a comparison operation, we are all done. 8582 8583 Expand_Compare_Minimize_Eliminate_Overflow (N); 8584 8585 if Nkind (N) /= N_Op_Le then 8586 return; 8587 end if; 8588 8589 -- Deal with array type operands 8590 8591 if Is_Array_Type (Typ1) then 8592 Expand_Array_Comparison (N); 8593 return; 8594 end if; 8595 8596 -- Deal with Boolean type operands 8597 8598 if Is_Boolean_Type (Typ1) then 8599 Adjust_Condition (Op1); 8600 Adjust_Condition (Op2); 8601 Set_Etype (N, Standard_Boolean); 8602 Adjust_Result_Type (N, Typ); 8603 end if; 8604 8605 Rewrite_Comparison (N); 8606 8607 Optimize_Length_Comparison (N); 8608 end Expand_N_Op_Le; 8609 8610 -------------------- 8611 -- Expand_N_Op_Lt -- 8612 -------------------- 8613 8614 procedure Expand_N_Op_Lt (N : Node_Id) is 8615 Typ : constant Entity_Id := Etype (N); 8616 Op1 : constant Node_Id := Left_Opnd (N); 8617 Op2 : constant Node_Id := Right_Opnd (N); 8618 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 8619 8620 begin 8621 Binary_Op_Validity_Checks (N); 8622 8623 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8624 -- means we no longer have a comparison operation, we are all done. 8625 8626 Expand_Compare_Minimize_Eliminate_Overflow (N); 8627 8628 if Nkind (N) /= N_Op_Lt then 8629 return; 8630 end if; 8631 8632 -- Deal with array type operands 8633 8634 if Is_Array_Type (Typ1) then 8635 Expand_Array_Comparison (N); 8636 return; 8637 end if; 8638 8639 -- Deal with Boolean type operands 8640 8641 if Is_Boolean_Type (Typ1) then 8642 Adjust_Condition (Op1); 8643 Adjust_Condition (Op2); 8644 Set_Etype (N, Standard_Boolean); 8645 Adjust_Result_Type (N, Typ); 8646 end if; 8647 8648 Rewrite_Comparison (N); 8649 8650 Optimize_Length_Comparison (N); 8651 end Expand_N_Op_Lt; 8652 8653 ----------------------- 8654 -- Expand_N_Op_Minus -- 8655 ----------------------- 8656 8657 procedure Expand_N_Op_Minus (N : Node_Id) is 8658 Loc : constant Source_Ptr := Sloc (N); 8659 Typ : constant Entity_Id := Etype (N); 8660 8661 begin 8662 Unary_Op_Validity_Checks (N); 8663 8664 -- Check for MINIMIZED/ELIMINATED overflow mode 8665 8666 if Minimized_Eliminated_Overflow_Check (N) then 8667 Apply_Arithmetic_Overflow_Check (N); 8668 return; 8669 end if; 8670 8671 if not Backend_Overflow_Checks_On_Target 8672 and then Is_Signed_Integer_Type (Etype (N)) 8673 and then Do_Overflow_Check (N) 8674 then 8675 -- Software overflow checking expands -expr into (0 - expr) 8676 8677 Rewrite (N, 8678 Make_Op_Subtract (Loc, 8679 Left_Opnd => Make_Integer_Literal (Loc, 0), 8680 Right_Opnd => Right_Opnd (N))); 8681 8682 Analyze_And_Resolve (N, Typ); 8683 end if; 8684 8685 Expand_Nonbinary_Modular_Op (N); 8686 end Expand_N_Op_Minus; 8687 8688 --------------------- 8689 -- Expand_N_Op_Mod -- 8690 --------------------- 8691 8692 procedure Expand_N_Op_Mod (N : Node_Id) is 8693 Loc : constant Source_Ptr := Sloc (N); 8694 Typ : constant Entity_Id := Etype (N); 8695 DDC : constant Boolean := Do_Division_Check (N); 8696 8697 Left : Node_Id; 8698 Right : Node_Id; 8699 8700 LLB : Uint; 8701 Llo : Uint; 8702 Lhi : Uint; 8703 LOK : Boolean; 8704 Rlo : Uint; 8705 Rhi : Uint; 8706 ROK : Boolean; 8707 8708 pragma Warnings (Off, Lhi); 8709 8710 begin 8711 Binary_Op_Validity_Checks (N); 8712 8713 -- Check for MINIMIZED/ELIMINATED overflow mode 8714 8715 if Minimized_Eliminated_Overflow_Check (N) then 8716 Apply_Arithmetic_Overflow_Check (N); 8717 return; 8718 end if; 8719 8720 if Is_Integer_Type (Etype (N)) then 8721 Apply_Divide_Checks (N); 8722 8723 -- All done if we don't have a MOD any more, which can happen as a 8724 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 8725 8726 if Nkind (N) /= N_Op_Mod then 8727 return; 8728 end if; 8729 end if; 8730 8731 -- Proceed with expansion of mod operator 8732 8733 Left := Left_Opnd (N); 8734 Right := Right_Opnd (N); 8735 8736 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); 8737 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); 8738 8739 -- Convert mod to rem if operands are both known to be non-negative, or 8740 -- both known to be non-positive (these are the cases in which rem and 8741 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite 8742 -- likely that this will improve the quality of code, (the operation now 8743 -- corresponds to the hardware remainder), and it does not seem likely 8744 -- that it could be harmful. It also avoids some cases of the elaborate 8745 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %). 8746 8747 if (LOK and ROK) 8748 and then ((Llo >= 0 and then Rlo >= 0) 8749 or else 8750 (Lhi <= 0 and then Rhi <= 0)) 8751 then 8752 Rewrite (N, 8753 Make_Op_Rem (Sloc (N), 8754 Left_Opnd => Left_Opnd (N), 8755 Right_Opnd => Right_Opnd (N))); 8756 8757 -- Instead of reanalyzing the node we do the analysis manually. This 8758 -- avoids anomalies when the replacement is done in an instance and 8759 -- is epsilon more efficient. 8760 8761 Set_Entity (N, Standard_Entity (S_Op_Rem)); 8762 Set_Etype (N, Typ); 8763 Set_Do_Division_Check (N, DDC); 8764 Expand_N_Op_Rem (N); 8765 Set_Analyzed (N); 8766 return; 8767 8768 -- Otherwise, normal mod processing 8769 8770 else 8771 -- Apply optimization x mod 1 = 0. We don't really need that with 8772 -- gcc, but it is useful with other back ends and is certainly 8773 -- harmless. 8774 8775 if Is_Integer_Type (Etype (N)) 8776 and then Compile_Time_Known_Value (Right) 8777 and then Expr_Value (Right) = Uint_1 8778 then 8779 -- Call Remove_Side_Effects to ensure that any side effects in 8780 -- the ignored left operand (in particular function calls to 8781 -- user defined functions) are properly executed. 8782 8783 Remove_Side_Effects (Left); 8784 8785 Rewrite (N, Make_Integer_Literal (Loc, 0)); 8786 Analyze_And_Resolve (N, Typ); 8787 return; 8788 end if; 8789 8790 -- If we still have a mod operator and we are in Modify_Tree_For_C 8791 -- mode, and we have a signed integer type, then here is where we do 8792 -- the rewrite in terms of Rem. Note this rewrite bypasses the need 8793 -- for the special handling of the annoying case of largest negative 8794 -- number mod minus one. 8795 8796 if Nkind (N) = N_Op_Mod 8797 and then Is_Signed_Integer_Type (Typ) 8798 and then Modify_Tree_For_C 8799 then 8800 -- In the general case, we expand A mod B as 8801 8802 -- Tnn : constant typ := A rem B; 8803 -- .. 8804 -- (if (A >= 0) = (B >= 0) then Tnn 8805 -- elsif Tnn = 0 then 0 8806 -- else Tnn + B) 8807 8808 -- The comparison can be written simply as A >= 0 if we know that 8809 -- B >= 0 which is a very common case. 8810 8811 -- An important optimization is when B is known at compile time 8812 -- to be 2**K for some constant. In this case we can simply AND 8813 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits) 8814 -- and that works for both the positive and negative cases. 8815 8816 declare 8817 P2 : constant Nat := Power_Of_Two (Right); 8818 8819 begin 8820 if P2 /= 0 then 8821 Rewrite (N, 8822 Unchecked_Convert_To (Typ, 8823 Make_Op_And (Loc, 8824 Left_Opnd => 8825 Unchecked_Convert_To 8826 (Corresponding_Unsigned_Type (Typ), Left), 8827 Right_Opnd => 8828 Make_Integer_Literal (Loc, 2 ** P2 - 1)))); 8829 Analyze_And_Resolve (N, Typ); 8830 return; 8831 end if; 8832 end; 8833 8834 -- Here for the full rewrite 8835 8836 declare 8837 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N); 8838 Cmp : Node_Id; 8839 8840 begin 8841 Cmp := 8842 Make_Op_Ge (Loc, 8843 Left_Opnd => Duplicate_Subexpr_No_Checks (Left), 8844 Right_Opnd => Make_Integer_Literal (Loc, 0)); 8845 8846 if not LOK or else Rlo < 0 then 8847 Cmp := 8848 Make_Op_Eq (Loc, 8849 Left_Opnd => Cmp, 8850 Right_Opnd => 8851 Make_Op_Ge (Loc, 8852 Left_Opnd => Duplicate_Subexpr_No_Checks (Right), 8853 Right_Opnd => Make_Integer_Literal (Loc, 0))); 8854 end if; 8855 8856 Insert_Action (N, 8857 Make_Object_Declaration (Loc, 8858 Defining_Identifier => Tnn, 8859 Constant_Present => True, 8860 Object_Definition => New_Occurrence_Of (Typ, Loc), 8861 Expression => 8862 Make_Op_Rem (Loc, 8863 Left_Opnd => Left, 8864 Right_Opnd => Right))); 8865 8866 Rewrite (N, 8867 Make_If_Expression (Loc, 8868 Expressions => New_List ( 8869 Cmp, 8870 New_Occurrence_Of (Tnn, Loc), 8871 Make_If_Expression (Loc, 8872 Is_Elsif => True, 8873 Expressions => New_List ( 8874 Make_Op_Eq (Loc, 8875 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 8876 Right_Opnd => Make_Integer_Literal (Loc, 0)), 8877 Make_Integer_Literal (Loc, 0), 8878 Make_Op_Add (Loc, 8879 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 8880 Right_Opnd => 8881 Duplicate_Subexpr_No_Checks (Right))))))); 8882 8883 Analyze_And_Resolve (N, Typ); 8884 return; 8885 end; 8886 end if; 8887 8888 -- Deal with annoying case of largest negative number mod minus one. 8889 -- Gigi may not handle this case correctly, because on some targets, 8890 -- the mod value is computed using a divide instruction which gives 8891 -- an overflow trap for this case. 8892 8893 -- It would be a bit more efficient to figure out which targets 8894 -- this is really needed for, but in practice it is reasonable 8895 -- to do the following special check in all cases, since it means 8896 -- we get a clearer message, and also the overhead is minimal given 8897 -- that division is expensive in any case. 8898 8899 -- In fact the check is quite easy, if the right operand is -1, then 8900 -- the mod value is always 0, and we can just ignore the left operand 8901 -- completely in this case. 8902 8903 -- This only applies if we still have a mod operator. Skip if we 8904 -- have already rewritten this (e.g. in the case of eliminated 8905 -- overflow checks which have driven us into bignum mode). 8906 8907 if Nkind (N) = N_Op_Mod then 8908 8909 -- The operand type may be private (e.g. in the expansion of an 8910 -- intrinsic operation) so we must use the underlying type to get 8911 -- the bounds, and convert the literals explicitly. 8912 8913 LLB := 8914 Expr_Value 8915 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); 8916 8917 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 8918 and then ((not LOK) or else (Llo = LLB)) 8919 then 8920 Rewrite (N, 8921 Make_If_Expression (Loc, 8922 Expressions => New_List ( 8923 Make_Op_Eq (Loc, 8924 Left_Opnd => Duplicate_Subexpr (Right), 8925 Right_Opnd => 8926 Unchecked_Convert_To (Typ, 8927 Make_Integer_Literal (Loc, -1))), 8928 Unchecked_Convert_To (Typ, 8929 Make_Integer_Literal (Loc, Uint_0)), 8930 Relocate_Node (N)))); 8931 8932 Set_Analyzed (Next (Next (First (Expressions (N))))); 8933 Analyze_And_Resolve (N, Typ); 8934 end if; 8935 end if; 8936 end if; 8937 end Expand_N_Op_Mod; 8938 8939 -------------------------- 8940 -- Expand_N_Op_Multiply -- 8941 -------------------------- 8942 8943 procedure Expand_N_Op_Multiply (N : Node_Id) is 8944 Loc : constant Source_Ptr := Sloc (N); 8945 Lop : constant Node_Id := Left_Opnd (N); 8946 Rop : constant Node_Id := Right_Opnd (N); 8947 8948 Lp2 : constant Boolean := 8949 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop); 8950 Rp2 : constant Boolean := 8951 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop); 8952 8953 Ltyp : constant Entity_Id := Etype (Lop); 8954 Rtyp : constant Entity_Id := Etype (Rop); 8955 Typ : Entity_Id := Etype (N); 8956 8957 begin 8958 Binary_Op_Validity_Checks (N); 8959 8960 -- Check for MINIMIZED/ELIMINATED overflow mode 8961 8962 if Minimized_Eliminated_Overflow_Check (N) then 8963 Apply_Arithmetic_Overflow_Check (N); 8964 return; 8965 end if; 8966 8967 -- Special optimizations for integer types 8968 8969 if Is_Integer_Type (Typ) then 8970 8971 -- N * 0 = 0 for integer types 8972 8973 if Compile_Time_Known_Value (Rop) 8974 and then Expr_Value (Rop) = Uint_0 8975 then 8976 -- Call Remove_Side_Effects to ensure that any side effects in 8977 -- the ignored left operand (in particular function calls to 8978 -- user defined functions) are properly executed. 8979 8980 Remove_Side_Effects (Lop); 8981 8982 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 8983 Analyze_And_Resolve (N, Typ); 8984 return; 8985 end if; 8986 8987 -- Similar handling for 0 * N = 0 8988 8989 if Compile_Time_Known_Value (Lop) 8990 and then Expr_Value (Lop) = Uint_0 8991 then 8992 Remove_Side_Effects (Rop); 8993 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 8994 Analyze_And_Resolve (N, Typ); 8995 return; 8996 end if; 8997 8998 -- N * 1 = 1 * N = N for integer types 8999 9000 -- This optimisation is not done if we are going to 9001 -- rewrite the product 1 * 2 ** N to a shift. 9002 9003 if Compile_Time_Known_Value (Rop) 9004 and then Expr_Value (Rop) = Uint_1 9005 and then not Lp2 9006 then 9007 Rewrite (N, Lop); 9008 return; 9009 9010 elsif Compile_Time_Known_Value (Lop) 9011 and then Expr_Value (Lop) = Uint_1 9012 and then not Rp2 9013 then 9014 Rewrite (N, Rop); 9015 return; 9016 end if; 9017 end if; 9018 9019 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that 9020 -- Is_Power_Of_2_For_Shift is set means that we know that our left 9021 -- operand is an integer, as required for this to work. 9022 9023 if Rp2 then 9024 if Lp2 then 9025 9026 -- Convert 2 ** A * 2 ** B into 2 ** (A + B) 9027 9028 Rewrite (N, 9029 Make_Op_Expon (Loc, 9030 Left_Opnd => Make_Integer_Literal (Loc, 2), 9031 Right_Opnd => 9032 Make_Op_Add (Loc, 9033 Left_Opnd => Right_Opnd (Lop), 9034 Right_Opnd => Right_Opnd (Rop)))); 9035 Analyze_And_Resolve (N, Typ); 9036 return; 9037 9038 else 9039 -- If the result is modular, perform the reduction of the result 9040 -- appropriately. 9041 9042 if Is_Modular_Integer_Type (Typ) 9043 and then not Non_Binary_Modulus (Typ) 9044 then 9045 Rewrite (N, 9046 Make_Op_And (Loc, 9047 Left_Opnd => 9048 Make_Op_Shift_Left (Loc, 9049 Left_Opnd => Lop, 9050 Right_Opnd => 9051 Convert_To (Standard_Natural, Right_Opnd (Rop))), 9052 Right_Opnd => 9053 Make_Integer_Literal (Loc, Modulus (Typ) - 1))); 9054 9055 else 9056 Rewrite (N, 9057 Make_Op_Shift_Left (Loc, 9058 Left_Opnd => Lop, 9059 Right_Opnd => 9060 Convert_To (Standard_Natural, Right_Opnd (Rop)))); 9061 end if; 9062 9063 Analyze_And_Resolve (N, Typ); 9064 return; 9065 end if; 9066 9067 -- Same processing for the operands the other way round 9068 9069 elsif Lp2 then 9070 if Is_Modular_Integer_Type (Typ) 9071 and then not Non_Binary_Modulus (Typ) 9072 then 9073 Rewrite (N, 9074 Make_Op_And (Loc, 9075 Left_Opnd => 9076 Make_Op_Shift_Left (Loc, 9077 Left_Opnd => Rop, 9078 Right_Opnd => 9079 Convert_To (Standard_Natural, Right_Opnd (Lop))), 9080 Right_Opnd => 9081 Make_Integer_Literal (Loc, Modulus (Typ) - 1))); 9082 9083 else 9084 Rewrite (N, 9085 Make_Op_Shift_Left (Loc, 9086 Left_Opnd => Rop, 9087 Right_Opnd => 9088 Convert_To (Standard_Natural, Right_Opnd (Lop)))); 9089 end if; 9090 9091 Analyze_And_Resolve (N, Typ); 9092 return; 9093 end if; 9094 9095 -- Do required fixup of universal fixed operation 9096 9097 if Typ = Universal_Fixed then 9098 Fixup_Universal_Fixed_Operation (N); 9099 Typ := Etype (N); 9100 end if; 9101 9102 -- Multiplications with fixed-point results 9103 9104 if Is_Fixed_Point_Type (Typ) then 9105 9106 -- No special processing if Treat_Fixed_As_Integer is set, since from 9107 -- a semantic point of view such operations are simply integer 9108 -- operations and will be treated that way. 9109 9110 if not Treat_Fixed_As_Integer (N) then 9111 9112 -- Case of fixed * integer => fixed 9113 9114 if Is_Integer_Type (Rtyp) then 9115 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); 9116 9117 -- Case of integer * fixed => fixed 9118 9119 elsif Is_Integer_Type (Ltyp) then 9120 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); 9121 9122 -- Case of fixed * fixed => fixed 9123 9124 else 9125 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); 9126 end if; 9127 end if; 9128 9129 -- Other cases of multiplication of fixed-point operands. Again we 9130 -- exclude the cases where Treat_Fixed_As_Integer flag is set. 9131 9132 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) 9133 and then not Treat_Fixed_As_Integer (N) 9134 then 9135 if Is_Integer_Type (Typ) then 9136 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); 9137 else 9138 pragma Assert (Is_Floating_Point_Type (Typ)); 9139 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); 9140 end if; 9141 9142 -- Mixed-mode operations can appear in a non-static universal context, 9143 -- in which case the integer argument must be converted explicitly. 9144 9145 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then 9146 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); 9147 Analyze_And_Resolve (Rop, Universal_Real); 9148 9149 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then 9150 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); 9151 Analyze_And_Resolve (Lop, Universal_Real); 9152 9153 -- Non-fixed point cases, check software overflow checking required 9154 9155 elsif Is_Signed_Integer_Type (Etype (N)) then 9156 Apply_Arithmetic_Overflow_Check (N); 9157 end if; 9158 9159 -- Overflow checks for floating-point if -gnateF mode active 9160 9161 Check_Float_Op_Overflow (N); 9162 9163 Expand_Nonbinary_Modular_Op (N); 9164 end Expand_N_Op_Multiply; 9165 9166 -------------------- 9167 -- Expand_N_Op_Ne -- 9168 -------------------- 9169 9170 procedure Expand_N_Op_Ne (N : Node_Id) is 9171 Typ : constant Entity_Id := Etype (Left_Opnd (N)); 9172 9173 begin 9174 -- Case of elementary type with standard operator 9175 9176 if Is_Elementary_Type (Typ) 9177 and then Sloc (Entity (N)) = Standard_Location 9178 then 9179 Binary_Op_Validity_Checks (N); 9180 9181 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if 9182 -- means we no longer have a /= operation, we are all done. 9183 9184 Expand_Compare_Minimize_Eliminate_Overflow (N); 9185 9186 if Nkind (N) /= N_Op_Ne then 9187 return; 9188 end if; 9189 9190 -- Boolean types (requiring handling of non-standard case) 9191 9192 if Is_Boolean_Type (Typ) then 9193 Adjust_Condition (Left_Opnd (N)); 9194 Adjust_Condition (Right_Opnd (N)); 9195 Set_Etype (N, Standard_Boolean); 9196 Adjust_Result_Type (N, Typ); 9197 end if; 9198 9199 Rewrite_Comparison (N); 9200 9201 -- For all cases other than elementary types, we rewrite node as the 9202 -- negation of an equality operation, and reanalyze. The equality to be 9203 -- used is defined in the same scope and has the same signature. This 9204 -- signature must be set explicitly since in an instance it may not have 9205 -- the same visibility as in the generic unit. This avoids duplicating 9206 -- or factoring the complex code for record/array equality tests etc. 9207 9208 -- This case is also used for the minimal expansion performed in 9209 -- GNATprove mode. 9210 9211 else 9212 declare 9213 Loc : constant Source_Ptr := Sloc (N); 9214 Neg : Node_Id; 9215 Ne : constant Entity_Id := Entity (N); 9216 9217 begin 9218 Binary_Op_Validity_Checks (N); 9219 9220 Neg := 9221 Make_Op_Not (Loc, 9222 Right_Opnd => 9223 Make_Op_Eq (Loc, 9224 Left_Opnd => Left_Opnd (N), 9225 Right_Opnd => Right_Opnd (N))); 9226 9227 -- The level of parentheses is useless in GNATprove mode, and 9228 -- bumping its level here leads to wrong columns being used in 9229 -- check messages, hence skip it in this mode. 9230 9231 if not GNATprove_Mode then 9232 Set_Paren_Count (Right_Opnd (Neg), 1); 9233 end if; 9234 9235 if Scope (Ne) /= Standard_Standard then 9236 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); 9237 end if; 9238 9239 -- For navigation purposes, we want to treat the inequality as an 9240 -- implicit reference to the corresponding equality. Preserve the 9241 -- Comes_From_ source flag to generate proper Xref entries. 9242 9243 Preserve_Comes_From_Source (Neg, N); 9244 Preserve_Comes_From_Source (Right_Opnd (Neg), N); 9245 Rewrite (N, Neg); 9246 Analyze_And_Resolve (N, Standard_Boolean); 9247 end; 9248 end if; 9249 9250 -- No need for optimization in GNATprove mode, where we would rather see 9251 -- the original source expression. 9252 9253 if not GNATprove_Mode then 9254 Optimize_Length_Comparison (N); 9255 end if; 9256 end Expand_N_Op_Ne; 9257 9258 --------------------- 9259 -- Expand_N_Op_Not -- 9260 --------------------- 9261 9262 -- If the argument is other than a Boolean array type, there is no special 9263 -- expansion required, except for dealing with validity checks, and non- 9264 -- standard boolean representations. 9265 9266 -- For the packed array case, we call the special routine in Exp_Pakd, 9267 -- except that if the component size is greater than one, we use the 9268 -- standard routine generating a gruesome loop (it is so peculiar to have 9269 -- packed arrays with non-standard Boolean representations anyway, so it 9270 -- does not matter that we do not handle this case efficiently). 9271 9272 -- For the unpacked array case (and for the special packed case where we 9273 -- have non standard Booleans, as discussed above), we generate and insert 9274 -- into the tree the following function definition: 9275 9276 -- function Nnnn (A : arr) is 9277 -- B : arr; 9278 -- begin 9279 -- for J in a'range loop 9280 -- B (J) := not A (J); 9281 -- end loop; 9282 -- return B; 9283 -- end Nnnn; 9284 9285 -- Here arr is the actual subtype of the parameter (and hence always 9286 -- constrained). Then we replace the not with a call to this function. 9287 9288 procedure Expand_N_Op_Not (N : Node_Id) is 9289 Loc : constant Source_Ptr := Sloc (N); 9290 Typ : constant Entity_Id := Etype (N); 9291 Opnd : Node_Id; 9292 Arr : Entity_Id; 9293 A : Entity_Id; 9294 B : Entity_Id; 9295 J : Entity_Id; 9296 A_J : Node_Id; 9297 B_J : Node_Id; 9298 9299 Func_Name : Entity_Id; 9300 Loop_Statement : Node_Id; 9301 9302 begin 9303 Unary_Op_Validity_Checks (N); 9304 9305 -- For boolean operand, deal with non-standard booleans 9306 9307 if Is_Boolean_Type (Typ) then 9308 Adjust_Condition (Right_Opnd (N)); 9309 Set_Etype (N, Standard_Boolean); 9310 Adjust_Result_Type (N, Typ); 9311 return; 9312 end if; 9313 9314 -- Only array types need any other processing 9315 9316 if not Is_Array_Type (Typ) then 9317 return; 9318 end if; 9319 9320 -- Case of array operand. If bit packed with a component size of 1, 9321 -- handle it in Exp_Pakd if the operand is known to be aligned. 9322 9323 if Is_Bit_Packed_Array (Typ) 9324 and then Component_Size (Typ) = 1 9325 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 9326 then 9327 Expand_Packed_Not (N); 9328 return; 9329 end if; 9330 9331 -- Case of array operand which is not bit-packed. If the context is 9332 -- a safe assignment, call in-place operation, If context is a larger 9333 -- boolean expression in the context of a safe assignment, expansion is 9334 -- done by enclosing operation. 9335 9336 Opnd := Relocate_Node (Right_Opnd (N)); 9337 Convert_To_Actual_Subtype (Opnd); 9338 Arr := Etype (Opnd); 9339 Ensure_Defined (Arr, N); 9340 Silly_Boolean_Array_Not_Test (N, Arr); 9341 9342 if Nkind (Parent (N)) = N_Assignment_Statement then 9343 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then 9344 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 9345 return; 9346 9347 -- Special case the negation of a binary operation 9348 9349 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor) 9350 and then Safe_In_Place_Array_Op 9351 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) 9352 then 9353 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 9354 return; 9355 end if; 9356 9357 elsif Nkind (Parent (N)) in N_Binary_Op 9358 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 9359 then 9360 declare 9361 Op1 : constant Node_Id := Left_Opnd (Parent (N)); 9362 Op2 : constant Node_Id := Right_Opnd (Parent (N)); 9363 Lhs : constant Node_Id := Name (Parent (Parent (N))); 9364 9365 begin 9366 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then 9367 9368 -- (not A) op (not B) can be reduced to a single call 9369 9370 if N = Op1 and then Nkind (Op2) = N_Op_Not then 9371 return; 9372 9373 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then 9374 return; 9375 9376 -- A xor (not B) can also be special-cased 9377 9378 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then 9379 return; 9380 end if; 9381 end if; 9382 end; 9383 end if; 9384 9385 A := Make_Defining_Identifier (Loc, Name_uA); 9386 B := Make_Defining_Identifier (Loc, Name_uB); 9387 J := Make_Defining_Identifier (Loc, Name_uJ); 9388 9389 A_J := 9390 Make_Indexed_Component (Loc, 9391 Prefix => New_Occurrence_Of (A, Loc), 9392 Expressions => New_List (New_Occurrence_Of (J, Loc))); 9393 9394 B_J := 9395 Make_Indexed_Component (Loc, 9396 Prefix => New_Occurrence_Of (B, Loc), 9397 Expressions => New_List (New_Occurrence_Of (J, Loc))); 9398 9399 Loop_Statement := 9400 Make_Implicit_Loop_Statement (N, 9401 Identifier => Empty, 9402 9403 Iteration_Scheme => 9404 Make_Iteration_Scheme (Loc, 9405 Loop_Parameter_Specification => 9406 Make_Loop_Parameter_Specification (Loc, 9407 Defining_Identifier => J, 9408 Discrete_Subtype_Definition => 9409 Make_Attribute_Reference (Loc, 9410 Prefix => Make_Identifier (Loc, Chars (A)), 9411 Attribute_Name => Name_Range))), 9412 9413 Statements => New_List ( 9414 Make_Assignment_Statement (Loc, 9415 Name => B_J, 9416 Expression => Make_Op_Not (Loc, A_J)))); 9417 9418 Func_Name := Make_Temporary (Loc, 'N'); 9419 Set_Is_Inlined (Func_Name); 9420 9421 Insert_Action (N, 9422 Make_Subprogram_Body (Loc, 9423 Specification => 9424 Make_Function_Specification (Loc, 9425 Defining_Unit_Name => Func_Name, 9426 Parameter_Specifications => New_List ( 9427 Make_Parameter_Specification (Loc, 9428 Defining_Identifier => A, 9429 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 9430 Result_Definition => New_Occurrence_Of (Typ, Loc)), 9431 9432 Declarations => New_List ( 9433 Make_Object_Declaration (Loc, 9434 Defining_Identifier => B, 9435 Object_Definition => New_Occurrence_Of (Arr, Loc))), 9436 9437 Handled_Statement_Sequence => 9438 Make_Handled_Sequence_Of_Statements (Loc, 9439 Statements => New_List ( 9440 Loop_Statement, 9441 Make_Simple_Return_Statement (Loc, 9442 Expression => Make_Identifier (Loc, Chars (B))))))); 9443 9444 Rewrite (N, 9445 Make_Function_Call (Loc, 9446 Name => New_Occurrence_Of (Func_Name, Loc), 9447 Parameter_Associations => New_List (Opnd))); 9448 9449 Analyze_And_Resolve (N, Typ); 9450 end Expand_N_Op_Not; 9451 9452 -------------------- 9453 -- Expand_N_Op_Or -- 9454 -------------------- 9455 9456 procedure Expand_N_Op_Or (N : Node_Id) is 9457 Typ : constant Entity_Id := Etype (N); 9458 9459 begin 9460 Binary_Op_Validity_Checks (N); 9461 9462 if Is_Array_Type (Etype (N)) then 9463 Expand_Boolean_Operator (N); 9464 9465 elsif Is_Boolean_Type (Etype (N)) then 9466 Adjust_Condition (Left_Opnd (N)); 9467 Adjust_Condition (Right_Opnd (N)); 9468 Set_Etype (N, Standard_Boolean); 9469 Adjust_Result_Type (N, Typ); 9470 9471 elsif Is_Intrinsic_Subprogram (Entity (N)) then 9472 Expand_Intrinsic_Call (N, Entity (N)); 9473 end if; 9474 9475 Expand_Nonbinary_Modular_Op (N); 9476 end Expand_N_Op_Or; 9477 9478 ---------------------- 9479 -- Expand_N_Op_Plus -- 9480 ---------------------- 9481 9482 procedure Expand_N_Op_Plus (N : Node_Id) is 9483 begin 9484 Unary_Op_Validity_Checks (N); 9485 9486 -- Check for MINIMIZED/ELIMINATED overflow mode 9487 9488 if Minimized_Eliminated_Overflow_Check (N) then 9489 Apply_Arithmetic_Overflow_Check (N); 9490 return; 9491 end if; 9492 end Expand_N_Op_Plus; 9493 9494 --------------------- 9495 -- Expand_N_Op_Rem -- 9496 --------------------- 9497 9498 procedure Expand_N_Op_Rem (N : Node_Id) is 9499 Loc : constant Source_Ptr := Sloc (N); 9500 Typ : constant Entity_Id := Etype (N); 9501 9502 Left : Node_Id; 9503 Right : Node_Id; 9504 9505 Lo : Uint; 9506 Hi : Uint; 9507 OK : Boolean; 9508 9509 Lneg : Boolean; 9510 Rneg : Boolean; 9511 -- Set if corresponding operand can be negative 9512 9513 pragma Unreferenced (Hi); 9514 9515 begin 9516 Binary_Op_Validity_Checks (N); 9517 9518 -- Check for MINIMIZED/ELIMINATED overflow mode 9519 9520 if Minimized_Eliminated_Overflow_Check (N) then 9521 Apply_Arithmetic_Overflow_Check (N); 9522 return; 9523 end if; 9524 9525 if Is_Integer_Type (Etype (N)) then 9526 Apply_Divide_Checks (N); 9527 9528 -- All done if we don't have a REM any more, which can happen as a 9529 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 9530 9531 if Nkind (N) /= N_Op_Rem then 9532 return; 9533 end if; 9534 end if; 9535 9536 -- Proceed with expansion of REM 9537 9538 Left := Left_Opnd (N); 9539 Right := Right_Opnd (N); 9540 9541 -- Apply optimization x rem 1 = 0. We don't really need that with gcc, 9542 -- but it is useful with other back ends, and is certainly harmless. 9543 9544 if Is_Integer_Type (Etype (N)) 9545 and then Compile_Time_Known_Value (Right) 9546 and then Expr_Value (Right) = Uint_1 9547 then 9548 -- Call Remove_Side_Effects to ensure that any side effects in the 9549 -- ignored left operand (in particular function calls to user defined 9550 -- functions) are properly executed. 9551 9552 Remove_Side_Effects (Left); 9553 9554 Rewrite (N, Make_Integer_Literal (Loc, 0)); 9555 Analyze_And_Resolve (N, Typ); 9556 return; 9557 end if; 9558 9559 -- Deal with annoying case of largest negative number remainder minus 9560 -- one. Gigi may not handle this case correctly, because on some 9561 -- targets, the mod value is computed using a divide instruction 9562 -- which gives an overflow trap for this case. 9563 9564 -- It would be a bit more efficient to figure out which targets this 9565 -- is really needed for, but in practice it is reasonable to do the 9566 -- following special check in all cases, since it means we get a clearer 9567 -- message, and also the overhead is minimal given that division is 9568 -- expensive in any case. 9569 9570 -- In fact the check is quite easy, if the right operand is -1, then 9571 -- the remainder is always 0, and we can just ignore the left operand 9572 -- completely in this case. 9573 9574 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 9575 Lneg := (not OK) or else Lo < 0; 9576 9577 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True); 9578 Rneg := (not OK) or else Lo < 0; 9579 9580 -- We won't mess with trying to find out if the left operand can really 9581 -- be the largest negative number (that's a pain in the case of private 9582 -- types and this is really marginal). We will just assume that we need 9583 -- the test if the left operand can be negative at all. 9584 9585 if Lneg and Rneg then 9586 Rewrite (N, 9587 Make_If_Expression (Loc, 9588 Expressions => New_List ( 9589 Make_Op_Eq (Loc, 9590 Left_Opnd => Duplicate_Subexpr (Right), 9591 Right_Opnd => 9592 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))), 9593 9594 Unchecked_Convert_To (Typ, 9595 Make_Integer_Literal (Loc, Uint_0)), 9596 9597 Relocate_Node (N)))); 9598 9599 Set_Analyzed (Next (Next (First (Expressions (N))))); 9600 Analyze_And_Resolve (N, Typ); 9601 end if; 9602 end Expand_N_Op_Rem; 9603 9604 ----------------------------- 9605 -- Expand_N_Op_Rotate_Left -- 9606 ----------------------------- 9607 9608 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is 9609 begin 9610 Binary_Op_Validity_Checks (N); 9611 9612 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C, 9613 -- so we rewrite in terms of logical shifts 9614 9615 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits) 9616 9617 -- where Bits is the shift count mod Esize (the mod operation here 9618 -- deals with ludicrous large shift counts, which are apparently OK). 9619 9620 -- What about nonbinary modulus ??? 9621 9622 declare 9623 Loc : constant Source_Ptr := Sloc (N); 9624 Rtp : constant Entity_Id := Etype (Right_Opnd (N)); 9625 Typ : constant Entity_Id := Etype (N); 9626 9627 begin 9628 if Modify_Tree_For_C then 9629 Rewrite (Right_Opnd (N), 9630 Make_Op_Rem (Loc, 9631 Left_Opnd => Relocate_Node (Right_Opnd (N)), 9632 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); 9633 9634 Analyze_And_Resolve (Right_Opnd (N), Rtp); 9635 9636 Rewrite (N, 9637 Make_Op_Or (Loc, 9638 Left_Opnd => 9639 Make_Op_Shift_Left (Loc, 9640 Left_Opnd => Left_Opnd (N), 9641 Right_Opnd => Right_Opnd (N)), 9642 9643 Right_Opnd => 9644 Make_Op_Shift_Right (Loc, 9645 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)), 9646 Right_Opnd => 9647 Make_Op_Subtract (Loc, 9648 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), 9649 Right_Opnd => 9650 Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); 9651 9652 Analyze_And_Resolve (N, Typ); 9653 end if; 9654 end; 9655 end Expand_N_Op_Rotate_Left; 9656 9657 ------------------------------ 9658 -- Expand_N_Op_Rotate_Right -- 9659 ------------------------------ 9660 9661 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is 9662 begin 9663 Binary_Op_Validity_Checks (N); 9664 9665 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C, 9666 -- so we rewrite in terms of logical shifts 9667 9668 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits) 9669 9670 -- where Bits is the shift count mod Esize (the mod operation here 9671 -- deals with ludicrous large shift counts, which are apparently OK). 9672 9673 -- What about nonbinary modulus ??? 9674 9675 declare 9676 Loc : constant Source_Ptr := Sloc (N); 9677 Rtp : constant Entity_Id := Etype (Right_Opnd (N)); 9678 Typ : constant Entity_Id := Etype (N); 9679 9680 begin 9681 Rewrite (Right_Opnd (N), 9682 Make_Op_Rem (Loc, 9683 Left_Opnd => Relocate_Node (Right_Opnd (N)), 9684 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); 9685 9686 Analyze_And_Resolve (Right_Opnd (N), Rtp); 9687 9688 if Modify_Tree_For_C then 9689 Rewrite (N, 9690 Make_Op_Or (Loc, 9691 Left_Opnd => 9692 Make_Op_Shift_Right (Loc, 9693 Left_Opnd => Left_Opnd (N), 9694 Right_Opnd => Right_Opnd (N)), 9695 9696 Right_Opnd => 9697 Make_Op_Shift_Left (Loc, 9698 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)), 9699 Right_Opnd => 9700 Make_Op_Subtract (Loc, 9701 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), 9702 Right_Opnd => 9703 Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); 9704 9705 Analyze_And_Resolve (N, Typ); 9706 end if; 9707 end; 9708 end Expand_N_Op_Rotate_Right; 9709 9710 ---------------------------- 9711 -- Expand_N_Op_Shift_Left -- 9712 ---------------------------- 9713 9714 -- Note: nothing in this routine depends on left as opposed to right shifts 9715 -- so we share the routine for expanding shift right operations. 9716 9717 procedure Expand_N_Op_Shift_Left (N : Node_Id) is 9718 begin 9719 Binary_Op_Validity_Checks (N); 9720 9721 -- If we are in Modify_Tree_For_C mode, then ensure that the right 9722 -- operand is not greater than the word size (since that would not 9723 -- be defined properly by the corresponding C shift operator). 9724 9725 if Modify_Tree_For_C then 9726 declare 9727 Right : constant Node_Id := Right_Opnd (N); 9728 Loc : constant Source_Ptr := Sloc (Right); 9729 Typ : constant Entity_Id := Etype (N); 9730 Siz : constant Uint := Esize (Typ); 9731 Orig : Node_Id; 9732 OK : Boolean; 9733 Lo : Uint; 9734 Hi : Uint; 9735 9736 begin 9737 if Compile_Time_Known_Value (Right) then 9738 if Expr_Value (Right) >= Siz then 9739 Rewrite (N, Make_Integer_Literal (Loc, 0)); 9740 Analyze_And_Resolve (N, Typ); 9741 end if; 9742 9743 -- Not compile time known, find range 9744 9745 else 9746 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 9747 9748 -- Nothing to do if known to be OK range, otherwise expand 9749 9750 if not OK or else Hi >= Siz then 9751 9752 -- Prevent recursion on copy of shift node 9753 9754 Orig := Relocate_Node (N); 9755 Set_Analyzed (Orig); 9756 9757 -- Now do the rewrite 9758 9759 Rewrite (N, 9760 Make_If_Expression (Loc, 9761 Expressions => New_List ( 9762 Make_Op_Ge (Loc, 9763 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), 9764 Right_Opnd => Make_Integer_Literal (Loc, Siz)), 9765 Make_Integer_Literal (Loc, 0), 9766 Orig))); 9767 Analyze_And_Resolve (N, Typ); 9768 end if; 9769 end if; 9770 end; 9771 end if; 9772 end Expand_N_Op_Shift_Left; 9773 9774 ----------------------------- 9775 -- Expand_N_Op_Shift_Right -- 9776 ----------------------------- 9777 9778 procedure Expand_N_Op_Shift_Right (N : Node_Id) is 9779 begin 9780 -- Share shift left circuit 9781 9782 Expand_N_Op_Shift_Left (N); 9783 end Expand_N_Op_Shift_Right; 9784 9785 ---------------------------------------- 9786 -- Expand_N_Op_Shift_Right_Arithmetic -- 9787 ---------------------------------------- 9788 9789 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is 9790 begin 9791 Binary_Op_Validity_Checks (N); 9792 9793 -- If we are in Modify_Tree_For_C mode, there is no shift right 9794 -- arithmetic in C, so we rewrite in terms of logical shifts. 9795 9796 -- Shift_Right (Num, Bits) or 9797 -- (if Num >= Sign 9798 -- then not (Shift_Right (Mask, bits)) 9799 -- else 0) 9800 9801 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1) 9802 9803 -- Note: in almost all C compilers it would work to just shift a 9804 -- signed integer right, but it's undefined and we cannot rely on it. 9805 9806 -- Note: the above works fine for shift counts greater than or equal 9807 -- to the word size, since in this case (not (Shift_Right (Mask, bits))) 9808 -- generates all 1'bits. 9809 9810 -- What about nonbinary modulus ??? 9811 9812 declare 9813 Loc : constant Source_Ptr := Sloc (N); 9814 Typ : constant Entity_Id := Etype (N); 9815 Sign : constant Uint := 2 ** (Esize (Typ) - 1); 9816 Mask : constant Uint := (2 ** Esize (Typ)) - 1; 9817 Left : constant Node_Id := Left_Opnd (N); 9818 Right : constant Node_Id := Right_Opnd (N); 9819 Maskx : Node_Id; 9820 9821 begin 9822 if Modify_Tree_For_C then 9823 9824 -- Here if not (Shift_Right (Mask, bits)) can be computed at 9825 -- compile time as a single constant. 9826 9827 if Compile_Time_Known_Value (Right) then 9828 declare 9829 Val : constant Uint := Expr_Value (Right); 9830 9831 begin 9832 if Val >= Esize (Typ) then 9833 Maskx := Make_Integer_Literal (Loc, Mask); 9834 9835 else 9836 Maskx := 9837 Make_Integer_Literal (Loc, 9838 Intval => Mask - (Mask / (2 ** Expr_Value (Right)))); 9839 end if; 9840 end; 9841 9842 else 9843 Maskx := 9844 Make_Op_Not (Loc, 9845 Right_Opnd => 9846 Make_Op_Shift_Right (Loc, 9847 Left_Opnd => Make_Integer_Literal (Loc, Mask), 9848 Right_Opnd => Duplicate_Subexpr_No_Checks (Right))); 9849 end if; 9850 9851 -- Now do the rewrite 9852 9853 Rewrite (N, 9854 Make_Op_Or (Loc, 9855 Left_Opnd => 9856 Make_Op_Shift_Right (Loc, 9857 Left_Opnd => Left, 9858 Right_Opnd => Right), 9859 Right_Opnd => 9860 Make_If_Expression (Loc, 9861 Expressions => New_List ( 9862 Make_Op_Ge (Loc, 9863 Left_Opnd => Duplicate_Subexpr_No_Checks (Left), 9864 Right_Opnd => Make_Integer_Literal (Loc, Sign)), 9865 Maskx, 9866 Make_Integer_Literal (Loc, 0))))); 9867 Analyze_And_Resolve (N, Typ); 9868 end if; 9869 end; 9870 end Expand_N_Op_Shift_Right_Arithmetic; 9871 9872 -------------------------- 9873 -- Expand_N_Op_Subtract -- 9874 -------------------------- 9875 9876 procedure Expand_N_Op_Subtract (N : Node_Id) is 9877 Typ : constant Entity_Id := Etype (N); 9878 9879 begin 9880 Binary_Op_Validity_Checks (N); 9881 9882 -- Check for MINIMIZED/ELIMINATED overflow mode 9883 9884 if Minimized_Eliminated_Overflow_Check (N) then 9885 Apply_Arithmetic_Overflow_Check (N); 9886 return; 9887 end if; 9888 9889 -- N - 0 = N for integer types 9890 9891 if Is_Integer_Type (Typ) 9892 and then Compile_Time_Known_Value (Right_Opnd (N)) 9893 and then Expr_Value (Right_Opnd (N)) = 0 9894 then 9895 Rewrite (N, Left_Opnd (N)); 9896 return; 9897 end if; 9898 9899 -- Arithmetic overflow checks for signed integer/fixed point types 9900 9901 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then 9902 Apply_Arithmetic_Overflow_Check (N); 9903 end if; 9904 9905 -- Overflow checks for floating-point if -gnateF mode active 9906 9907 Check_Float_Op_Overflow (N); 9908 9909 Expand_Nonbinary_Modular_Op (N); 9910 end Expand_N_Op_Subtract; 9911 9912 --------------------- 9913 -- Expand_N_Op_Xor -- 9914 --------------------- 9915 9916 procedure Expand_N_Op_Xor (N : Node_Id) is 9917 Typ : constant Entity_Id := Etype (N); 9918 9919 begin 9920 Binary_Op_Validity_Checks (N); 9921 9922 if Is_Array_Type (Etype (N)) then 9923 Expand_Boolean_Operator (N); 9924 9925 elsif Is_Boolean_Type (Etype (N)) then 9926 Adjust_Condition (Left_Opnd (N)); 9927 Adjust_Condition (Right_Opnd (N)); 9928 Set_Etype (N, Standard_Boolean); 9929 Adjust_Result_Type (N, Typ); 9930 9931 elsif Is_Intrinsic_Subprogram (Entity (N)) then 9932 Expand_Intrinsic_Call (N, Entity (N)); 9933 end if; 9934 end Expand_N_Op_Xor; 9935 9936 ---------------------- 9937 -- Expand_N_Or_Else -- 9938 ---------------------- 9939 9940 procedure Expand_N_Or_Else (N : Node_Id) 9941 renames Expand_Short_Circuit_Operator; 9942 9943 ----------------------------------- 9944 -- Expand_N_Qualified_Expression -- 9945 ----------------------------------- 9946 9947 procedure Expand_N_Qualified_Expression (N : Node_Id) is 9948 Operand : constant Node_Id := Expression (N); 9949 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 9950 9951 begin 9952 -- Do validity check if validity checking operands 9953 9954 if Validity_Checks_On and Validity_Check_Operands then 9955 Ensure_Valid (Operand); 9956 end if; 9957 9958 -- Apply possible constraint check 9959 9960 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); 9961 9962 if Do_Range_Check (Operand) then 9963 Set_Do_Range_Check (Operand, False); 9964 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed); 9965 end if; 9966 end Expand_N_Qualified_Expression; 9967 9968 ------------------------------------ 9969 -- Expand_N_Quantified_Expression -- 9970 ------------------------------------ 9971 9972 -- We expand: 9973 9974 -- for all X in range => Cond 9975 9976 -- into: 9977 9978 -- T := True; 9979 -- for X in range loop 9980 -- if not Cond then 9981 -- T := False; 9982 -- exit; 9983 -- end if; 9984 -- end loop; 9985 9986 -- Similarly, an existentially quantified expression: 9987 9988 -- for some X in range => Cond 9989 9990 -- becomes: 9991 9992 -- T := False; 9993 -- for X in range loop 9994 -- if Cond then 9995 -- T := True; 9996 -- exit; 9997 -- end if; 9998 -- end loop; 9999 10000 -- In both cases, the iteration may be over a container in which case it is 10001 -- given by an iterator specification, not a loop parameter specification. 10002 10003 procedure Expand_N_Quantified_Expression (N : Node_Id) is 10004 Actions : constant List_Id := New_List; 10005 For_All : constant Boolean := All_Present (N); 10006 Iter_Spec : constant Node_Id := Iterator_Specification (N); 10007 Loc : constant Source_Ptr := Sloc (N); 10008 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); 10009 Cond : Node_Id; 10010 Flag : Entity_Id; 10011 Scheme : Node_Id; 10012 Stmts : List_Id; 10013 10014 begin 10015 -- Create the declaration of the flag which tracks the status of the 10016 -- quantified expression. Generate: 10017 10018 -- Flag : Boolean := (True | False); 10019 10020 Flag := Make_Temporary (Loc, 'T', N); 10021 10022 Append_To (Actions, 10023 Make_Object_Declaration (Loc, 10024 Defining_Identifier => Flag, 10025 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 10026 Expression => 10027 New_Occurrence_Of (Boolean_Literals (For_All), Loc))); 10028 10029 -- Construct the circuitry which tracks the status of the quantified 10030 -- expression. Generate: 10031 10032 -- if [not] Cond then 10033 -- Flag := (False | True); 10034 -- exit; 10035 -- end if; 10036 10037 Cond := Relocate_Node (Condition (N)); 10038 10039 if For_All then 10040 Cond := Make_Op_Not (Loc, Cond); 10041 end if; 10042 10043 Stmts := New_List ( 10044 Make_Implicit_If_Statement (N, 10045 Condition => Cond, 10046 Then_Statements => New_List ( 10047 Make_Assignment_Statement (Loc, 10048 Name => New_Occurrence_Of (Flag, Loc), 10049 Expression => 10050 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), 10051 Make_Exit_Statement (Loc)))); 10052 10053 -- Build the loop equivalent of the quantified expression 10054 10055 if Present (Iter_Spec) then 10056 Scheme := 10057 Make_Iteration_Scheme (Loc, 10058 Iterator_Specification => Iter_Spec); 10059 else 10060 Scheme := 10061 Make_Iteration_Scheme (Loc, 10062 Loop_Parameter_Specification => Loop_Spec); 10063 end if; 10064 10065 Append_To (Actions, 10066 Make_Loop_Statement (Loc, 10067 Iteration_Scheme => Scheme, 10068 Statements => Stmts, 10069 End_Label => Empty)); 10070 10071 -- Transform the quantified expression 10072 10073 Rewrite (N, 10074 Make_Expression_With_Actions (Loc, 10075 Expression => New_Occurrence_Of (Flag, Loc), 10076 Actions => Actions)); 10077 Analyze_And_Resolve (N, Standard_Boolean); 10078 end Expand_N_Quantified_Expression; 10079 10080 ----------------------------------- 10081 -- Expand_N_Reduction_Expression -- 10082 ----------------------------------- 10083 10084 procedure Expand_N_Reduction_Expression (N : Node_Id) is 10085 Actions : constant List_Id := New_List; 10086 Expr : constant Node_Id := Expression (N); 10087 Iter_Spec : constant Node_Id := Iterator_Specification (N); 10088 Loc : constant Source_Ptr := Sloc (N); 10089 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); 10090 Typ : constant Entity_Id := Etype (N); 10091 10092 Actual : Node_Id; 10093 New_Call : Node_Id; 10094 Reduction_Par : Node_Id; 10095 Result : Entity_Id; 10096 Scheme : Node_Id; 10097 10098 begin 10099 Result := Make_Temporary (Loc, 'R', N); 10100 New_Call := New_Copy_Tree (Expr); 10101 10102 if Nkind (New_Call) = N_Function_Call then 10103 Actual := First (Parameter_Associations (New_Call)); 10104 10105 if Nkind (Actual) /= N_Reduction_Expression_Parameter then 10106 Actual := Next_Actual (Actual); 10107 end if; 10108 10109 elsif Nkind (New_Call) in N_Binary_Op then 10110 Actual := Left_Opnd (New_Call); 10111 10112 if Nkind (Actual) /= N_Reduction_Expression_Parameter then 10113 Actual := Right_Opnd (New_Call); 10114 end if; 10115 end if; 10116 10117 Reduction_Par := Expression (Actual); 10118 10119 Append_To (Actions, 10120 Make_Object_Declaration (Loc, 10121 Defining_Identifier => Result, 10122 Object_Definition => New_Occurrence_Of (Typ, Loc), 10123 Expression => New_Copy_Tree (Reduction_Par))); 10124 10125 if Present (Iter_Spec) then 10126 Scheme := 10127 Make_Iteration_Scheme (Loc, 10128 Iterator_Specification => Iter_Spec); 10129 else 10130 Scheme := 10131 Make_Iteration_Scheme (Loc, 10132 Loop_Parameter_Specification => Loop_Spec); 10133 end if; 10134 10135 Replace (Actual, New_Occurrence_Of (Result, Loc)); 10136 10137 Append_To (Actions, 10138 Make_Loop_Statement (Loc, 10139 Iteration_Scheme => Scheme, 10140 Statements => New_List (Make_Assignment_Statement (Loc, 10141 New_Occurrence_Of (Result, Loc), New_Call)), 10142 End_Label => Empty)); 10143 10144 Rewrite (N, 10145 Make_Expression_With_Actions (Loc, 10146 Expression => New_Occurrence_Of (Result, Loc), 10147 Actions => Actions)); 10148 Analyze_And_Resolve (N, Typ); 10149 end Expand_N_Reduction_Expression; 10150 10151 --------------------------------- 10152 -- Expand_N_Selected_Component -- 10153 --------------------------------- 10154 10155 procedure Expand_N_Selected_Component (N : Node_Id) is 10156 Loc : constant Source_Ptr := Sloc (N); 10157 Par : constant Node_Id := Parent (N); 10158 P : constant Node_Id := Prefix (N); 10159 S : constant Node_Id := Selector_Name (N); 10160 Ptyp : Entity_Id := Underlying_Type (Etype (P)); 10161 Disc : Entity_Id; 10162 New_N : Node_Id; 10163 Dcon : Elmt_Id; 10164 Dval : Node_Id; 10165 10166 function In_Left_Hand_Side (Comp : Node_Id) return Boolean; 10167 -- Gigi needs a temporary for prefixes that depend on a discriminant, 10168 -- unless the context of an assignment can provide size information. 10169 -- Don't we have a general routine that does this??? 10170 10171 function Is_Subtype_Declaration return Boolean; 10172 -- The replacement of a discriminant reference by its value is required 10173 -- if this is part of the initialization of an temporary generated by a 10174 -- change of representation. This shows up as the construction of a 10175 -- discriminant constraint for a subtype declared at the same point as 10176 -- the entity in the prefix of the selected component. We recognize this 10177 -- case when the context of the reference is: 10178 -- subtype ST is T(Obj.D); 10179 -- where the entity for Obj comes from source, and ST has the same sloc. 10180 10181 ----------------------- 10182 -- In_Left_Hand_Side -- 10183 ----------------------- 10184 10185 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is 10186 begin 10187 return (Nkind (Parent (Comp)) = N_Assignment_Statement 10188 and then Comp = Name (Parent (Comp))) 10189 or else (Present (Parent (Comp)) 10190 and then Nkind (Parent (Comp)) in N_Subexpr 10191 and then In_Left_Hand_Side (Parent (Comp))); 10192 end In_Left_Hand_Side; 10193 10194 ----------------------------- 10195 -- Is_Subtype_Declaration -- 10196 ----------------------------- 10197 10198 function Is_Subtype_Declaration return Boolean is 10199 Par : constant Node_Id := Parent (N); 10200 begin 10201 return 10202 Nkind (Par) = N_Index_Or_Discriminant_Constraint 10203 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration 10204 and then Comes_From_Source (Entity (Prefix (N))) 10205 and then Sloc (Par) = Sloc (Entity (Prefix (N))); 10206 end Is_Subtype_Declaration; 10207 10208 -- Start of processing for Expand_N_Selected_Component 10209 10210 begin 10211 -- Insert explicit dereference if required 10212 10213 if Is_Access_Type (Ptyp) then 10214 10215 -- First set prefix type to proper access type, in case it currently 10216 -- has a private (non-access) view of this type. 10217 10218 Set_Etype (P, Ptyp); 10219 10220 Insert_Explicit_Dereference (P); 10221 Analyze_And_Resolve (P, Designated_Type (Ptyp)); 10222 10223 if Ekind (Etype (P)) = E_Private_Subtype 10224 and then Is_For_Access_Subtype (Etype (P)) 10225 then 10226 Set_Etype (P, Base_Type (Etype (P))); 10227 end if; 10228 10229 Ptyp := Etype (P); 10230 end if; 10231 10232 -- Deal with discriminant check required 10233 10234 if Do_Discriminant_Check (N) then 10235 if Present (Discriminant_Checking_Func 10236 (Original_Record_Component (Entity (S)))) 10237 then 10238 -- Present the discriminant checking function to the backend, so 10239 -- that it can inline the call to the function. 10240 10241 Add_Inlined_Body 10242 (Discriminant_Checking_Func 10243 (Original_Record_Component (Entity (S))), 10244 N); 10245 10246 -- Now reset the flag and generate the call 10247 10248 Set_Do_Discriminant_Check (N, False); 10249 Generate_Discriminant_Check (N); 10250 10251 -- In the case of Unchecked_Union, no discriminant checking is 10252 -- actually performed. 10253 10254 else 10255 Set_Do_Discriminant_Check (N, False); 10256 end if; 10257 end if; 10258 10259 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 10260 -- function, then additional actuals must be passed. 10261 10262 if Is_Build_In_Place_Function_Call (P) then 10263 Make_Build_In_Place_Call_In_Anonymous_Context (P); 10264 10265 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 10266 -- containing build-in-place function calls whose returned object covers 10267 -- interface types. 10268 10269 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then 10270 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); 10271 end if; 10272 10273 -- Gigi cannot handle unchecked conversions that are the prefix of a 10274 -- selected component with discriminants. This must be checked during 10275 -- expansion, because during analysis the type of the selector is not 10276 -- known at the point the prefix is analyzed. If the conversion is the 10277 -- target of an assignment, then we cannot force the evaluation. 10278 10279 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion 10280 and then Has_Discriminants (Etype (N)) 10281 and then not In_Left_Hand_Side (N) 10282 then 10283 Force_Evaluation (Prefix (N)); 10284 end if; 10285 10286 -- Remaining processing applies only if selector is a discriminant 10287 10288 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then 10289 10290 -- If the selector is a discriminant of a constrained record type, 10291 -- we may be able to rewrite the expression with the actual value 10292 -- of the discriminant, a useful optimization in some cases. 10293 10294 if Is_Record_Type (Ptyp) 10295 and then Has_Discriminants (Ptyp) 10296 and then Is_Constrained (Ptyp) 10297 then 10298 -- Do this optimization for discrete types only, and not for 10299 -- access types (access discriminants get us into trouble). 10300 10301 if not Is_Discrete_Type (Etype (N)) then 10302 null; 10303 10304 -- Don't do this on the left-hand side of an assignment statement. 10305 -- Normally one would think that references like this would not 10306 -- occur, but they do in generated code, and mean that we really 10307 -- do want to assign the discriminant. 10308 10309 elsif Nkind (Par) = N_Assignment_Statement 10310 and then Name (Par) = N 10311 then 10312 null; 10313 10314 -- Don't do this optimization for the prefix of an attribute or 10315 -- the name of an object renaming declaration since these are 10316 -- contexts where we do not want the value anyway. 10317 10318 elsif (Nkind (Par) = N_Attribute_Reference 10319 and then Prefix (Par) = N) 10320 or else Is_Renamed_Object (N) 10321 then 10322 null; 10323 10324 -- Don't do this optimization if we are within the code for a 10325 -- discriminant check, since the whole point of such a check may 10326 -- be to verify the condition on which the code below depends. 10327 10328 elsif Is_In_Discriminant_Check (N) then 10329 null; 10330 10331 -- Green light to see if we can do the optimization. There is 10332 -- still one condition that inhibits the optimization below but 10333 -- now is the time to check the particular discriminant. 10334 10335 else 10336 -- Loop through discriminants to find the matching discriminant 10337 -- constraint to see if we can copy it. 10338 10339 Disc := First_Discriminant (Ptyp); 10340 Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); 10341 Discr_Loop : while Present (Dcon) loop 10342 Dval := Node (Dcon); 10343 10344 -- Check if this is the matching discriminant and if the 10345 -- discriminant value is simple enough to make sense to 10346 -- copy. We don't want to copy complex expressions, and 10347 -- indeed to do so can cause trouble (before we put in 10348 -- this guard, a discriminant expression containing an 10349 -- AND THEN was copied, causing problems for coverage 10350 -- analysis tools). 10351 10352 -- However, if the reference is part of the initialization 10353 -- code generated for an object declaration, we must use 10354 -- the discriminant value from the subtype constraint, 10355 -- because the selected component may be a reference to the 10356 -- object being initialized, whose discriminant is not yet 10357 -- set. This only happens in complex cases involving changes 10358 -- or representation. 10359 10360 if Disc = Entity (Selector_Name (N)) 10361 and then (Is_Entity_Name (Dval) 10362 or else Compile_Time_Known_Value (Dval) 10363 or else Is_Subtype_Declaration) 10364 then 10365 -- Here we have the matching discriminant. Check for 10366 -- the case of a discriminant of a component that is 10367 -- constrained by an outer discriminant, which cannot 10368 -- be optimized away. 10369 10370 if Denotes_Discriminant 10371 (Dval, Check_Concurrent => True) 10372 then 10373 exit Discr_Loop; 10374 10375 elsif Nkind (Original_Node (Dval)) = N_Selected_Component 10376 and then 10377 Denotes_Discriminant 10378 (Selector_Name (Original_Node (Dval)), True) 10379 then 10380 exit Discr_Loop; 10381 10382 -- Do not retrieve value if constraint is not static. It 10383 -- is generally not useful, and the constraint may be a 10384 -- rewritten outer discriminant in which case it is in 10385 -- fact incorrect. 10386 10387 elsif Is_Entity_Name (Dval) 10388 and then 10389 Nkind (Parent (Entity (Dval))) = N_Object_Declaration 10390 and then Present (Expression (Parent (Entity (Dval)))) 10391 and then not 10392 Is_OK_Static_Expression 10393 (Expression (Parent (Entity (Dval)))) 10394 then 10395 exit Discr_Loop; 10396 10397 -- In the context of a case statement, the expression may 10398 -- have the base type of the discriminant, and we need to 10399 -- preserve the constraint to avoid spurious errors on 10400 -- missing cases. 10401 10402 elsif Nkind (Parent (N)) = N_Case_Statement 10403 and then Etype (Dval) /= Etype (Disc) 10404 then 10405 Rewrite (N, 10406 Make_Qualified_Expression (Loc, 10407 Subtype_Mark => 10408 New_Occurrence_Of (Etype (Disc), Loc), 10409 Expression => 10410 New_Copy_Tree (Dval))); 10411 Analyze_And_Resolve (N, Etype (Disc)); 10412 10413 -- In case that comes out as a static expression, 10414 -- reset it (a selected component is never static). 10415 10416 Set_Is_Static_Expression (N, False); 10417 return; 10418 10419 -- Otherwise we can just copy the constraint, but the 10420 -- result is certainly not static. In some cases the 10421 -- discriminant constraint has been analyzed in the 10422 -- context of the original subtype indication, but for 10423 -- itypes the constraint might not have been analyzed 10424 -- yet, and this must be done now. 10425 10426 else 10427 Rewrite (N, New_Copy_Tree (Dval)); 10428 Analyze_And_Resolve (N); 10429 Set_Is_Static_Expression (N, False); 10430 return; 10431 end if; 10432 end if; 10433 10434 Next_Elmt (Dcon); 10435 Next_Discriminant (Disc); 10436 end loop Discr_Loop; 10437 10438 -- Note: the above loop should always find a matching 10439 -- discriminant, but if it does not, we just missed an 10440 -- optimization due to some glitch (perhaps a previous 10441 -- error), so ignore. 10442 10443 end if; 10444 end if; 10445 10446 -- The only remaining processing is in the case of a discriminant of 10447 -- a concurrent object, where we rewrite the prefix to denote the 10448 -- corresponding record type. If the type is derived and has renamed 10449 -- discriminants, use corresponding discriminant, which is the one 10450 -- that appears in the corresponding record. 10451 10452 if not Is_Concurrent_Type (Ptyp) then 10453 return; 10454 end if; 10455 10456 Disc := Entity (Selector_Name (N)); 10457 10458 if Is_Derived_Type (Ptyp) 10459 and then Present (Corresponding_Discriminant (Disc)) 10460 then 10461 Disc := Corresponding_Discriminant (Disc); 10462 end if; 10463 10464 New_N := 10465 Make_Selected_Component (Loc, 10466 Prefix => 10467 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), 10468 New_Copy_Tree (P)), 10469 Selector_Name => Make_Identifier (Loc, Chars (Disc))); 10470 10471 Rewrite (N, New_N); 10472 Analyze (N); 10473 end if; 10474 10475 -- Set Atomic_Sync_Required if necessary for atomic component 10476 10477 if Nkind (N) = N_Selected_Component then 10478 declare 10479 E : constant Entity_Id := Entity (Selector_Name (N)); 10480 Set : Boolean; 10481 10482 begin 10483 -- If component is atomic, but type is not, setting depends on 10484 -- disable/enable state for the component. 10485 10486 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then 10487 Set := not Atomic_Synchronization_Disabled (E); 10488 10489 -- If component is not atomic, but its type is atomic, setting 10490 -- depends on disable/enable state for the type. 10491 10492 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then 10493 Set := not Atomic_Synchronization_Disabled (Etype (E)); 10494 10495 -- If both component and type are atomic, we disable if either 10496 -- component or its type have sync disabled. 10497 10498 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then 10499 Set := (not Atomic_Synchronization_Disabled (E)) 10500 and then 10501 (not Atomic_Synchronization_Disabled (Etype (E))); 10502 10503 else 10504 Set := False; 10505 end if; 10506 10507 -- Set flag if required 10508 10509 if Set then 10510 Activate_Atomic_Synchronization (N); 10511 end if; 10512 end; 10513 end if; 10514 end Expand_N_Selected_Component; 10515 10516 -------------------- 10517 -- Expand_N_Slice -- 10518 -------------------- 10519 10520 procedure Expand_N_Slice (N : Node_Id) is 10521 Loc : constant Source_Ptr := Sloc (N); 10522 Typ : constant Entity_Id := Etype (N); 10523 10524 function Is_Procedure_Actual (N : Node_Id) return Boolean; 10525 -- Check whether the argument is an actual for a procedure call, in 10526 -- which case the expansion of a bit-packed slice is deferred until the 10527 -- call itself is expanded. The reason this is required is that we might 10528 -- have an IN OUT or OUT parameter, and the copy out is essential, and 10529 -- that copy out would be missed if we created a temporary here in 10530 -- Expand_N_Slice. Note that we don't bother to test specifically for an 10531 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it 10532 -- is harmless to defer expansion in the IN case, since the call 10533 -- processing will still generate the appropriate copy in operation, 10534 -- which will take care of the slice. 10535 10536 procedure Make_Temporary_For_Slice; 10537 -- Create a named variable for the value of the slice, in cases where 10538 -- the back end cannot handle it properly, e.g. when packed types or 10539 -- unaligned slices are involved. 10540 10541 ------------------------- 10542 -- Is_Procedure_Actual -- 10543 ------------------------- 10544 10545 function Is_Procedure_Actual (N : Node_Id) return Boolean is 10546 Par : Node_Id := Parent (N); 10547 10548 begin 10549 loop 10550 -- If our parent is a procedure call we can return 10551 10552 if Nkind (Par) = N_Procedure_Call_Statement then 10553 return True; 10554 10555 -- If our parent is a type conversion, keep climbing the tree, 10556 -- since a type conversion can be a procedure actual. Also keep 10557 -- climbing if parameter association or a qualified expression, 10558 -- since these are additional cases that do can appear on 10559 -- procedure actuals. 10560 10561 elsif Nkind_In (Par, N_Type_Conversion, 10562 N_Parameter_Association, 10563 N_Qualified_Expression) 10564 then 10565 Par := Parent (Par); 10566 10567 -- Any other case is not what we are looking for 10568 10569 else 10570 return False; 10571 end if; 10572 end loop; 10573 end Is_Procedure_Actual; 10574 10575 ------------------------------ 10576 -- Make_Temporary_For_Slice -- 10577 ------------------------------ 10578 10579 procedure Make_Temporary_For_Slice is 10580 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); 10581 Decl : Node_Id; 10582 10583 begin 10584 Decl := 10585 Make_Object_Declaration (Loc, 10586 Defining_Identifier => Ent, 10587 Object_Definition => New_Occurrence_Of (Typ, Loc)); 10588 10589 Set_No_Initialization (Decl); 10590 10591 Insert_Actions (N, New_List ( 10592 Decl, 10593 Make_Assignment_Statement (Loc, 10594 Name => New_Occurrence_Of (Ent, Loc), 10595 Expression => Relocate_Node (N)))); 10596 10597 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 10598 Analyze_And_Resolve (N, Typ); 10599 end Make_Temporary_For_Slice; 10600 10601 -- Local variables 10602 10603 Pref : constant Node_Id := Prefix (N); 10604 Pref_Typ : Entity_Id := Etype (Pref); 10605 10606 -- Start of processing for Expand_N_Slice 10607 10608 begin 10609 -- Special handling for access types 10610 10611 if Is_Access_Type (Pref_Typ) then 10612 Pref_Typ := Designated_Type (Pref_Typ); 10613 10614 Rewrite (Pref, 10615 Make_Explicit_Dereference (Sloc (N), 10616 Prefix => Relocate_Node (Pref))); 10617 10618 Analyze_And_Resolve (Pref, Pref_Typ); 10619 end if; 10620 10621 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 10622 -- function, then additional actuals must be passed. 10623 10624 if Is_Build_In_Place_Function_Call (Pref) then 10625 Make_Build_In_Place_Call_In_Anonymous_Context (Pref); 10626 10627 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 10628 -- containing build-in-place function calls whose returned object covers 10629 -- interface types. 10630 10631 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then 10632 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); 10633 end if; 10634 10635 -- The remaining case to be handled is packed slices. We can leave 10636 -- packed slices as they are in the following situations: 10637 10638 -- 1. Right or left side of an assignment (we can handle this 10639 -- situation correctly in the assignment statement expansion). 10640 10641 -- 2. Prefix of indexed component (the slide is optimized away in this 10642 -- case, see the start of Expand_N_Slice.) 10643 10644 -- 3. Object renaming declaration, since we want the name of the 10645 -- slice, not the value. 10646 10647 -- 4. Argument to procedure call, since copy-in/copy-out handling may 10648 -- be required, and this is handled in the expansion of call 10649 -- itself. 10650 10651 -- 5. Prefix of an address attribute (this is an error which is caught 10652 -- elsewhere, and the expansion would interfere with generating the 10653 -- error message). 10654 10655 if not Is_Packed (Typ) then 10656 10657 -- Apply transformation for actuals of a function call, where 10658 -- Expand_Actuals is not used. 10659 10660 if Nkind (Parent (N)) = N_Function_Call 10661 and then Is_Possibly_Unaligned_Slice (N) 10662 then 10663 Make_Temporary_For_Slice; 10664 end if; 10665 10666 elsif Nkind (Parent (N)) = N_Assignment_Statement 10667 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement 10668 and then Parent (N) = Name (Parent (Parent (N)))) 10669 then 10670 return; 10671 10672 elsif Nkind (Parent (N)) = N_Indexed_Component 10673 or else Is_Renamed_Object (N) 10674 or else Is_Procedure_Actual (N) 10675 then 10676 return; 10677 10678 elsif Nkind (Parent (N)) = N_Attribute_Reference 10679 and then Attribute_Name (Parent (N)) = Name_Address 10680 then 10681 return; 10682 10683 else 10684 Make_Temporary_For_Slice; 10685 end if; 10686 end Expand_N_Slice; 10687 10688 ------------------------------ 10689 -- Expand_N_Type_Conversion -- 10690 ------------------------------ 10691 10692 procedure Expand_N_Type_Conversion (N : Node_Id) is 10693 Loc : constant Source_Ptr := Sloc (N); 10694 Operand : constant Node_Id := Expression (N); 10695 Target_Type : constant Entity_Id := Etype (N); 10696 Operand_Type : Entity_Id := Etype (Operand); 10697 10698 procedure Handle_Changed_Representation; 10699 -- This is called in the case of record and array type conversions to 10700 -- see if there is a change of representation to be handled. Change of 10701 -- representation is actually handled at the assignment statement level, 10702 -- and what this procedure does is rewrite node N conversion as an 10703 -- assignment to temporary. If there is no change of representation, 10704 -- then the conversion node is unchanged. 10705 10706 procedure Raise_Accessibility_Error; 10707 -- Called when we know that an accessibility check will fail. Rewrites 10708 -- node N to an appropriate raise statement and outputs warning msgs. 10709 -- The Etype of the raise node is set to Target_Type. Note that in this 10710 -- case the rest of the processing should be skipped (i.e. the call to 10711 -- this procedure will be followed by "goto Done"). 10712 10713 procedure Real_Range_Check; 10714 -- Handles generation of range check for real target value 10715 10716 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; 10717 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully 10718 -- evaluates to True. 10719 10720 ----------------------------------- 10721 -- Handle_Changed_Representation -- 10722 ----------------------------------- 10723 10724 procedure Handle_Changed_Representation is 10725 Temp : Entity_Id; 10726 Decl : Node_Id; 10727 Odef : Node_Id; 10728 N_Ix : Node_Id; 10729 Cons : List_Id; 10730 10731 begin 10732 -- Nothing else to do if no change of representation 10733 10734 if Same_Representation (Operand_Type, Target_Type) then 10735 return; 10736 10737 -- The real change of representation work is done by the assignment 10738 -- statement processing. So if this type conversion is appearing as 10739 -- the expression of an assignment statement, nothing needs to be 10740 -- done to the conversion. 10741 10742 elsif Nkind (Parent (N)) = N_Assignment_Statement then 10743 return; 10744 10745 -- Otherwise we need to generate a temporary variable, and do the 10746 -- change of representation assignment into that temporary variable. 10747 -- The conversion is then replaced by a reference to this variable. 10748 10749 else 10750 Cons := No_List; 10751 10752 -- If type is unconstrained we have to add a constraint, copied 10753 -- from the actual value of the left-hand side. 10754 10755 if not Is_Constrained (Target_Type) then 10756 if Has_Discriminants (Operand_Type) then 10757 10758 -- A change of representation can only apply to untagged 10759 -- types. We need to build the constraint that applies to 10760 -- the target type, using the constraints of the operand. 10761 -- The analysis is complicated if there are both inherited 10762 -- discriminants and constrained discriminants. 10763 -- We iterate over the discriminants of the target, and 10764 -- find the discriminant of the same name: 10765 10766 -- a) If there is a corresponding discriminant in the object 10767 -- then the value is a selected component of the operand. 10768 10769 -- b) Otherwise the value of a constrained discriminant is 10770 -- found in the stored constraint of the operand. 10771 10772 declare 10773 Stored : constant Elist_Id := 10774 Stored_Constraint (Operand_Type); 10775 10776 Elmt : Elmt_Id; 10777 10778 Disc_O : Entity_Id; 10779 -- Discriminant of the operand type. Its value in the 10780 -- object is captured in a selected component. 10781 10782 Disc_S : Entity_Id; 10783 -- Stored discriminant of the operand. If present, it 10784 -- corresponds to a constrained discriminant of the 10785 -- parent type. 10786 10787 Disc_T : Entity_Id; 10788 -- Discriminant of the target type 10789 10790 begin 10791 Disc_T := First_Discriminant (Target_Type); 10792 Disc_O := First_Discriminant (Operand_Type); 10793 Disc_S := First_Stored_Discriminant (Operand_Type); 10794 10795 if Present (Stored) then 10796 Elmt := First_Elmt (Stored); 10797 else 10798 Elmt := No_Elmt; -- init to avoid warning 10799 end if; 10800 10801 Cons := New_List; 10802 while Present (Disc_T) loop 10803 if Present (Disc_O) 10804 and then Chars (Disc_T) = Chars (Disc_O) 10805 then 10806 Append_To (Cons, 10807 Make_Selected_Component (Loc, 10808 Prefix => 10809 Duplicate_Subexpr_Move_Checks (Operand), 10810 Selector_Name => 10811 Make_Identifier (Loc, Chars (Disc_O)))); 10812 Next_Discriminant (Disc_O); 10813 10814 elsif Present (Disc_S) then 10815 Append_To (Cons, New_Copy_Tree (Node (Elmt))); 10816 Next_Elmt (Elmt); 10817 end if; 10818 10819 Next_Discriminant (Disc_T); 10820 end loop; 10821 end; 10822 10823 elsif Is_Array_Type (Operand_Type) then 10824 N_Ix := First_Index (Target_Type); 10825 Cons := New_List; 10826 10827 for J in 1 .. Number_Dimensions (Operand_Type) loop 10828 10829 -- We convert the bounds explicitly. We use an unchecked 10830 -- conversion because bounds checks are done elsewhere. 10831 10832 Append_To (Cons, 10833 Make_Range (Loc, 10834 Low_Bound => 10835 Unchecked_Convert_To (Etype (N_Ix), 10836 Make_Attribute_Reference (Loc, 10837 Prefix => 10838 Duplicate_Subexpr_No_Checks 10839 (Operand, Name_Req => True), 10840 Attribute_Name => Name_First, 10841 Expressions => New_List ( 10842 Make_Integer_Literal (Loc, J)))), 10843 10844 High_Bound => 10845 Unchecked_Convert_To (Etype (N_Ix), 10846 Make_Attribute_Reference (Loc, 10847 Prefix => 10848 Duplicate_Subexpr_No_Checks 10849 (Operand, Name_Req => True), 10850 Attribute_Name => Name_Last, 10851 Expressions => New_List ( 10852 Make_Integer_Literal (Loc, J)))))); 10853 10854 Next_Index (N_Ix); 10855 end loop; 10856 end if; 10857 end if; 10858 10859 Odef := New_Occurrence_Of (Target_Type, Loc); 10860 10861 if Present (Cons) then 10862 Odef := 10863 Make_Subtype_Indication (Loc, 10864 Subtype_Mark => Odef, 10865 Constraint => 10866 Make_Index_Or_Discriminant_Constraint (Loc, 10867 Constraints => Cons)); 10868 end if; 10869 10870 Temp := Make_Temporary (Loc, 'C'); 10871 Decl := 10872 Make_Object_Declaration (Loc, 10873 Defining_Identifier => Temp, 10874 Object_Definition => Odef); 10875 10876 Set_No_Initialization (Decl, True); 10877 10878 -- Insert required actions. It is essential to suppress checks 10879 -- since we have suppressed default initialization, which means 10880 -- that the variable we create may have no discriminants. 10881 10882 Insert_Actions (N, 10883 New_List ( 10884 Decl, 10885 Make_Assignment_Statement (Loc, 10886 Name => New_Occurrence_Of (Temp, Loc), 10887 Expression => Relocate_Node (N))), 10888 Suppress => All_Checks); 10889 10890 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 10891 return; 10892 end if; 10893 end Handle_Changed_Representation; 10894 10895 ------------------------------- 10896 -- Raise_Accessibility_Error -- 10897 ------------------------------- 10898 10899 procedure Raise_Accessibility_Error is 10900 begin 10901 Error_Msg_Warn := SPARK_Mode /= On; 10902 Rewrite (N, 10903 Make_Raise_Program_Error (Sloc (N), 10904 Reason => PE_Accessibility_Check_Failed)); 10905 Set_Etype (N, Target_Type); 10906 10907 Error_Msg_N ("<<accessibility check failure", N); 10908 Error_Msg_NE ("\<<& [", N, Standard_Program_Error); 10909 end Raise_Accessibility_Error; 10910 10911 ---------------------- 10912 -- Real_Range_Check -- 10913 ---------------------- 10914 10915 -- Case of conversions to floating-point or fixed-point. If range checks 10916 -- are enabled and the target type has a range constraint, we convert: 10917 10918 -- typ (x) 10919 10920 -- to 10921 10922 -- Tnn : typ'Base := typ'Base (x); 10923 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] 10924 -- Tnn 10925 10926 -- This is necessary when there is a conversion of integer to float or 10927 -- to fixed-point to ensure that the correct checks are made. It is not 10928 -- necessary for float to float where it is enough to simply set the 10929 -- Do_Range_Check flag. 10930 10931 procedure Real_Range_Check is 10932 Btyp : constant Entity_Id := Base_Type (Target_Type); 10933 Lo : constant Node_Id := Type_Low_Bound (Target_Type); 10934 Hi : constant Node_Id := Type_High_Bound (Target_Type); 10935 Xtyp : constant Entity_Id := Etype (Operand); 10936 Conv : Node_Id; 10937 Tnn : Entity_Id; 10938 10939 begin 10940 -- Nothing to do if conversion was rewritten 10941 10942 if Nkind (N) /= N_Type_Conversion then 10943 return; 10944 end if; 10945 10946 -- Nothing to do if range checks suppressed, or target has the same 10947 -- range as the base type (or is the base type). 10948 10949 if Range_Checks_Suppressed (Target_Type) 10950 or else (Lo = Type_Low_Bound (Btyp) 10951 and then 10952 Hi = Type_High_Bound (Btyp)) 10953 then 10954 return; 10955 end if; 10956 10957 -- Nothing to do if expression is an entity on which checks have been 10958 -- suppressed. 10959 10960 if Is_Entity_Name (Operand) 10961 and then Range_Checks_Suppressed (Entity (Operand)) 10962 then 10963 return; 10964 end if; 10965 10966 -- Nothing to do if bounds are all static and we can tell that the 10967 -- expression is within the bounds of the target. Note that if the 10968 -- operand is of an unconstrained floating-point type, then we do 10969 -- not trust it to be in range (might be infinite) 10970 10971 declare 10972 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); 10973 S_Hi : constant Node_Id := Type_High_Bound (Xtyp); 10974 10975 begin 10976 if (not Is_Floating_Point_Type (Xtyp) 10977 or else Is_Constrained (Xtyp)) 10978 and then Compile_Time_Known_Value (S_Lo) 10979 and then Compile_Time_Known_Value (S_Hi) 10980 and then Compile_Time_Known_Value (Hi) 10981 and then Compile_Time_Known_Value (Lo) 10982 then 10983 declare 10984 D_Lov : constant Ureal := Expr_Value_R (Lo); 10985 D_Hiv : constant Ureal := Expr_Value_R (Hi); 10986 S_Lov : Ureal; 10987 S_Hiv : Ureal; 10988 10989 begin 10990 if Is_Real_Type (Xtyp) then 10991 S_Lov := Expr_Value_R (S_Lo); 10992 S_Hiv := Expr_Value_R (S_Hi); 10993 else 10994 S_Lov := UR_From_Uint (Expr_Value (S_Lo)); 10995 S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); 10996 end if; 10997 10998 if D_Hiv > D_Lov 10999 and then S_Lov >= D_Lov 11000 and then S_Hiv <= D_Hiv 11001 then 11002 -- Unset the range check flag on the current value of 11003 -- Expression (N), since the captured Operand may have 11004 -- been rewritten (such as for the case of a conversion 11005 -- to a fixed-point type). 11006 11007 Set_Do_Range_Check (Expression (N), False); 11008 11009 return; 11010 end if; 11011 end; 11012 end if; 11013 end; 11014 11015 -- For float to float conversions, we are done 11016 11017 if Is_Floating_Point_Type (Xtyp) 11018 and then 11019 Is_Floating_Point_Type (Btyp) 11020 then 11021 return; 11022 end if; 11023 11024 -- Otherwise rewrite the conversion as described above 11025 11026 Conv := Relocate_Node (N); 11027 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); 11028 Set_Etype (Conv, Btyp); 11029 11030 -- Enable overflow except for case of integer to float conversions, 11031 -- where it is never required, since we can never have overflow in 11032 -- this case. 11033 11034 if not Is_Integer_Type (Etype (Operand)) then 11035 Enable_Overflow_Check (Conv); 11036 end if; 11037 11038 Tnn := Make_Temporary (Loc, 'T', Conv); 11039 11040 Insert_Actions (N, New_List ( 11041 Make_Object_Declaration (Loc, 11042 Defining_Identifier => Tnn, 11043 Object_Definition => New_Occurrence_Of (Btyp, Loc), 11044 Constant_Present => True, 11045 Expression => Conv), 11046 11047 Make_Raise_Constraint_Error (Loc, 11048 Condition => 11049 Make_Or_Else (Loc, 11050 Left_Opnd => 11051 Make_Op_Lt (Loc, 11052 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 11053 Right_Opnd => 11054 Make_Attribute_Reference (Loc, 11055 Attribute_Name => Name_First, 11056 Prefix => 11057 New_Occurrence_Of (Target_Type, Loc))), 11058 11059 Right_Opnd => 11060 Make_Op_Gt (Loc, 11061 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 11062 Right_Opnd => 11063 Make_Attribute_Reference (Loc, 11064 Attribute_Name => Name_Last, 11065 Prefix => 11066 New_Occurrence_Of (Target_Type, Loc)))), 11067 Reason => CE_Range_Check_Failed))); 11068 11069 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 11070 Analyze_And_Resolve (N, Btyp); 11071 end Real_Range_Check; 11072 11073 ----------------------------- 11074 -- Has_Extra_Accessibility -- 11075 ----------------------------- 11076 11077 -- Returns true for a formal of an anonymous access type or for 11078 -- an Ada 2012-style stand-alone object of an anonymous access type. 11079 11080 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is 11081 begin 11082 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then 11083 return Present (Effective_Extra_Accessibility (Id)); 11084 else 11085 return False; 11086 end if; 11087 end Has_Extra_Accessibility; 11088 11089 -- Start of processing for Expand_N_Type_Conversion 11090 11091 begin 11092 -- First remove check marks put by the semantic analysis on the type 11093 -- conversion between array types. We need these checks, and they will 11094 -- be generated by this expansion routine, but we do not depend on these 11095 -- flags being set, and since we do intend to expand the checks in the 11096 -- front end, we don't want them on the tree passed to the back end. 11097 11098 if Is_Array_Type (Target_Type) then 11099 if Is_Constrained (Target_Type) then 11100 Set_Do_Length_Check (N, False); 11101 else 11102 Set_Do_Range_Check (Operand, False); 11103 end if; 11104 end if; 11105 11106 -- Nothing at all to do if conversion is to the identical type so remove 11107 -- the conversion completely, it is useless, except that it may carry 11108 -- an Assignment_OK attribute, which must be propagated to the operand. 11109 11110 if Operand_Type = Target_Type then 11111 if Assignment_OK (N) then 11112 Set_Assignment_OK (Operand); 11113 end if; 11114 11115 Rewrite (N, Relocate_Node (Operand)); 11116 goto Done; 11117 end if; 11118 11119 -- Nothing to do if this is the second argument of read. This is a 11120 -- "backwards" conversion that will be handled by the specialized code 11121 -- in attribute processing. 11122 11123 if Nkind (Parent (N)) = N_Attribute_Reference 11124 and then Attribute_Name (Parent (N)) = Name_Read 11125 and then Next (First (Expressions (Parent (N)))) = N 11126 then 11127 goto Done; 11128 end if; 11129 11130 -- Check for case of converting to a type that has an invariant 11131 -- associated with it. This requires an invariant check. We insert 11132 -- a call: 11133 11134 -- invariant_check (typ (expr)) 11135 11136 -- in the code, after removing side effects from the expression. 11137 -- This is clearer than replacing the conversion into an expression 11138 -- with actions, because the context may impose additional actions 11139 -- (tag checks, membership tests, etc.) that conflict with this 11140 -- rewriting (used previously). 11141 11142 -- Note: the Comes_From_Source check, and then the resetting of this 11143 -- flag prevents what would otherwise be an infinite recursion. 11144 11145 if Has_Invariants (Target_Type) 11146 and then Present (Invariant_Procedure (Target_Type)) 11147 and then Comes_From_Source (N) 11148 then 11149 Set_Comes_From_Source (N, False); 11150 Remove_Side_Effects (N); 11151 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N))); 11152 goto Done; 11153 end if; 11154 11155 -- Here if we may need to expand conversion 11156 11157 -- If the operand of the type conversion is an arithmetic operation on 11158 -- signed integers, and the based type of the signed integer type in 11159 -- question is smaller than Standard.Integer, we promote both of the 11160 -- operands to type Integer. 11161 11162 -- For example, if we have 11163 11164 -- target-type (opnd1 + opnd2) 11165 11166 -- and opnd1 and opnd2 are of type short integer, then we rewrite 11167 -- this as: 11168 11169 -- target-type (integer(opnd1) + integer(opnd2)) 11170 11171 -- We do this because we are always allowed to compute in a larger type 11172 -- if we do the right thing with the result, and in this case we are 11173 -- going to do a conversion which will do an appropriate check to make 11174 -- sure that things are in range of the target type in any case. This 11175 -- avoids some unnecessary intermediate overflows. 11176 11177 -- We might consider a similar transformation in the case where the 11178 -- target is a real type or a 64-bit integer type, and the operand 11179 -- is an arithmetic operation using a 32-bit integer type. However, 11180 -- we do not bother with this case, because it could cause significant 11181 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be 11182 -- much cheaper, but we don't want different behavior on 32-bit and 11183 -- 64-bit machines. Note that the exclusion of the 64-bit case also 11184 -- handles the configurable run-time cases where 64-bit arithmetic 11185 -- may simply be unavailable. 11186 11187 -- Note: this circuit is partially redundant with respect to the circuit 11188 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in 11189 -- the processing here. Also we still need the Checks circuit, since we 11190 -- have to be sure not to generate junk overflow checks in the first 11191 -- place, since it would be trick to remove them here. 11192 11193 if Integer_Promotion_Possible (N) then 11194 11195 -- All conditions met, go ahead with transformation 11196 11197 declare 11198 Opnd : Node_Id; 11199 L, R : Node_Id; 11200 11201 begin 11202 R := 11203 Make_Type_Conversion (Loc, 11204 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 11205 Expression => Relocate_Node (Right_Opnd (Operand))); 11206 11207 Opnd := New_Op_Node (Nkind (Operand), Loc); 11208 Set_Right_Opnd (Opnd, R); 11209 11210 if Nkind (Operand) in N_Binary_Op then 11211 L := 11212 Make_Type_Conversion (Loc, 11213 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 11214 Expression => Relocate_Node (Left_Opnd (Operand))); 11215 11216 Set_Left_Opnd (Opnd, L); 11217 end if; 11218 11219 Rewrite (N, 11220 Make_Type_Conversion (Loc, 11221 Subtype_Mark => Relocate_Node (Subtype_Mark (N)), 11222 Expression => Opnd)); 11223 11224 Analyze_And_Resolve (N, Target_Type); 11225 goto Done; 11226 end; 11227 end if; 11228 11229 -- Do validity check if validity checking operands 11230 11231 if Validity_Checks_On and Validity_Check_Operands then 11232 Ensure_Valid (Operand); 11233 end if; 11234 11235 -- Special case of converting from non-standard boolean type 11236 11237 if Is_Boolean_Type (Operand_Type) 11238 and then (Nonzero_Is_True (Operand_Type)) 11239 then 11240 Adjust_Condition (Operand); 11241 Set_Etype (Operand, Standard_Boolean); 11242 Operand_Type := Standard_Boolean; 11243 end if; 11244 11245 -- Case of converting to an access type 11246 11247 if Is_Access_Type (Target_Type) then 11248 11249 -- If this type conversion was internally generated by the front end 11250 -- to displace the pointer to the object to reference an interface 11251 -- type and the original node was an Unrestricted_Access attribute, 11252 -- then skip applying accessibility checks (because, according to the 11253 -- GNAT Reference Manual, this attribute is similar to 'Access except 11254 -- that all accessibility and aliased view checks are omitted). 11255 11256 if not Comes_From_Source (N) 11257 and then Is_Interface (Designated_Type (Target_Type)) 11258 and then Nkind (Original_Node (N)) = N_Attribute_Reference 11259 and then Attribute_Name (Original_Node (N)) = 11260 Name_Unrestricted_Access 11261 then 11262 null; 11263 11264 -- Apply an accessibility check when the conversion operand is an 11265 -- access parameter (or a renaming thereof), unless conversion was 11266 -- expanded from an Unchecked_ or Unrestricted_Access attribute, 11267 -- or for the actual of a class-wide interface parameter. Note that 11268 -- other checks may still need to be applied below (such as tagged 11269 -- type checks). 11270 11271 elsif Is_Entity_Name (Operand) 11272 and then Has_Extra_Accessibility (Entity (Operand)) 11273 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type 11274 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference 11275 or else Attribute_Name (Original_Node (N)) = Name_Access) 11276 then 11277 if not Comes_From_Source (N) 11278 and then Nkind_In (Parent (N), N_Function_Call, 11279 N_Procedure_Call_Statement) 11280 and then Is_Interface (Designated_Type (Target_Type)) 11281 and then Is_Class_Wide_Type (Designated_Type (Target_Type)) 11282 then 11283 null; 11284 11285 else 11286 Apply_Accessibility_Check 11287 (Operand, Target_Type, Insert_Node => Operand); 11288 end if; 11289 11290 -- If the level of the operand type is statically deeper than the 11291 -- level of the target type, then force Program_Error. Note that this 11292 -- can only occur for cases where the attribute is within the body of 11293 -- an instantiation, otherwise the conversion will already have been 11294 -- rejected as illegal. 11295 11296 -- Note: warnings are issued by the analyzer for the instance cases 11297 11298 elsif In_Instance_Body 11299 11300 -- The case where the target type is an anonymous access type of 11301 -- a discriminant is excluded, because the level of such a type 11302 -- depends on the context and currently the level returned for such 11303 -- types is zero, resulting in warnings about about check failures 11304 -- in certain legal cases involving class-wide interfaces as the 11305 -- designated type (some cases, such as return statements, are 11306 -- checked at run time, but not clear if these are handled right 11307 -- in general, see 3.10.2(12/2-12.5/3) ???). 11308 11309 and then 11310 not (Ekind (Target_Type) = E_Anonymous_Access_Type 11311 and then Present (Associated_Node_For_Itype (Target_Type)) 11312 and then Nkind (Associated_Node_For_Itype (Target_Type)) = 11313 N_Discriminant_Specification) 11314 and then 11315 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) 11316 then 11317 Raise_Accessibility_Error; 11318 goto Done; 11319 11320 -- When the operand is a selected access discriminant the check needs 11321 -- to be made against the level of the object denoted by the prefix 11322 -- of the selected name. Force Program_Error for this case as well 11323 -- (this accessibility violation can only happen if within the body 11324 -- of an instantiation). 11325 11326 elsif In_Instance_Body 11327 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 11328 and then Nkind (Operand) = N_Selected_Component 11329 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant 11330 and then Object_Access_Level (Operand) > 11331 Type_Access_Level (Target_Type) 11332 then 11333 Raise_Accessibility_Error; 11334 goto Done; 11335 end if; 11336 end if; 11337 11338 -- Case of conversions of tagged types and access to tagged types 11339 11340 -- When needed, that is to say when the expression is class-wide, Add 11341 -- runtime a tag check for (strict) downward conversion by using the 11342 -- membership test, generating: 11343 11344 -- [constraint_error when Operand not in Target_Type'Class] 11345 11346 -- or in the access type case 11347 11348 -- [constraint_error 11349 -- when Operand /= null 11350 -- and then Operand.all not in 11351 -- Designated_Type (Target_Type)'Class] 11352 11353 if (Is_Access_Type (Target_Type) 11354 and then Is_Tagged_Type (Designated_Type (Target_Type))) 11355 or else Is_Tagged_Type (Target_Type) 11356 then 11357 -- Do not do any expansion in the access type case if the parent is a 11358 -- renaming, since this is an error situation which will be caught by 11359 -- Sem_Ch8, and the expansion can interfere with this error check. 11360 11361 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then 11362 goto Done; 11363 end if; 11364 11365 -- Otherwise, proceed with processing tagged conversion 11366 11367 Tagged_Conversion : declare 11368 Actual_Op_Typ : Entity_Id; 11369 Actual_Targ_Typ : Entity_Id; 11370 Make_Conversion : Boolean := False; 11371 Root_Op_Typ : Entity_Id; 11372 11373 procedure Make_Tag_Check (Targ_Typ : Entity_Id); 11374 -- Create a membership check to test whether Operand is a member 11375 -- of Targ_Typ. If the original Target_Type is an access, include 11376 -- a test for null value. The check is inserted at N. 11377 11378 -------------------- 11379 -- Make_Tag_Check -- 11380 -------------------- 11381 11382 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is 11383 Cond : Node_Id; 11384 11385 begin 11386 -- Generate: 11387 -- [Constraint_Error 11388 -- when Operand /= null 11389 -- and then Operand.all not in Targ_Typ] 11390 11391 if Is_Access_Type (Target_Type) then 11392 Cond := 11393 Make_And_Then (Loc, 11394 Left_Opnd => 11395 Make_Op_Ne (Loc, 11396 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 11397 Right_Opnd => Make_Null (Loc)), 11398 11399 Right_Opnd => 11400 Make_Not_In (Loc, 11401 Left_Opnd => 11402 Make_Explicit_Dereference (Loc, 11403 Prefix => Duplicate_Subexpr_No_Checks (Operand)), 11404 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc))); 11405 11406 -- Generate: 11407 -- [Constraint_Error when Operand not in Targ_Typ] 11408 11409 else 11410 Cond := 11411 Make_Not_In (Loc, 11412 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 11413 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)); 11414 end if; 11415 11416 Insert_Action (N, 11417 Make_Raise_Constraint_Error (Loc, 11418 Condition => Cond, 11419 Reason => CE_Tag_Check_Failed), 11420 Suppress => All_Checks); 11421 end Make_Tag_Check; 11422 11423 -- Start of processing for Tagged_Conversion 11424 11425 begin 11426 -- Handle entities from the limited view 11427 11428 if Is_Access_Type (Operand_Type) then 11429 Actual_Op_Typ := 11430 Available_View (Designated_Type (Operand_Type)); 11431 else 11432 Actual_Op_Typ := Operand_Type; 11433 end if; 11434 11435 if Is_Access_Type (Target_Type) then 11436 Actual_Targ_Typ := 11437 Available_View (Designated_Type (Target_Type)); 11438 else 11439 Actual_Targ_Typ := Target_Type; 11440 end if; 11441 11442 Root_Op_Typ := Root_Type (Actual_Op_Typ); 11443 11444 -- Ada 2005 (AI-251): Handle interface type conversion 11445 11446 if Is_Interface (Actual_Op_Typ) 11447 or else 11448 Is_Interface (Actual_Targ_Typ) 11449 then 11450 Expand_Interface_Conversion (N); 11451 goto Done; 11452 end if; 11453 11454 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then 11455 11456 -- Create a runtime tag check for a downward class-wide type 11457 -- conversion. 11458 11459 if Is_Class_Wide_Type (Actual_Op_Typ) 11460 and then Actual_Op_Typ /= Actual_Targ_Typ 11461 and then Root_Op_Typ /= Actual_Targ_Typ 11462 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ, 11463 Use_Full_View => True) 11464 then 11465 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); 11466 Make_Conversion := True; 11467 end if; 11468 11469 -- AI05-0073: If the result subtype of the function is defined 11470 -- by an access_definition designating a specific tagged type 11471 -- T, a check is made that the result value is null or the tag 11472 -- of the object designated by the result value identifies T. 11473 -- Constraint_Error is raised if this check fails. 11474 11475 if Nkind (Parent (N)) = N_Simple_Return_Statement then 11476 declare 11477 Func : Entity_Id; 11478 Func_Typ : Entity_Id; 11479 11480 begin 11481 -- Climb scope stack looking for the enclosing function 11482 11483 Func := Current_Scope; 11484 while Present (Func) 11485 and then Ekind (Func) /= E_Function 11486 loop 11487 Func := Scope (Func); 11488 end loop; 11489 11490 -- The function's return subtype must be defined using 11491 -- an access definition. 11492 11493 if Nkind (Result_Definition (Parent (Func))) = 11494 N_Access_Definition 11495 then 11496 Func_Typ := Directly_Designated_Type (Etype (Func)); 11497 11498 -- The return subtype denotes a specific tagged type, 11499 -- in other words, a non class-wide type. 11500 11501 if Is_Tagged_Type (Func_Typ) 11502 and then not Is_Class_Wide_Type (Func_Typ) 11503 then 11504 Make_Tag_Check (Actual_Targ_Typ); 11505 Make_Conversion := True; 11506 end if; 11507 end if; 11508 end; 11509 end if; 11510 11511 -- We have generated a tag check for either a class-wide type 11512 -- conversion or for AI05-0073. 11513 11514 if Make_Conversion then 11515 declare 11516 Conv : Node_Id; 11517 begin 11518 Conv := 11519 Make_Unchecked_Type_Conversion (Loc, 11520 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 11521 Expression => Relocate_Node (Expression (N))); 11522 Rewrite (N, Conv); 11523 Analyze_And_Resolve (N, Target_Type); 11524 end; 11525 end if; 11526 end if; 11527 end Tagged_Conversion; 11528 11529 -- Case of other access type conversions 11530 11531 elsif Is_Access_Type (Target_Type) then 11532 Apply_Constraint_Check (Operand, Target_Type); 11533 11534 -- Case of conversions from a fixed-point type 11535 11536 -- These conversions require special expansion and processing, found in 11537 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, 11538 -- since from a semantic point of view, these are simple integer 11539 -- conversions, which do not need further processing. 11540 11541 elsif Is_Fixed_Point_Type (Operand_Type) 11542 and then not Conversion_OK (N) 11543 then 11544 -- We should never see universal fixed at this case, since the 11545 -- expansion of the constituent divide or multiply should have 11546 -- eliminated the explicit mention of universal fixed. 11547 11548 pragma Assert (Operand_Type /= Universal_Fixed); 11549 11550 -- Check for special case of the conversion to universal real that 11551 -- occurs as a result of the use of a round attribute. In this case, 11552 -- the real type for the conversion is taken from the target type of 11553 -- the Round attribute and the result must be marked as rounded. 11554 11555 if Target_Type = Universal_Real 11556 and then Nkind (Parent (N)) = N_Attribute_Reference 11557 and then Attribute_Name (Parent (N)) = Name_Round 11558 then 11559 Set_Rounded_Result (N); 11560 Set_Etype (N, Etype (Parent (N))); 11561 end if; 11562 11563 -- Otherwise do correct fixed-conversion, but skip these if the 11564 -- Conversion_OK flag is set, because from a semantic point of view 11565 -- these are simple integer conversions needing no further processing 11566 -- (the backend will simply treat them as integers). 11567 11568 if not Conversion_OK (N) then 11569 if Is_Fixed_Point_Type (Etype (N)) then 11570 Expand_Convert_Fixed_To_Fixed (N); 11571 Real_Range_Check; 11572 11573 elsif Is_Integer_Type (Etype (N)) then 11574 Expand_Convert_Fixed_To_Integer (N); 11575 11576 else 11577 pragma Assert (Is_Floating_Point_Type (Etype (N))); 11578 Expand_Convert_Fixed_To_Float (N); 11579 Real_Range_Check; 11580 end if; 11581 end if; 11582 11583 -- Case of conversions to a fixed-point type 11584 11585 -- These conversions require special expansion and processing, found in 11586 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, 11587 -- since from a semantic point of view, these are simple integer 11588 -- conversions, which do not need further processing. 11589 11590 elsif Is_Fixed_Point_Type (Target_Type) 11591 and then not Conversion_OK (N) 11592 then 11593 if Is_Integer_Type (Operand_Type) then 11594 Expand_Convert_Integer_To_Fixed (N); 11595 Real_Range_Check; 11596 else 11597 pragma Assert (Is_Floating_Point_Type (Operand_Type)); 11598 Expand_Convert_Float_To_Fixed (N); 11599 Real_Range_Check; 11600 end if; 11601 11602 -- Case of float-to-integer conversions 11603 11604 -- We also handle float-to-fixed conversions with Conversion_OK set 11605 -- since semantically the fixed-point target is treated as though it 11606 -- were an integer in such cases. 11607 11608 elsif Is_Floating_Point_Type (Operand_Type) 11609 and then 11610 (Is_Integer_Type (Target_Type) 11611 or else 11612 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N))) 11613 then 11614 -- One more check here, gcc is still not able to do conversions of 11615 -- this type with proper overflow checking, and so gigi is doing an 11616 -- approximation of what is required by doing floating-point compares 11617 -- with the end-point. But that can lose precision in some cases, and 11618 -- give a wrong result. Converting the operand to Universal_Real is 11619 -- helpful, but still does not catch all cases with 64-bit integers 11620 -- on targets with only 64-bit floats. 11621 11622 -- The above comment seems obsoleted by Apply_Float_Conversion_Check 11623 -- Can this code be removed ??? 11624 11625 if Do_Range_Check (Operand) then 11626 Rewrite (Operand, 11627 Make_Type_Conversion (Loc, 11628 Subtype_Mark => 11629 New_Occurrence_Of (Universal_Real, Loc), 11630 Expression => 11631 Relocate_Node (Operand))); 11632 11633 Set_Etype (Operand, Universal_Real); 11634 Enable_Range_Check (Operand); 11635 Set_Do_Range_Check (Expression (Operand), False); 11636 end if; 11637 11638 -- Case of array conversions 11639 11640 -- Expansion of array conversions, add required length/range checks but 11641 -- only do this if there is no change of representation. For handling of 11642 -- this case, see Handle_Changed_Representation. 11643 11644 elsif Is_Array_Type (Target_Type) then 11645 if Is_Constrained (Target_Type) then 11646 Apply_Length_Check (Operand, Target_Type); 11647 else 11648 Apply_Range_Check (Operand, Target_Type); 11649 end if; 11650 11651 Handle_Changed_Representation; 11652 11653 -- Case of conversions of discriminated types 11654 11655 -- Add required discriminant checks if target is constrained. Again this 11656 -- change is skipped if we have a change of representation. 11657 11658 elsif Has_Discriminants (Target_Type) 11659 and then Is_Constrained (Target_Type) 11660 then 11661 Apply_Discriminant_Check (Operand, Target_Type); 11662 Handle_Changed_Representation; 11663 11664 -- Case of all other record conversions. The only processing required 11665 -- is to check for a change of representation requiring the special 11666 -- assignment processing. 11667 11668 elsif Is_Record_Type (Target_Type) then 11669 11670 -- Ada 2005 (AI-216): Program_Error is raised when converting from 11671 -- a derived Unchecked_Union type to an unconstrained type that is 11672 -- not Unchecked_Union if the operand lacks inferable discriminants. 11673 11674 if Is_Derived_Type (Operand_Type) 11675 and then Is_Unchecked_Union (Base_Type (Operand_Type)) 11676 and then not Is_Constrained (Target_Type) 11677 and then not Is_Unchecked_Union (Base_Type (Target_Type)) 11678 and then not Has_Inferable_Discriminants (Operand) 11679 then 11680 -- To prevent Gigi from generating illegal code, we generate a 11681 -- Program_Error node, but we give it the target type of the 11682 -- conversion (is this requirement documented somewhere ???) 11683 11684 declare 11685 PE : constant Node_Id := Make_Raise_Program_Error (Loc, 11686 Reason => PE_Unchecked_Union_Restriction); 11687 11688 begin 11689 Set_Etype (PE, Target_Type); 11690 Rewrite (N, PE); 11691 11692 end; 11693 else 11694 Handle_Changed_Representation; 11695 end if; 11696 11697 -- Case of conversions of enumeration types 11698 11699 elsif Is_Enumeration_Type (Target_Type) then 11700 11701 -- Special processing is required if there is a change of 11702 -- representation (from enumeration representation clauses). 11703 11704 if not Same_Representation (Target_Type, Operand_Type) then 11705 11706 -- Convert: x(y) to x'val (ytyp'val (y)) 11707 11708 Rewrite (N, 11709 Make_Attribute_Reference (Loc, 11710 Prefix => New_Occurrence_Of (Target_Type, Loc), 11711 Attribute_Name => Name_Val, 11712 Expressions => New_List ( 11713 Make_Attribute_Reference (Loc, 11714 Prefix => New_Occurrence_Of (Operand_Type, Loc), 11715 Attribute_Name => Name_Pos, 11716 Expressions => New_List (Operand))))); 11717 11718 Analyze_And_Resolve (N, Target_Type); 11719 end if; 11720 11721 -- Case of conversions to floating-point 11722 11723 elsif Is_Floating_Point_Type (Target_Type) then 11724 Real_Range_Check; 11725 end if; 11726 11727 -- At this stage, either the conversion node has been transformed into 11728 -- some other equivalent expression, or left as a conversion that can be 11729 -- handled by Gigi, in the following cases: 11730 11731 -- Conversions with no change of representation or type 11732 11733 -- Numeric conversions involving integer, floating- and fixed-point 11734 -- values. Fixed-point values are allowed only if Conversion_OK is 11735 -- set, i.e. if the fixed-point values are to be treated as integers. 11736 11737 -- No other conversions should be passed to Gigi 11738 11739 -- Check: are these rules stated in sinfo??? if so, why restate here??? 11740 11741 -- The only remaining step is to generate a range check if we still have 11742 -- a type conversion at this stage and Do_Range_Check is set. For now we 11743 -- do this only for conversions of discrete types and for float-to-float 11744 -- conversions. 11745 11746 if Nkind (N) = N_Type_Conversion then 11747 11748 -- For now we only support floating-point cases where both source 11749 -- and target are floating-point types. Conversions where the source 11750 -- and target involve integer or fixed-point types are still TBD, 11751 -- though not clear whether those can even happen at this point, due 11752 -- to transformations above. ??? 11753 11754 if Is_Floating_Point_Type (Etype (N)) 11755 and then Is_Floating_Point_Type (Etype (Expression (N))) 11756 then 11757 if Do_Range_Check (Expression (N)) 11758 and then Is_Floating_Point_Type (Target_Type) 11759 then 11760 Generate_Range_Check 11761 (Expression (N), Target_Type, CE_Range_Check_Failed); 11762 end if; 11763 11764 -- Discrete-to-discrete conversions 11765 11766 elsif Is_Discrete_Type (Etype (N)) then 11767 declare 11768 Expr : constant Node_Id := Expression (N); 11769 Ftyp : Entity_Id; 11770 Ityp : Entity_Id; 11771 11772 begin 11773 if Do_Range_Check (Expr) 11774 and then Is_Discrete_Type (Etype (Expr)) 11775 then 11776 Set_Do_Range_Check (Expr, False); 11777 11778 -- Before we do a range check, we have to deal with treating 11779 -- a fixed-point operand as an integer. The way we do this 11780 -- is simply to do an unchecked conversion to an appropriate 11781 -- integer type large enough to hold the result. 11782 11783 -- This code is not active yet, because we are only dealing 11784 -- with discrete types so far ??? 11785 11786 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer 11787 and then Treat_Fixed_As_Integer (Expr) 11788 then 11789 Ftyp := Base_Type (Etype (Expr)); 11790 11791 if Esize (Ftyp) >= Esize (Standard_Integer) then 11792 Ityp := Standard_Long_Long_Integer; 11793 else 11794 Ityp := Standard_Integer; 11795 end if; 11796 11797 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); 11798 end if; 11799 11800 -- Reset overflow flag, since the range check will include 11801 -- dealing with possible overflow, and generate the check. 11802 -- If Address is either a source type or target type, 11803 -- suppress range check to avoid typing anomalies when 11804 -- it is a visible integer type. 11805 11806 Set_Do_Overflow_Check (N, False); 11807 11808 if not Is_Descendant_Of_Address (Etype (Expr)) 11809 and then not Is_Descendant_Of_Address (Target_Type) 11810 then 11811 Generate_Range_Check 11812 (Expr, Target_Type, CE_Range_Check_Failed); 11813 end if; 11814 end if; 11815 end; 11816 end if; 11817 end if; 11818 11819 -- Here at end of processing 11820 11821 <<Done>> 11822 -- Apply predicate check if required. Note that we can't just call 11823 -- Apply_Predicate_Check here, because the type looks right after 11824 -- the conversion and it would omit the check. The Comes_From_Source 11825 -- guard is necessary to prevent infinite recursions when we generate 11826 -- internal conversions for the purpose of checking predicates. 11827 11828 if Present (Predicate_Function (Target_Type)) 11829 and then not Predicates_Ignored (Target_Type) 11830 and then Target_Type /= Operand_Type 11831 and then Comes_From_Source (N) 11832 then 11833 declare 11834 New_Expr : constant Node_Id := Duplicate_Subexpr (N); 11835 11836 begin 11837 -- Avoid infinite recursion on the subsequent expansion of 11838 -- of the copy of the original type conversion. 11839 11840 Set_Comes_From_Source (New_Expr, False); 11841 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr)); 11842 end; 11843 end if; 11844 end Expand_N_Type_Conversion; 11845 11846 ----------------------------------- 11847 -- Expand_N_Unchecked_Expression -- 11848 ----------------------------------- 11849 11850 -- Remove the unchecked expression node from the tree. Its job was simply 11851 -- to make sure that its constituent expression was handled with checks 11852 -- off, and now that that is done, we can remove it from the tree, and 11853 -- indeed must, since Gigi does not expect to see these nodes. 11854 11855 procedure Expand_N_Unchecked_Expression (N : Node_Id) is 11856 Exp : constant Node_Id := Expression (N); 11857 begin 11858 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); 11859 Rewrite (N, Exp); 11860 end Expand_N_Unchecked_Expression; 11861 11862 ---------------------------------------- 11863 -- Expand_N_Unchecked_Type_Conversion -- 11864 ---------------------------------------- 11865 11866 -- If this cannot be handled by Gigi and we haven't already made a 11867 -- temporary for it, do it now. 11868 11869 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is 11870 Target_Type : constant Entity_Id := Etype (N); 11871 Operand : constant Node_Id := Expression (N); 11872 Operand_Type : constant Entity_Id := Etype (Operand); 11873 11874 begin 11875 -- Nothing at all to do if conversion is to the identical type so remove 11876 -- the conversion completely, it is useless, except that it may carry 11877 -- an Assignment_OK indication which must be propagated to the operand. 11878 11879 if Operand_Type = Target_Type then 11880 11881 -- Code duplicates Expand_N_Unchecked_Expression above, factor??? 11882 11883 if Assignment_OK (N) then 11884 Set_Assignment_OK (Operand); 11885 end if; 11886 11887 Rewrite (N, Relocate_Node (Operand)); 11888 return; 11889 end if; 11890 11891 -- If we have a conversion of a compile time known value to a target 11892 -- type and the value is in range of the target type, then we can simply 11893 -- replace the construct by an integer literal of the correct type. We 11894 -- only apply this to integer types being converted. Possibly it may 11895 -- apply in other cases, but it is too much trouble to worry about. 11896 11897 -- Note that we do not do this transformation if the Kill_Range_Check 11898 -- flag is set, since then the value may be outside the expected range. 11899 -- This happens in the Normalize_Scalars case. 11900 11901 -- We also skip this if either the target or operand type is biased 11902 -- because in this case, the unchecked conversion is supposed to 11903 -- preserve the bit pattern, not the integer value. 11904 11905 if Is_Integer_Type (Target_Type) 11906 and then not Has_Biased_Representation (Target_Type) 11907 and then Is_Integer_Type (Operand_Type) 11908 and then not Has_Biased_Representation (Operand_Type) 11909 and then Compile_Time_Known_Value (Operand) 11910 and then not Kill_Range_Check (N) 11911 then 11912 declare 11913 Val : constant Uint := Expr_Value (Operand); 11914 11915 begin 11916 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) 11917 and then 11918 Compile_Time_Known_Value (Type_High_Bound (Target_Type)) 11919 and then 11920 Val >= Expr_Value (Type_Low_Bound (Target_Type)) 11921 and then 11922 Val <= Expr_Value (Type_High_Bound (Target_Type)) 11923 then 11924 Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); 11925 11926 -- If Address is the target type, just set the type to avoid a 11927 -- spurious type error on the literal when Address is a visible 11928 -- integer type. 11929 11930 if Is_Descendant_Of_Address (Target_Type) then 11931 Set_Etype (N, Target_Type); 11932 else 11933 Analyze_And_Resolve (N, Target_Type); 11934 end if; 11935 11936 return; 11937 end if; 11938 end; 11939 end if; 11940 11941 -- Nothing to do if conversion is safe 11942 11943 if Safe_Unchecked_Type_Conversion (N) then 11944 return; 11945 end if; 11946 11947 -- Otherwise force evaluation unless Assignment_OK flag is set (this 11948 -- flag indicates ??? More comments needed here) 11949 11950 if Assignment_OK (N) then 11951 null; 11952 else 11953 Force_Evaluation (N); 11954 end if; 11955 end Expand_N_Unchecked_Type_Conversion; 11956 11957 ---------------------------- 11958 -- Expand_Record_Equality -- 11959 ---------------------------- 11960 11961 -- For non-variant records, Equality is expanded when needed into: 11962 11963 -- and then Lhs.Discr1 = Rhs.Discr1 11964 -- and then ... 11965 -- and then Lhs.Discrn = Rhs.Discrn 11966 -- and then Lhs.Cmp1 = Rhs.Cmp1 11967 -- and then ... 11968 -- and then Lhs.Cmpn = Rhs.Cmpn 11969 11970 -- The expression is folded by the back end for adjacent fields. This 11971 -- function is called for tagged record in only one occasion: for imple- 11972 -- menting predefined primitive equality (see Predefined_Primitives_Bodies) 11973 -- otherwise the primitive "=" is used directly. 11974 11975 function Expand_Record_Equality 11976 (Nod : Node_Id; 11977 Typ : Entity_Id; 11978 Lhs : Node_Id; 11979 Rhs : Node_Id; 11980 Bodies : List_Id) return Node_Id 11981 is 11982 Loc : constant Source_Ptr := Sloc (Nod); 11983 11984 Result : Node_Id; 11985 C : Entity_Id; 11986 11987 First_Time : Boolean := True; 11988 11989 function Element_To_Compare (C : Entity_Id) return Entity_Id; 11990 -- Return the next discriminant or component to compare, starting with 11991 -- C, skipping inherited components. 11992 11993 ------------------------ 11994 -- Element_To_Compare -- 11995 ------------------------ 11996 11997 function Element_To_Compare (C : Entity_Id) return Entity_Id is 11998 Comp : Entity_Id; 11999 12000 begin 12001 Comp := C; 12002 loop 12003 -- Exit loop when the next element to be compared is found, or 12004 -- there is no more such element. 12005 12006 exit when No (Comp); 12007 12008 exit when Ekind_In (Comp, E_Discriminant, E_Component) 12009 and then not ( 12010 12011 -- Skip inherited components 12012 12013 -- Note: for a tagged type, we always generate the "=" primitive 12014 -- for the base type (not on the first subtype), so the test for 12015 -- Comp /= Original_Record_Component (Comp) is True for 12016 -- inherited components only. 12017 12018 (Is_Tagged_Type (Typ) 12019 and then Comp /= Original_Record_Component (Comp)) 12020 12021 -- Skip _Tag 12022 12023 or else Chars (Comp) = Name_uTag 12024 12025 -- Skip interface elements (secondary tags???) 12026 12027 or else Is_Interface (Etype (Comp))); 12028 12029 Next_Entity (Comp); 12030 end loop; 12031 12032 return Comp; 12033 end Element_To_Compare; 12034 12035 -- Start of processing for Expand_Record_Equality 12036 12037 begin 12038 -- Generates the following code: (assuming that Typ has one Discr and 12039 -- component C2 is also a record) 12040 12041 -- True 12042 -- and then Lhs.Discr1 = Rhs.Discr1 12043 -- and then Lhs.C1 = Rhs.C1 12044 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn 12045 -- and then ... 12046 -- and then Lhs.Cmpn = Rhs.Cmpn 12047 12048 Result := New_Occurrence_Of (Standard_True, Loc); 12049 C := Element_To_Compare (First_Entity (Typ)); 12050 while Present (C) loop 12051 declare 12052 New_Lhs : Node_Id; 12053 New_Rhs : Node_Id; 12054 Check : Node_Id; 12055 12056 begin 12057 if First_Time then 12058 First_Time := False; 12059 New_Lhs := Lhs; 12060 New_Rhs := Rhs; 12061 else 12062 New_Lhs := New_Copy_Tree (Lhs); 12063 New_Rhs := New_Copy_Tree (Rhs); 12064 end if; 12065 12066 Check := 12067 Expand_Composite_Equality (Nod, Etype (C), 12068 Lhs => 12069 Make_Selected_Component (Loc, 12070 Prefix => New_Lhs, 12071 Selector_Name => New_Occurrence_Of (C, Loc)), 12072 Rhs => 12073 Make_Selected_Component (Loc, 12074 Prefix => New_Rhs, 12075 Selector_Name => New_Occurrence_Of (C, Loc)), 12076 Bodies => Bodies); 12077 12078 -- If some (sub)component is an unchecked_union, the whole 12079 -- operation will raise program error. 12080 12081 if Nkind (Check) = N_Raise_Program_Error then 12082 Result := Check; 12083 Set_Etype (Result, Standard_Boolean); 12084 exit; 12085 else 12086 Result := 12087 Make_And_Then (Loc, 12088 Left_Opnd => Result, 12089 Right_Opnd => Check); 12090 end if; 12091 end; 12092 12093 C := Element_To_Compare (Next_Entity (C)); 12094 end loop; 12095 12096 return Result; 12097 end Expand_Record_Equality; 12098 12099 --------------------------- 12100 -- Expand_Set_Membership -- 12101 --------------------------- 12102 12103 procedure Expand_Set_Membership (N : Node_Id) is 12104 Lop : constant Node_Id := Left_Opnd (N); 12105 Alt : Node_Id; 12106 Res : Node_Id; 12107 12108 function Make_Cond (Alt : Node_Id) return Node_Id; 12109 -- If the alternative is a subtype mark, create a simple membership 12110 -- test. Otherwise create an equality test for it. 12111 12112 --------------- 12113 -- Make_Cond -- 12114 --------------- 12115 12116 function Make_Cond (Alt : Node_Id) return Node_Id is 12117 Cond : Node_Id; 12118 L : constant Node_Id := New_Copy (Lop); 12119 R : constant Node_Id := Relocate_Node (Alt); 12120 12121 begin 12122 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) 12123 or else Nkind (Alt) = N_Range 12124 then 12125 Cond := 12126 Make_In (Sloc (Alt), 12127 Left_Opnd => L, 12128 Right_Opnd => R); 12129 else 12130 Cond := 12131 Make_Op_Eq (Sloc (Alt), 12132 Left_Opnd => L, 12133 Right_Opnd => R); 12134 end if; 12135 12136 return Cond; 12137 end Make_Cond; 12138 12139 -- Start of processing for Expand_Set_Membership 12140 12141 begin 12142 Remove_Side_Effects (Lop); 12143 12144 Alt := Last (Alternatives (N)); 12145 Res := Make_Cond (Alt); 12146 12147 Prev (Alt); 12148 while Present (Alt) loop 12149 Res := 12150 Make_Or_Else (Sloc (Alt), 12151 Left_Opnd => Make_Cond (Alt), 12152 Right_Opnd => Res); 12153 Prev (Alt); 12154 end loop; 12155 12156 Rewrite (N, Res); 12157 Analyze_And_Resolve (N, Standard_Boolean); 12158 end Expand_Set_Membership; 12159 12160 ----------------------------------- 12161 -- Expand_Short_Circuit_Operator -- 12162 ----------------------------------- 12163 12164 -- Deal with special expansion if actions are present for the right operand 12165 -- and deal with optimizing case of arguments being True or False. We also 12166 -- deal with the special case of non-standard boolean values. 12167 12168 procedure Expand_Short_Circuit_Operator (N : Node_Id) is 12169 Loc : constant Source_Ptr := Sloc (N); 12170 Typ : constant Entity_Id := Etype (N); 12171 Left : constant Node_Id := Left_Opnd (N); 12172 Right : constant Node_Id := Right_Opnd (N); 12173 LocR : constant Source_Ptr := Sloc (Right); 12174 Actlist : List_Id; 12175 12176 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; 12177 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); 12178 -- If Left = Shortcut_Value then Right need not be evaluated 12179 12180 function Make_Test_Expr (Opnd : Node_Id) return Node_Id; 12181 -- For Opnd a boolean expression, return a Boolean expression equivalent 12182 -- to Opnd /= Shortcut_Value. 12183 12184 -------------------- 12185 -- Make_Test_Expr -- 12186 -------------------- 12187 12188 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is 12189 begin 12190 if Shortcut_Value then 12191 return Make_Op_Not (Sloc (Opnd), Opnd); 12192 else 12193 return Opnd; 12194 end if; 12195 end Make_Test_Expr; 12196 12197 -- Local variables 12198 12199 Op_Var : Entity_Id; 12200 -- Entity for a temporary variable holding the value of the operator, 12201 -- used for expansion in the case where actions are present. 12202 12203 -- Start of processing for Expand_Short_Circuit_Operator 12204 12205 begin 12206 -- Deal with non-standard booleans 12207 12208 if Is_Boolean_Type (Typ) then 12209 Adjust_Condition (Left); 12210 Adjust_Condition (Right); 12211 Set_Etype (N, Standard_Boolean); 12212 end if; 12213 12214 -- Check for cases where left argument is known to be True or False 12215 12216 if Compile_Time_Known_Value (Left) then 12217 12218 -- Mark SCO for left condition as compile time known 12219 12220 if Generate_SCO and then Comes_From_Source (Left) then 12221 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); 12222 end if; 12223 12224 -- Rewrite True AND THEN Right / False OR ELSE Right to Right. 12225 -- Any actions associated with Right will be executed unconditionally 12226 -- and can thus be inserted into the tree unconditionally. 12227 12228 if Expr_Value_E (Left) /= Shortcut_Ent then 12229 if Present (Actions (N)) then 12230 Insert_Actions (N, Actions (N)); 12231 end if; 12232 12233 Rewrite (N, Right); 12234 12235 -- Rewrite False AND THEN Right / True OR ELSE Right to Left. 12236 -- In this case we can forget the actions associated with Right, 12237 -- since they will never be executed. 12238 12239 else 12240 Kill_Dead_Code (Right); 12241 Kill_Dead_Code (Actions (N)); 12242 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 12243 end if; 12244 12245 Adjust_Result_Type (N, Typ); 12246 return; 12247 end if; 12248 12249 -- If Actions are present for the right operand, we have to do some 12250 -- special processing. We can't just let these actions filter back into 12251 -- code preceding the short circuit (which is what would have happened 12252 -- if we had not trapped them in the short-circuit form), since they 12253 -- must only be executed if the right operand of the short circuit is 12254 -- executed and not otherwise. 12255 12256 if Present (Actions (N)) then 12257 Actlist := Actions (N); 12258 12259 -- The old approach is to expand: 12260 12261 -- left AND THEN right 12262 12263 -- into 12264 12265 -- C : Boolean := False; 12266 -- IF left THEN 12267 -- Actions; 12268 -- IF right THEN 12269 -- C := True; 12270 -- END IF; 12271 -- END IF; 12272 12273 -- and finally rewrite the operator into a reference to C. Similarly 12274 -- for left OR ELSE right, with negated values. Note that this 12275 -- rewrite causes some difficulties for coverage analysis because 12276 -- of the introduction of the new variable C, which obscures the 12277 -- structure of the test. 12278 12279 -- We use this "old approach" if Minimize_Expression_With_Actions 12280 -- is True. 12281 12282 if Minimize_Expression_With_Actions then 12283 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); 12284 12285 Insert_Action (N, 12286 Make_Object_Declaration (Loc, 12287 Defining_Identifier => Op_Var, 12288 Object_Definition => 12289 New_Occurrence_Of (Standard_Boolean, Loc), 12290 Expression => 12291 New_Occurrence_Of (Shortcut_Ent, Loc))); 12292 12293 Append_To (Actlist, 12294 Make_Implicit_If_Statement (Right, 12295 Condition => Make_Test_Expr (Right), 12296 Then_Statements => New_List ( 12297 Make_Assignment_Statement (LocR, 12298 Name => New_Occurrence_Of (Op_Var, LocR), 12299 Expression => 12300 New_Occurrence_Of 12301 (Boolean_Literals (not Shortcut_Value), LocR))))); 12302 12303 Insert_Action (N, 12304 Make_Implicit_If_Statement (Left, 12305 Condition => Make_Test_Expr (Left), 12306 Then_Statements => Actlist)); 12307 12308 Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); 12309 Analyze_And_Resolve (N, Standard_Boolean); 12310 12311 -- The new approach (the default) is to use an 12312 -- Expression_With_Actions node for the right operand of the 12313 -- short-circuit form. Note that this solves the traceability 12314 -- problems for coverage analysis. 12315 12316 else 12317 Rewrite (Right, 12318 Make_Expression_With_Actions (LocR, 12319 Expression => Relocate_Node (Right), 12320 Actions => Actlist)); 12321 12322 Set_Actions (N, No_List); 12323 Analyze_And_Resolve (Right, Standard_Boolean); 12324 end if; 12325 12326 Adjust_Result_Type (N, Typ); 12327 return; 12328 end if; 12329 12330 -- No actions present, check for cases of right argument True/False 12331 12332 if Compile_Time_Known_Value (Right) then 12333 12334 -- Mark SCO for left condition as compile time known 12335 12336 if Generate_SCO and then Comes_From_Source (Right) then 12337 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); 12338 end if; 12339 12340 -- Change (Left and then True), (Left or else False) to Left. Note 12341 -- that we know there are no actions associated with the right 12342 -- operand, since we just checked for this case above. 12343 12344 if Expr_Value_E (Right) /= Shortcut_Ent then 12345 Rewrite (N, Left); 12346 12347 -- Change (Left and then False), (Left or else True) to Right, 12348 -- making sure to preserve any side effects associated with the Left 12349 -- operand. 12350 12351 else 12352 Remove_Side_Effects (Left); 12353 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 12354 end if; 12355 end if; 12356 12357 Adjust_Result_Type (N, Typ); 12358 end Expand_Short_Circuit_Operator; 12359 12360 ------------------------------------- 12361 -- Fixup_Universal_Fixed_Operation -- 12362 ------------------------------------- 12363 12364 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is 12365 Conv : constant Node_Id := Parent (N); 12366 12367 begin 12368 -- We must have a type conversion immediately above us 12369 12370 pragma Assert (Nkind (Conv) = N_Type_Conversion); 12371 12372 -- Normally the type conversion gives our target type. The exception 12373 -- occurs in the case of the Round attribute, where the conversion 12374 -- will be to universal real, and our real type comes from the Round 12375 -- attribute (as well as an indication that we must round the result) 12376 12377 if Nkind (Parent (Conv)) = N_Attribute_Reference 12378 and then Attribute_Name (Parent (Conv)) = Name_Round 12379 then 12380 Set_Etype (N, Etype (Parent (Conv))); 12381 Set_Rounded_Result (N); 12382 12383 -- Normal case where type comes from conversion above us 12384 12385 else 12386 Set_Etype (N, Etype (Conv)); 12387 end if; 12388 end Fixup_Universal_Fixed_Operation; 12389 12390 --------------------------------- 12391 -- Has_Inferable_Discriminants -- 12392 --------------------------------- 12393 12394 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is 12395 12396 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; 12397 -- Determines whether the left-most prefix of a selected component is a 12398 -- formal parameter in a subprogram. Assumes N is a selected component. 12399 12400 -------------------------------- 12401 -- Prefix_Is_Formal_Parameter -- 12402 -------------------------------- 12403 12404 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is 12405 Sel_Comp : Node_Id; 12406 12407 begin 12408 -- Move to the left-most prefix by climbing up the tree 12409 12410 Sel_Comp := N; 12411 while Present (Parent (Sel_Comp)) 12412 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component 12413 loop 12414 Sel_Comp := Parent (Sel_Comp); 12415 end loop; 12416 12417 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; 12418 end Prefix_Is_Formal_Parameter; 12419 12420 -- Start of processing for Has_Inferable_Discriminants 12421 12422 begin 12423 -- For selected components, the subtype of the selector must be a 12424 -- constrained Unchecked_Union. If the component is subject to a 12425 -- per-object constraint, then the enclosing object must have inferable 12426 -- discriminants. 12427 12428 if Nkind (N) = N_Selected_Component then 12429 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then 12430 12431 -- A small hack. If we have a per-object constrained selected 12432 -- component of a formal parameter, return True since we do not 12433 -- know the actual parameter association yet. 12434 12435 if Prefix_Is_Formal_Parameter (N) then 12436 return True; 12437 12438 -- Otherwise, check the enclosing object and the selector 12439 12440 else 12441 return Has_Inferable_Discriminants (Prefix (N)) 12442 and then Has_Inferable_Discriminants (Selector_Name (N)); 12443 end if; 12444 12445 -- The call to Has_Inferable_Discriminants will determine whether 12446 -- the selector has a constrained Unchecked_Union nominal type. 12447 12448 else 12449 return Has_Inferable_Discriminants (Selector_Name (N)); 12450 end if; 12451 12452 -- A qualified expression has inferable discriminants if its subtype 12453 -- mark is a constrained Unchecked_Union subtype. 12454 12455 elsif Nkind (N) = N_Qualified_Expression then 12456 return Is_Unchecked_Union (Etype (Subtype_Mark (N))) 12457 and then Is_Constrained (Etype (Subtype_Mark (N))); 12458 12459 -- For all other names, it is sufficient to have a constrained 12460 -- Unchecked_Union nominal subtype. 12461 12462 else 12463 return Is_Unchecked_Union (Base_Type (Etype (N))) 12464 and then Is_Constrained (Etype (N)); 12465 end if; 12466 end Has_Inferable_Discriminants; 12467 12468 ------------------------------- 12469 -- Insert_Dereference_Action -- 12470 ------------------------------- 12471 12472 procedure Insert_Dereference_Action (N : Node_Id) is 12473 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; 12474 -- Return true if type of P is derived from Checked_Pool; 12475 12476 ----------------------------- 12477 -- Is_Checked_Storage_Pool -- 12478 ----------------------------- 12479 12480 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is 12481 T : Entity_Id; 12482 12483 begin 12484 if No (P) then 12485 return False; 12486 end if; 12487 12488 T := Etype (P); 12489 while T /= Etype (T) loop 12490 if Is_RTE (T, RE_Checked_Pool) then 12491 return True; 12492 else 12493 T := Etype (T); 12494 end if; 12495 end loop; 12496 12497 return False; 12498 end Is_Checked_Storage_Pool; 12499 12500 -- Local variables 12501 12502 Context : constant Node_Id := Parent (N); 12503 Ptr_Typ : constant Entity_Id := Etype (N); 12504 Desig_Typ : constant Entity_Id := 12505 Available_View (Designated_Type (Ptr_Typ)); 12506 Loc : constant Source_Ptr := Sloc (N); 12507 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ); 12508 12509 Addr : Entity_Id; 12510 Alig : Entity_Id; 12511 Deref : Node_Id; 12512 Size : Entity_Id; 12513 Size_Bits : Node_Id; 12514 Stmt : Node_Id; 12515 12516 -- Start of processing for Insert_Dereference_Action 12517 12518 begin 12519 pragma Assert (Nkind (Context) = N_Explicit_Dereference); 12520 12521 -- Do not re-expand a dereference which has already been processed by 12522 -- this routine. 12523 12524 if Has_Dereference_Action (Context) then 12525 return; 12526 12527 -- Do not perform this type of expansion for internally-generated 12528 -- dereferences. 12529 12530 elsif not Comes_From_Source (Original_Node (Context)) then 12531 return; 12532 12533 -- A dereference action is only applicable to objects which have been 12534 -- allocated on a checked pool. 12535 12536 elsif not Is_Checked_Storage_Pool (Pool) then 12537 return; 12538 end if; 12539 12540 -- Extract the address of the dereferenced object. Generate: 12541 12542 -- Addr : System.Address := <N>'Pool_Address; 12543 12544 Addr := Make_Temporary (Loc, 'P'); 12545 12546 Insert_Action (N, 12547 Make_Object_Declaration (Loc, 12548 Defining_Identifier => Addr, 12549 Object_Definition => 12550 New_Occurrence_Of (RTE (RE_Address), Loc), 12551 Expression => 12552 Make_Attribute_Reference (Loc, 12553 Prefix => Duplicate_Subexpr_Move_Checks (N), 12554 Attribute_Name => Name_Pool_Address))); 12555 12556 -- Calculate the size of the dereferenced object. Generate: 12557 12558 -- Size : Storage_Count := <N>.all'Size / Storage_Unit; 12559 12560 Deref := 12561 Make_Explicit_Dereference (Loc, 12562 Prefix => Duplicate_Subexpr_Move_Checks (N)); 12563 Set_Has_Dereference_Action (Deref); 12564 12565 Size_Bits := 12566 Make_Attribute_Reference (Loc, 12567 Prefix => Deref, 12568 Attribute_Name => Name_Size); 12569 12570 -- Special case of an unconstrained array: need to add descriptor size 12571 12572 if Is_Array_Type (Desig_Typ) 12573 and then not Is_Constrained (First_Subtype (Desig_Typ)) 12574 then 12575 Size_Bits := 12576 Make_Op_Add (Loc, 12577 Left_Opnd => 12578 Make_Attribute_Reference (Loc, 12579 Prefix => 12580 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc), 12581 Attribute_Name => Name_Descriptor_Size), 12582 Right_Opnd => Size_Bits); 12583 end if; 12584 12585 Size := Make_Temporary (Loc, 'S'); 12586 Insert_Action (N, 12587 Make_Object_Declaration (Loc, 12588 Defining_Identifier => Size, 12589 Object_Definition => 12590 New_Occurrence_Of (RTE (RE_Storage_Count), Loc), 12591 Expression => 12592 Make_Op_Divide (Loc, 12593 Left_Opnd => Size_Bits, 12594 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); 12595 12596 -- Calculate the alignment of the dereferenced object. Generate: 12597 -- Alig : constant Storage_Count := <N>.all'Alignment; 12598 12599 Deref := 12600 Make_Explicit_Dereference (Loc, 12601 Prefix => Duplicate_Subexpr_Move_Checks (N)); 12602 Set_Has_Dereference_Action (Deref); 12603 12604 Alig := Make_Temporary (Loc, 'A'); 12605 Insert_Action (N, 12606 Make_Object_Declaration (Loc, 12607 Defining_Identifier => Alig, 12608 Object_Definition => 12609 New_Occurrence_Of (RTE (RE_Storage_Count), Loc), 12610 Expression => 12611 Make_Attribute_Reference (Loc, 12612 Prefix => Deref, 12613 Attribute_Name => Name_Alignment))); 12614 12615 -- A dereference of a controlled object requires special processing. The 12616 -- finalization machinery requests additional space from the underlying 12617 -- pool to allocate and hide two pointers. As a result, a checked pool 12618 -- may mark the wrong memory as valid. Since checked pools do not have 12619 -- knowledge of hidden pointers, we have to bring the two pointers back 12620 -- in view in order to restore the original state of the object. 12621 12622 -- The address manipulation is not performed for access types that are 12623 -- subject to pragma No_Heap_Finalization because the two pointers do 12624 -- not exist in the first place. 12625 12626 if No_Heap_Finalization (Ptr_Typ) then 12627 null; 12628 12629 elsif Needs_Finalization (Desig_Typ) then 12630 12631 -- Adjust the address and size of the dereferenced object. Generate: 12632 -- Adjust_Controlled_Dereference (Addr, Size, Alig); 12633 12634 Stmt := 12635 Make_Procedure_Call_Statement (Loc, 12636 Name => 12637 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc), 12638 Parameter_Associations => New_List ( 12639 New_Occurrence_Of (Addr, Loc), 12640 New_Occurrence_Of (Size, Loc), 12641 New_Occurrence_Of (Alig, Loc))); 12642 12643 -- Class-wide types complicate things because we cannot determine 12644 -- statically whether the actual object is truly controlled. We must 12645 -- generate a runtime check to detect this property. Generate: 12646 -- 12647 -- if Needs_Finalization (<N>.all'Tag) then 12648 -- <Stmt>; 12649 -- end if; 12650 12651 if Is_Class_Wide_Type (Desig_Typ) then 12652 Deref := 12653 Make_Explicit_Dereference (Loc, 12654 Prefix => Duplicate_Subexpr_Move_Checks (N)); 12655 Set_Has_Dereference_Action (Deref); 12656 12657 Stmt := 12658 Make_Implicit_If_Statement (N, 12659 Condition => 12660 Make_Function_Call (Loc, 12661 Name => 12662 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc), 12663 Parameter_Associations => New_List ( 12664 Make_Attribute_Reference (Loc, 12665 Prefix => Deref, 12666 Attribute_Name => Name_Tag))), 12667 Then_Statements => New_List (Stmt)); 12668 end if; 12669 12670 Insert_Action (N, Stmt); 12671 end if; 12672 12673 -- Generate: 12674 -- Dereference (Pool, Addr, Size, Alig); 12675 12676 Insert_Action (N, 12677 Make_Procedure_Call_Statement (Loc, 12678 Name => 12679 New_Occurrence_Of 12680 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), 12681 Parameter_Associations => New_List ( 12682 New_Occurrence_Of (Pool, Loc), 12683 New_Occurrence_Of (Addr, Loc), 12684 New_Occurrence_Of (Size, Loc), 12685 New_Occurrence_Of (Alig, Loc)))); 12686 12687 -- Mark the explicit dereference as processed to avoid potential 12688 -- infinite expansion. 12689 12690 Set_Has_Dereference_Action (Context); 12691 12692 exception 12693 when RE_Not_Available => 12694 return; 12695 end Insert_Dereference_Action; 12696 12697 -------------------------------- 12698 -- Integer_Promotion_Possible -- 12699 -------------------------------- 12700 12701 function Integer_Promotion_Possible (N : Node_Id) return Boolean is 12702 Operand : constant Node_Id := Expression (N); 12703 Operand_Type : constant Entity_Id := Etype (Operand); 12704 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); 12705 12706 begin 12707 pragma Assert (Nkind (N) = N_Type_Conversion); 12708 12709 return 12710 12711 -- We only do the transformation for source constructs. We assume 12712 -- that the expander knows what it is doing when it generates code. 12713 12714 Comes_From_Source (N) 12715 12716 -- If the operand type is Short_Integer or Short_Short_Integer, 12717 -- then we will promote to Integer, which is available on all 12718 -- targets, and is sufficient to ensure no intermediate overflow. 12719 -- Furthermore it is likely to be as efficient or more efficient 12720 -- than using the smaller type for the computation so we do this 12721 -- unconditionally. 12722 12723 and then 12724 (Root_Operand_Type = Base_Type (Standard_Short_Integer) 12725 or else 12726 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) 12727 12728 -- Test for interesting operation, which includes addition, 12729 -- division, exponentiation, multiplication, subtraction, absolute 12730 -- value and unary negation. Unary "+" is omitted since it is a 12731 -- no-op and thus can't overflow. 12732 12733 and then Nkind_In (Operand, N_Op_Abs, 12734 N_Op_Add, 12735 N_Op_Divide, 12736 N_Op_Expon, 12737 N_Op_Minus, 12738 N_Op_Multiply, 12739 N_Op_Subtract); 12740 end Integer_Promotion_Possible; 12741 12742 ------------------------------ 12743 -- Make_Array_Comparison_Op -- 12744 ------------------------------ 12745 12746 -- This is a hand-coded expansion of the following generic function: 12747 12748 -- generic 12749 -- type elem is (<>); 12750 -- type index is (<>); 12751 -- type a is array (index range <>) of elem; 12752 12753 -- function Gnnn (X : a; Y: a) return boolean is 12754 -- J : index := Y'first; 12755 12756 -- begin 12757 -- if X'length = 0 then 12758 -- return false; 12759 12760 -- elsif Y'length = 0 then 12761 -- return true; 12762 12763 -- else 12764 -- for I in X'range loop 12765 -- if X (I) = Y (J) then 12766 -- if J = Y'last then 12767 -- exit; 12768 -- else 12769 -- J := index'succ (J); 12770 -- end if; 12771 12772 -- else 12773 -- return X (I) > Y (J); 12774 -- end if; 12775 -- end loop; 12776 12777 -- return X'length > Y'length; 12778 -- end if; 12779 -- end Gnnn; 12780 12781 -- Note that since we are essentially doing this expansion by hand, we 12782 -- do not need to generate an actual or formal generic part, just the 12783 -- instantiated function itself. 12784 12785 -- Perhaps we could have the actual generic available in the run-time, 12786 -- obtained by rtsfind, and actually expand a real instantiation ??? 12787 12788 function Make_Array_Comparison_Op 12789 (Typ : Entity_Id; 12790 Nod : Node_Id) return Node_Id 12791 is 12792 Loc : constant Source_Ptr := Sloc (Nod); 12793 12794 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); 12795 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); 12796 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); 12797 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 12798 12799 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); 12800 12801 Loop_Statement : Node_Id; 12802 Loop_Body : Node_Id; 12803 If_Stat : Node_Id; 12804 Inner_If : Node_Id; 12805 Final_Expr : Node_Id; 12806 Func_Body : Node_Id; 12807 Func_Name : Entity_Id; 12808 Formals : List_Id; 12809 Length1 : Node_Id; 12810 Length2 : Node_Id; 12811 12812 begin 12813 -- if J = Y'last then 12814 -- exit; 12815 -- else 12816 -- J := index'succ (J); 12817 -- end if; 12818 12819 Inner_If := 12820 Make_Implicit_If_Statement (Nod, 12821 Condition => 12822 Make_Op_Eq (Loc, 12823 Left_Opnd => New_Occurrence_Of (J, Loc), 12824 Right_Opnd => 12825 Make_Attribute_Reference (Loc, 12826 Prefix => New_Occurrence_Of (Y, Loc), 12827 Attribute_Name => Name_Last)), 12828 12829 Then_Statements => New_List ( 12830 Make_Exit_Statement (Loc)), 12831 12832 Else_Statements => 12833 New_List ( 12834 Make_Assignment_Statement (Loc, 12835 Name => New_Occurrence_Of (J, Loc), 12836 Expression => 12837 Make_Attribute_Reference (Loc, 12838 Prefix => New_Occurrence_Of (Index, Loc), 12839 Attribute_Name => Name_Succ, 12840 Expressions => New_List (New_Occurrence_Of (J, Loc)))))); 12841 12842 -- if X (I) = Y (J) then 12843 -- if ... end if; 12844 -- else 12845 -- return X (I) > Y (J); 12846 -- end if; 12847 12848 Loop_Body := 12849 Make_Implicit_If_Statement (Nod, 12850 Condition => 12851 Make_Op_Eq (Loc, 12852 Left_Opnd => 12853 Make_Indexed_Component (Loc, 12854 Prefix => New_Occurrence_Of (X, Loc), 12855 Expressions => New_List (New_Occurrence_Of (I, Loc))), 12856 12857 Right_Opnd => 12858 Make_Indexed_Component (Loc, 12859 Prefix => New_Occurrence_Of (Y, Loc), 12860 Expressions => New_List (New_Occurrence_Of (J, Loc)))), 12861 12862 Then_Statements => New_List (Inner_If), 12863 12864 Else_Statements => New_List ( 12865 Make_Simple_Return_Statement (Loc, 12866 Expression => 12867 Make_Op_Gt (Loc, 12868 Left_Opnd => 12869 Make_Indexed_Component (Loc, 12870 Prefix => New_Occurrence_Of (X, Loc), 12871 Expressions => New_List (New_Occurrence_Of (I, Loc))), 12872 12873 Right_Opnd => 12874 Make_Indexed_Component (Loc, 12875 Prefix => New_Occurrence_Of (Y, Loc), 12876 Expressions => New_List ( 12877 New_Occurrence_Of (J, Loc))))))); 12878 12879 -- for I in X'range loop 12880 -- if ... end if; 12881 -- end loop; 12882 12883 Loop_Statement := 12884 Make_Implicit_Loop_Statement (Nod, 12885 Identifier => Empty, 12886 12887 Iteration_Scheme => 12888 Make_Iteration_Scheme (Loc, 12889 Loop_Parameter_Specification => 12890 Make_Loop_Parameter_Specification (Loc, 12891 Defining_Identifier => I, 12892 Discrete_Subtype_Definition => 12893 Make_Attribute_Reference (Loc, 12894 Prefix => New_Occurrence_Of (X, Loc), 12895 Attribute_Name => Name_Range))), 12896 12897 Statements => New_List (Loop_Body)); 12898 12899 -- if X'length = 0 then 12900 -- return false; 12901 -- elsif Y'length = 0 then 12902 -- return true; 12903 -- else 12904 -- for ... loop ... end loop; 12905 -- return X'length > Y'length; 12906 -- end if; 12907 12908 Length1 := 12909 Make_Attribute_Reference (Loc, 12910 Prefix => New_Occurrence_Of (X, Loc), 12911 Attribute_Name => Name_Length); 12912 12913 Length2 := 12914 Make_Attribute_Reference (Loc, 12915 Prefix => New_Occurrence_Of (Y, Loc), 12916 Attribute_Name => Name_Length); 12917 12918 Final_Expr := 12919 Make_Op_Gt (Loc, 12920 Left_Opnd => Length1, 12921 Right_Opnd => Length2); 12922 12923 If_Stat := 12924 Make_Implicit_If_Statement (Nod, 12925 Condition => 12926 Make_Op_Eq (Loc, 12927 Left_Opnd => 12928 Make_Attribute_Reference (Loc, 12929 Prefix => New_Occurrence_Of (X, Loc), 12930 Attribute_Name => Name_Length), 12931 Right_Opnd => 12932 Make_Integer_Literal (Loc, 0)), 12933 12934 Then_Statements => 12935 New_List ( 12936 Make_Simple_Return_Statement (Loc, 12937 Expression => New_Occurrence_Of (Standard_False, Loc))), 12938 12939 Elsif_Parts => New_List ( 12940 Make_Elsif_Part (Loc, 12941 Condition => 12942 Make_Op_Eq (Loc, 12943 Left_Opnd => 12944 Make_Attribute_Reference (Loc, 12945 Prefix => New_Occurrence_Of (Y, Loc), 12946 Attribute_Name => Name_Length), 12947 Right_Opnd => 12948 Make_Integer_Literal (Loc, 0)), 12949 12950 Then_Statements => 12951 New_List ( 12952 Make_Simple_Return_Statement (Loc, 12953 Expression => New_Occurrence_Of (Standard_True, Loc))))), 12954 12955 Else_Statements => New_List ( 12956 Loop_Statement, 12957 Make_Simple_Return_Statement (Loc, 12958 Expression => Final_Expr))); 12959 12960 -- (X : a; Y: a) 12961 12962 Formals := New_List ( 12963 Make_Parameter_Specification (Loc, 12964 Defining_Identifier => X, 12965 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 12966 12967 Make_Parameter_Specification (Loc, 12968 Defining_Identifier => Y, 12969 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 12970 12971 -- function Gnnn (...) return boolean is 12972 -- J : index := Y'first; 12973 -- begin 12974 -- if ... end if; 12975 -- end Gnnn; 12976 12977 Func_Name := Make_Temporary (Loc, 'G'); 12978 12979 Func_Body := 12980 Make_Subprogram_Body (Loc, 12981 Specification => 12982 Make_Function_Specification (Loc, 12983 Defining_Unit_Name => Func_Name, 12984 Parameter_Specifications => Formals, 12985 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 12986 12987 Declarations => New_List ( 12988 Make_Object_Declaration (Loc, 12989 Defining_Identifier => J, 12990 Object_Definition => New_Occurrence_Of (Index, Loc), 12991 Expression => 12992 Make_Attribute_Reference (Loc, 12993 Prefix => New_Occurrence_Of (Y, Loc), 12994 Attribute_Name => Name_First))), 12995 12996 Handled_Statement_Sequence => 12997 Make_Handled_Sequence_Of_Statements (Loc, 12998 Statements => New_List (If_Stat))); 12999 13000 return Func_Body; 13001 end Make_Array_Comparison_Op; 13002 13003 --------------------------- 13004 -- Make_Boolean_Array_Op -- 13005 --------------------------- 13006 13007 -- For logical operations on boolean arrays, expand in line the following, 13008 -- replacing 'and' with 'or' or 'xor' where needed: 13009 13010 -- function Annn (A : typ; B: typ) return typ is 13011 -- C : typ; 13012 -- begin 13013 -- for J in A'range loop 13014 -- C (J) := A (J) op B (J); 13015 -- end loop; 13016 -- return C; 13017 -- end Annn; 13018 13019 -- Here typ is the boolean array type 13020 13021 function Make_Boolean_Array_Op 13022 (Typ : Entity_Id; 13023 N : Node_Id) return Node_Id 13024 is 13025 Loc : constant Source_Ptr := Sloc (N); 13026 13027 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 13028 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 13029 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); 13030 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 13031 13032 A_J : Node_Id; 13033 B_J : Node_Id; 13034 C_J : Node_Id; 13035 Op : Node_Id; 13036 13037 Formals : List_Id; 13038 Func_Name : Entity_Id; 13039 Func_Body : Node_Id; 13040 Loop_Statement : Node_Id; 13041 13042 begin 13043 A_J := 13044 Make_Indexed_Component (Loc, 13045 Prefix => New_Occurrence_Of (A, Loc), 13046 Expressions => New_List (New_Occurrence_Of (J, Loc))); 13047 13048 B_J := 13049 Make_Indexed_Component (Loc, 13050 Prefix => New_Occurrence_Of (B, Loc), 13051 Expressions => New_List (New_Occurrence_Of (J, Loc))); 13052 13053 C_J := 13054 Make_Indexed_Component (Loc, 13055 Prefix => New_Occurrence_Of (C, Loc), 13056 Expressions => New_List (New_Occurrence_Of (J, Loc))); 13057 13058 if Nkind (N) = N_Op_And then 13059 Op := 13060 Make_Op_And (Loc, 13061 Left_Opnd => A_J, 13062 Right_Opnd => B_J); 13063 13064 elsif Nkind (N) = N_Op_Or then 13065 Op := 13066 Make_Op_Or (Loc, 13067 Left_Opnd => A_J, 13068 Right_Opnd => B_J); 13069 13070 else 13071 Op := 13072 Make_Op_Xor (Loc, 13073 Left_Opnd => A_J, 13074 Right_Opnd => B_J); 13075 end if; 13076 13077 Loop_Statement := 13078 Make_Implicit_Loop_Statement (N, 13079 Identifier => Empty, 13080 13081 Iteration_Scheme => 13082 Make_Iteration_Scheme (Loc, 13083 Loop_Parameter_Specification => 13084 Make_Loop_Parameter_Specification (Loc, 13085 Defining_Identifier => J, 13086 Discrete_Subtype_Definition => 13087 Make_Attribute_Reference (Loc, 13088 Prefix => New_Occurrence_Of (A, Loc), 13089 Attribute_Name => Name_Range))), 13090 13091 Statements => New_List ( 13092 Make_Assignment_Statement (Loc, 13093 Name => C_J, 13094 Expression => Op))); 13095 13096 Formals := New_List ( 13097 Make_Parameter_Specification (Loc, 13098 Defining_Identifier => A, 13099 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 13100 13101 Make_Parameter_Specification (Loc, 13102 Defining_Identifier => B, 13103 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 13104 13105 Func_Name := Make_Temporary (Loc, 'A'); 13106 Set_Is_Inlined (Func_Name); 13107 13108 Func_Body := 13109 Make_Subprogram_Body (Loc, 13110 Specification => 13111 Make_Function_Specification (Loc, 13112 Defining_Unit_Name => Func_Name, 13113 Parameter_Specifications => Formals, 13114 Result_Definition => New_Occurrence_Of (Typ, Loc)), 13115 13116 Declarations => New_List ( 13117 Make_Object_Declaration (Loc, 13118 Defining_Identifier => C, 13119 Object_Definition => New_Occurrence_Of (Typ, Loc))), 13120 13121 Handled_Statement_Sequence => 13122 Make_Handled_Sequence_Of_Statements (Loc, 13123 Statements => New_List ( 13124 Loop_Statement, 13125 Make_Simple_Return_Statement (Loc, 13126 Expression => New_Occurrence_Of (C, Loc))))); 13127 13128 return Func_Body; 13129 end Make_Boolean_Array_Op; 13130 13131 ----------------------------------------- 13132 -- Minimized_Eliminated_Overflow_Check -- 13133 ----------------------------------------- 13134 13135 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is 13136 begin 13137 return 13138 Is_Signed_Integer_Type (Etype (N)) 13139 and then Overflow_Check_Mode in Minimized_Or_Eliminated; 13140 end Minimized_Eliminated_Overflow_Check; 13141 13142 -------------------------------- 13143 -- Optimize_Length_Comparison -- 13144 -------------------------------- 13145 13146 procedure Optimize_Length_Comparison (N : Node_Id) is 13147 Loc : constant Source_Ptr := Sloc (N); 13148 Typ : constant Entity_Id := Etype (N); 13149 Result : Node_Id; 13150 13151 Left : Node_Id; 13152 Right : Node_Id; 13153 -- First and Last attribute reference nodes, which end up as left and 13154 -- right operands of the optimized result. 13155 13156 Is_Zero : Boolean; 13157 -- True for comparison operand of zero 13158 13159 Comp : Node_Id; 13160 -- Comparison operand, set only if Is_Zero is false 13161 13162 Ent : Entity_Id := Empty; 13163 -- Entity whose length is being compared 13164 13165 Index : Node_Id := Empty; 13166 -- Integer_Literal node for length attribute expression, or Empty 13167 -- if there is no such expression present. 13168 13169 Ityp : Entity_Id; 13170 -- Type of array index to which 'Length is applied 13171 13172 Op : Node_Kind := Nkind (N); 13173 -- Kind of comparison operator, gets flipped if operands backwards 13174 13175 function Is_Optimizable (N : Node_Id) return Boolean; 13176 -- Tests N to see if it is an optimizable comparison value (defined as 13177 -- constant zero or one, or something else where the value is known to 13178 -- be positive and in the range of 32-bits, and where the corresponding 13179 -- Length value is also known to be 32-bits. If result is true, sets 13180 -- Is_Zero, Ityp, and Comp accordingly. 13181 13182 function Is_Entity_Length (N : Node_Id) return Boolean; 13183 -- Tests if N is a length attribute applied to a simple entity. If so, 13184 -- returns True, and sets Ent to the entity, and Index to the integer 13185 -- literal provided as an attribute expression, or to Empty if none. 13186 -- Also returns True if the expression is a generated type conversion 13187 -- whose expression is of the desired form. This latter case arises 13188 -- when Apply_Universal_Integer_Attribute_Check installs a conversion 13189 -- to check for being in range, which is not needed in this context. 13190 -- Returns False if neither condition holds. 13191 13192 function Prepare_64 (N : Node_Id) return Node_Id; 13193 -- Given a discrete expression, returns a Long_Long_Integer typed 13194 -- expression representing the underlying value of the expression. 13195 -- This is done with an unchecked conversion to the result type. We 13196 -- use unchecked conversion to handle the enumeration type case. 13197 13198 ---------------------- 13199 -- Is_Entity_Length -- 13200 ---------------------- 13201 13202 function Is_Entity_Length (N : Node_Id) return Boolean is 13203 begin 13204 if Nkind (N) = N_Attribute_Reference 13205 and then Attribute_Name (N) = Name_Length 13206 and then Is_Entity_Name (Prefix (N)) 13207 then 13208 Ent := Entity (Prefix (N)); 13209 13210 if Present (Expressions (N)) then 13211 Index := First (Expressions (N)); 13212 else 13213 Index := Empty; 13214 end if; 13215 13216 return True; 13217 13218 elsif Nkind (N) = N_Type_Conversion 13219 and then not Comes_From_Source (N) 13220 then 13221 return Is_Entity_Length (Expression (N)); 13222 13223 else 13224 return False; 13225 end if; 13226 end Is_Entity_Length; 13227 13228 -------------------- 13229 -- Is_Optimizable -- 13230 -------------------- 13231 13232 function Is_Optimizable (N : Node_Id) return Boolean is 13233 Val : Uint; 13234 OK : Boolean; 13235 Lo : Uint; 13236 Hi : Uint; 13237 Indx : Node_Id; 13238 13239 begin 13240 if Compile_Time_Known_Value (N) then 13241 Val := Expr_Value (N); 13242 13243 if Val = Uint_0 then 13244 Is_Zero := True; 13245 Comp := Empty; 13246 return True; 13247 13248 elsif Val = Uint_1 then 13249 Is_Zero := False; 13250 Comp := Empty; 13251 return True; 13252 end if; 13253 end if; 13254 13255 -- Here we have to make sure of being within 32-bits 13256 13257 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); 13258 13259 if not OK 13260 or else Lo < Uint_1 13261 or else Hi > UI_From_Int (Int'Last) 13262 then 13263 return False; 13264 end if; 13265 13266 -- Comparison value was within range, so now we must check the index 13267 -- value to make sure it is also within 32-bits. 13268 13269 Indx := First_Index (Etype (Ent)); 13270 13271 if Present (Index) then 13272 for J in 2 .. UI_To_Int (Intval (Index)) loop 13273 Next_Index (Indx); 13274 end loop; 13275 end if; 13276 13277 Ityp := Etype (Indx); 13278 13279 if Esize (Ityp) > 32 then 13280 return False; 13281 end if; 13282 13283 Is_Zero := False; 13284 Comp := N; 13285 return True; 13286 end Is_Optimizable; 13287 13288 ---------------- 13289 -- Prepare_64 -- 13290 ---------------- 13291 13292 function Prepare_64 (N : Node_Id) return Node_Id is 13293 begin 13294 return Unchecked_Convert_To (Standard_Long_Long_Integer, N); 13295 end Prepare_64; 13296 13297 -- Start of processing for Optimize_Length_Comparison 13298 13299 begin 13300 -- Nothing to do if not a comparison 13301 13302 if Op not in N_Op_Compare then 13303 return; 13304 end if; 13305 13306 -- Nothing to do if special -gnatd.P debug flag set. 13307 13308 if Debug_Flag_Dot_PP then 13309 return; 13310 end if; 13311 13312 -- Ent'Length op 0/1 13313 13314 if Is_Entity_Length (Left_Opnd (N)) 13315 and then Is_Optimizable (Right_Opnd (N)) 13316 then 13317 null; 13318 13319 -- 0/1 op Ent'Length 13320 13321 elsif Is_Entity_Length (Right_Opnd (N)) 13322 and then Is_Optimizable (Left_Opnd (N)) 13323 then 13324 -- Flip comparison to opposite sense 13325 13326 case Op is 13327 when N_Op_Lt => Op := N_Op_Gt; 13328 when N_Op_Le => Op := N_Op_Ge; 13329 when N_Op_Gt => Op := N_Op_Lt; 13330 when N_Op_Ge => Op := N_Op_Le; 13331 when others => null; 13332 end case; 13333 13334 -- Else optimization not possible 13335 13336 else 13337 return; 13338 end if; 13339 13340 -- Fall through if we will do the optimization 13341 13342 -- Cases to handle: 13343 13344 -- X'Length = 0 => X'First > X'Last 13345 -- X'Length = 1 => X'First = X'Last 13346 -- X'Length = n => X'First + (n - 1) = X'Last 13347 13348 -- X'Length /= 0 => X'First <= X'Last 13349 -- X'Length /= 1 => X'First /= X'Last 13350 -- X'Length /= n => X'First + (n - 1) /= X'Last 13351 13352 -- X'Length >= 0 => always true, warn 13353 -- X'Length >= 1 => X'First <= X'Last 13354 -- X'Length >= n => X'First + (n - 1) <= X'Last 13355 13356 -- X'Length > 0 => X'First <= X'Last 13357 -- X'Length > 1 => X'First < X'Last 13358 -- X'Length > n => X'First + (n - 1) < X'Last 13359 13360 -- X'Length <= 0 => X'First > X'Last (warn, could be =) 13361 -- X'Length <= 1 => X'First >= X'Last 13362 -- X'Length <= n => X'First + (n - 1) >= X'Last 13363 13364 -- X'Length < 0 => always false (warn) 13365 -- X'Length < 1 => X'First > X'Last 13366 -- X'Length < n => X'First + (n - 1) > X'Last 13367 13368 -- Note: for the cases of n (not constant 0,1), we require that the 13369 -- corresponding index type be integer or shorter (i.e. not 64-bit), 13370 -- and the same for the comparison value. Then we do the comparison 13371 -- using 64-bit arithmetic (actually long long integer), so that we 13372 -- cannot have overflow intefering with the result. 13373 13374 -- First deal with warning cases 13375 13376 if Is_Zero then 13377 case Op is 13378 13379 -- X'Length >= 0 13380 13381 when N_Op_Ge => 13382 Rewrite (N, 13383 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc))); 13384 Analyze_And_Resolve (N, Typ); 13385 Warn_On_Known_Condition (N); 13386 return; 13387 13388 -- X'Length < 0 13389 13390 when N_Op_Lt => 13391 Rewrite (N, 13392 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc))); 13393 Analyze_And_Resolve (N, Typ); 13394 Warn_On_Known_Condition (N); 13395 return; 13396 13397 when N_Op_Le => 13398 if Constant_Condition_Warnings 13399 and then Comes_From_Source (Original_Node (N)) 13400 then 13401 Error_Msg_N ("could replace by ""'=""?c?", N); 13402 end if; 13403 13404 Op := N_Op_Eq; 13405 13406 when others => 13407 null; 13408 end case; 13409 end if; 13410 13411 -- Build the First reference we will use 13412 13413 Left := 13414 Make_Attribute_Reference (Loc, 13415 Prefix => New_Occurrence_Of (Ent, Loc), 13416 Attribute_Name => Name_First); 13417 13418 if Present (Index) then 13419 Set_Expressions (Left, New_List (New_Copy (Index))); 13420 end if; 13421 13422 -- If general value case, then do the addition of (n - 1), and 13423 -- also add the needed conversions to type Long_Long_Integer. 13424 13425 if Present (Comp) then 13426 Left := 13427 Make_Op_Add (Loc, 13428 Left_Opnd => Prepare_64 (Left), 13429 Right_Opnd => 13430 Make_Op_Subtract (Loc, 13431 Left_Opnd => Prepare_64 (Comp), 13432 Right_Opnd => Make_Integer_Literal (Loc, 1))); 13433 end if; 13434 13435 -- Build the Last reference we will use 13436 13437 Right := 13438 Make_Attribute_Reference (Loc, 13439 Prefix => New_Occurrence_Of (Ent, Loc), 13440 Attribute_Name => Name_Last); 13441 13442 if Present (Index) then 13443 Set_Expressions (Right, New_List (New_Copy (Index))); 13444 end if; 13445 13446 -- If general operand, convert Last reference to Long_Long_Integer 13447 13448 if Present (Comp) then 13449 Right := Prepare_64 (Right); 13450 end if; 13451 13452 -- Check for cases to optimize 13453 13454 -- X'Length = 0 => X'First > X'Last 13455 -- X'Length < 1 => X'First > X'Last 13456 -- X'Length < n => X'First + (n - 1) > X'Last 13457 13458 if (Is_Zero and then Op = N_Op_Eq) 13459 or else (not Is_Zero and then Op = N_Op_Lt) 13460 then 13461 Result := 13462 Make_Op_Gt (Loc, 13463 Left_Opnd => Left, 13464 Right_Opnd => Right); 13465 13466 -- X'Length = 1 => X'First = X'Last 13467 -- X'Length = n => X'First + (n - 1) = X'Last 13468 13469 elsif not Is_Zero and then Op = N_Op_Eq then 13470 Result := 13471 Make_Op_Eq (Loc, 13472 Left_Opnd => Left, 13473 Right_Opnd => Right); 13474 13475 -- X'Length /= 0 => X'First <= X'Last 13476 -- X'Length > 0 => X'First <= X'Last 13477 13478 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then 13479 Result := 13480 Make_Op_Le (Loc, 13481 Left_Opnd => Left, 13482 Right_Opnd => Right); 13483 13484 -- X'Length /= 1 => X'First /= X'Last 13485 -- X'Length /= n => X'First + (n - 1) /= X'Last 13486 13487 elsif not Is_Zero and then Op = N_Op_Ne then 13488 Result := 13489 Make_Op_Ne (Loc, 13490 Left_Opnd => Left, 13491 Right_Opnd => Right); 13492 13493 -- X'Length >= 1 => X'First <= X'Last 13494 -- X'Length >= n => X'First + (n - 1) <= X'Last 13495 13496 elsif not Is_Zero and then Op = N_Op_Ge then 13497 Result := 13498 Make_Op_Le (Loc, 13499 Left_Opnd => Left, 13500 Right_Opnd => Right); 13501 13502 -- X'Length > 1 => X'First < X'Last 13503 -- X'Length > n => X'First + (n = 1) < X'Last 13504 13505 elsif not Is_Zero and then Op = N_Op_Gt then 13506 Result := 13507 Make_Op_Lt (Loc, 13508 Left_Opnd => Left, 13509 Right_Opnd => Right); 13510 13511 -- X'Length <= 1 => X'First >= X'Last 13512 -- X'Length <= n => X'First + (n - 1) >= X'Last 13513 13514 elsif not Is_Zero and then Op = N_Op_Le then 13515 Result := 13516 Make_Op_Ge (Loc, 13517 Left_Opnd => Left, 13518 Right_Opnd => Right); 13519 13520 -- Should not happen at this stage 13521 13522 else 13523 raise Program_Error; 13524 end if; 13525 13526 -- Rewrite and finish up 13527 13528 Rewrite (N, Result); 13529 Analyze_And_Resolve (N, Typ); 13530 return; 13531 end Optimize_Length_Comparison; 13532 13533 -------------------------------- 13534 -- Process_If_Case_Statements -- 13535 -------------------------------- 13536 13537 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is 13538 Decl : Node_Id; 13539 13540 begin 13541 Decl := First (Stmts); 13542 while Present (Decl) loop 13543 if Nkind (Decl) = N_Object_Declaration 13544 and then Is_Finalizable_Transient (Decl, N) 13545 then 13546 Process_Transient_In_Expression (Decl, N, Stmts); 13547 end if; 13548 13549 Next (Decl); 13550 end loop; 13551 end Process_If_Case_Statements; 13552 13553 ------------------------------------- 13554 -- Process_Transient_In_Expression -- 13555 ------------------------------------- 13556 13557 procedure Process_Transient_In_Expression 13558 (Obj_Decl : Node_Id; 13559 Expr : Node_Id; 13560 Stmts : List_Id) 13561 is 13562 Loc : constant Source_Ptr := Sloc (Obj_Decl); 13563 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); 13564 13565 Hook_Context : constant Node_Id := Find_Hook_Context (Expr); 13566 -- The node on which to insert the hook as an action. This is usually 13567 -- the innermost enclosing non-transient construct. 13568 13569 Fin_Call : Node_Id; 13570 Hook_Assign : Node_Id; 13571 Hook_Clear : Node_Id; 13572 Hook_Decl : Node_Id; 13573 Hook_Insert : Node_Id; 13574 Ptr_Decl : Node_Id; 13575 13576 Fin_Context : Node_Id; 13577 -- The node after which to insert the finalization actions of the 13578 -- transient object. 13579 13580 begin 13581 pragma Assert (Nkind_In (Expr, N_Case_Expression, 13582 N_Expression_With_Actions, 13583 N_If_Expression)); 13584 13585 -- When the context is a Boolean evaluation, all three nodes capture the 13586 -- result of their computation in a local temporary: 13587 13588 -- do 13589 -- Trans_Id : Ctrl_Typ := ...; 13590 -- Result : constant Boolean := ... Trans_Id ...; 13591 -- <finalize Trans_Id> 13592 -- in Result end; 13593 13594 -- As a result, the finalization of any transient objects can safely 13595 -- take place after the result capture. 13596 13597 -- ??? could this be extended to elementary types? 13598 13599 if Is_Boolean_Type (Etype (Expr)) then 13600 Fin_Context := Last (Stmts); 13601 13602 -- Otherwise the immediate context may not be safe enough to carry 13603 -- out transient object finalization due to aliasing and nesting of 13604 -- constructs. Insert calls to [Deep_]Finalize after the innermost 13605 -- enclosing non-transient construct. 13606 13607 else 13608 Fin_Context := Hook_Context; 13609 end if; 13610 13611 -- Mark the transient object as successfully processed to avoid double 13612 -- finalization. 13613 13614 Set_Is_Finalized_Transient (Obj_Id); 13615 13616 -- Construct all the pieces necessary to hook and finalize a transient 13617 -- object. 13618 13619 Build_Transient_Object_Statements 13620 (Obj_Decl => Obj_Decl, 13621 Fin_Call => Fin_Call, 13622 Hook_Assign => Hook_Assign, 13623 Hook_Clear => Hook_Clear, 13624 Hook_Decl => Hook_Decl, 13625 Ptr_Decl => Ptr_Decl, 13626 Finalize_Obj => False); 13627 13628 -- Add the access type which provides a reference to the transient 13629 -- object. Generate: 13630 13631 -- type Ptr_Typ is access all Desig_Typ; 13632 13633 Insert_Action (Hook_Context, Ptr_Decl); 13634 13635 -- Add the temporary which acts as a hook to the transient object. 13636 -- Generate: 13637 13638 -- Hook : Ptr_Id := null; 13639 13640 Insert_Action (Hook_Context, Hook_Decl); 13641 13642 -- When the transient object is initialized by an aggregate, the hook 13643 -- must capture the object after the last aggregate assignment takes 13644 -- place. Only then is the object considered initialized. Generate: 13645 13646 -- Hook := Ptr_Typ (Obj_Id); 13647 -- <or> 13648 -- Hook := Obj_Id'Unrestricted_Access; 13649 13650 if Ekind_In (Obj_Id, E_Constant, E_Variable) 13651 and then Present (Last_Aggregate_Assignment (Obj_Id)) 13652 then 13653 Hook_Insert := Last_Aggregate_Assignment (Obj_Id); 13654 13655 -- Otherwise the hook seizes the related object immediately 13656 13657 else 13658 Hook_Insert := Obj_Decl; 13659 end if; 13660 13661 Insert_After_And_Analyze (Hook_Insert, Hook_Assign); 13662 13663 -- When the node is part of a return statement, there is no need to 13664 -- insert a finalization call, as the general finalization mechanism 13665 -- (see Build_Finalizer) would take care of the transient object on 13666 -- subprogram exit. Note that it would also be impossible to insert the 13667 -- finalization code after the return statement as this will render it 13668 -- unreachable. 13669 13670 if Nkind (Fin_Context) = N_Simple_Return_Statement then 13671 null; 13672 13673 -- Finalize the hook after the context has been evaluated. Generate: 13674 13675 -- if Hook /= null then 13676 -- [Deep_]Finalize (Hook.all); 13677 -- Hook := null; 13678 -- end if; 13679 13680 else 13681 Insert_Action_After (Fin_Context, 13682 Make_Implicit_If_Statement (Obj_Decl, 13683 Condition => 13684 Make_Op_Ne (Loc, 13685 Left_Opnd => 13686 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc), 13687 Right_Opnd => Make_Null (Loc)), 13688 13689 Then_Statements => New_List ( 13690 Fin_Call, 13691 Hook_Clear))); 13692 end if; 13693 end Process_Transient_In_Expression; 13694 13695 ------------------------ 13696 -- Rewrite_Comparison -- 13697 ------------------------ 13698 13699 procedure Rewrite_Comparison (N : Node_Id) is 13700 Typ : constant Entity_Id := Etype (N); 13701 13702 False_Result : Boolean; 13703 True_Result : Boolean; 13704 13705 begin 13706 if Nkind (N) = N_Type_Conversion then 13707 Rewrite_Comparison (Expression (N)); 13708 return; 13709 13710 elsif Nkind (N) not in N_Op_Compare then 13711 return; 13712 end if; 13713 13714 -- Determine the potential outcome of the comparison assuming that the 13715 -- operands are valid and emit a warning when the comparison evaluates 13716 -- to True or False only in the presence of invalid values. 13717 13718 Warn_On_Constant_Valid_Condition (N); 13719 13720 -- Determine the potential outcome of the comparison assuming that the 13721 -- operands are not valid. 13722 13723 Test_Comparison 13724 (Op => N, 13725 Assume_Valid => False, 13726 True_Result => True_Result, 13727 False_Result => False_Result); 13728 13729 -- The outcome is a decisive False or True, rewrite the operator 13730 13731 if False_Result or True_Result then 13732 Rewrite (N, 13733 Convert_To (Typ, 13734 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N)))); 13735 13736 Analyze_And_Resolve (N, Typ); 13737 Warn_On_Known_Condition (N); 13738 end if; 13739 end Rewrite_Comparison; 13740 13741 ---------------------------- 13742 -- Safe_In_Place_Array_Op -- 13743 ---------------------------- 13744 13745 function Safe_In_Place_Array_Op 13746 (Lhs : Node_Id; 13747 Op1 : Node_Id; 13748 Op2 : Node_Id) return Boolean 13749 is 13750 Target : Entity_Id; 13751 13752 function Is_Safe_Operand (Op : Node_Id) return Boolean; 13753 -- Operand is safe if it cannot overlap part of the target of the 13754 -- operation. If the operand and the target are identical, the operand 13755 -- is safe. The operand can be empty in the case of negation. 13756 13757 function Is_Unaliased (N : Node_Id) return Boolean; 13758 -- Check that N is a stand-alone entity 13759 13760 ------------------ 13761 -- Is_Unaliased -- 13762 ------------------ 13763 13764 function Is_Unaliased (N : Node_Id) return Boolean is 13765 begin 13766 return 13767 Is_Entity_Name (N) 13768 and then No (Address_Clause (Entity (N))) 13769 and then No (Renamed_Object (Entity (N))); 13770 end Is_Unaliased; 13771 13772 --------------------- 13773 -- Is_Safe_Operand -- 13774 --------------------- 13775 13776 function Is_Safe_Operand (Op : Node_Id) return Boolean is 13777 begin 13778 if No (Op) then 13779 return True; 13780 13781 elsif Is_Entity_Name (Op) then 13782 return Is_Unaliased (Op); 13783 13784 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then 13785 return Is_Unaliased (Prefix (Op)); 13786 13787 elsif Nkind (Op) = N_Slice then 13788 return 13789 Is_Unaliased (Prefix (Op)) 13790 and then Entity (Prefix (Op)) /= Target; 13791 13792 elsif Nkind (Op) = N_Op_Not then 13793 return Is_Safe_Operand (Right_Opnd (Op)); 13794 13795 else 13796 return False; 13797 end if; 13798 end Is_Safe_Operand; 13799 13800 -- Start of processing for Safe_In_Place_Array_Op 13801 13802 begin 13803 -- Skip this processing if the component size is different from system 13804 -- storage unit (since at least for NOT this would cause problems). 13805 13806 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then 13807 return False; 13808 13809 -- Cannot do in place stuff if non-standard Boolean representation 13810 13811 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then 13812 return False; 13813 13814 elsif not Is_Unaliased (Lhs) then 13815 return False; 13816 13817 else 13818 Target := Entity (Lhs); 13819 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); 13820 end if; 13821 end Safe_In_Place_Array_Op; 13822 13823 ----------------------- 13824 -- Tagged_Membership -- 13825 ----------------------- 13826 13827 -- There are two different cases to consider depending on whether the right 13828 -- operand is a class-wide type or not. If not we just compare the actual 13829 -- tag of the left expr to the target type tag: 13830 -- 13831 -- Left_Expr.Tag = Right_Type'Tag; 13832 -- 13833 -- If it is a class-wide type we use the RT function CW_Membership which is 13834 -- usually implemented by looking in the ancestor tables contained in the 13835 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag 13836 13837 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT 13838 -- function IW_Membership which is usually implemented by looking in the 13839 -- table of abstract interface types plus the ancestor table contained in 13840 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag 13841 13842 procedure Tagged_Membership 13843 (N : Node_Id; 13844 SCIL_Node : out Node_Id; 13845 Result : out Node_Id) 13846 is 13847 Left : constant Node_Id := Left_Opnd (N); 13848 Right : constant Node_Id := Right_Opnd (N); 13849 Loc : constant Source_Ptr := Sloc (N); 13850 13851 Full_R_Typ : Entity_Id; 13852 Left_Type : Entity_Id; 13853 New_Node : Node_Id; 13854 Right_Type : Entity_Id; 13855 Obj_Tag : Node_Id; 13856 13857 begin 13858 SCIL_Node := Empty; 13859 13860 -- Handle entities from the limited view 13861 13862 Left_Type := Available_View (Etype (Left)); 13863 Right_Type := Available_View (Etype (Right)); 13864 13865 -- In the case where the type is an access type, the test is applied 13866 -- using the designated types (needed in Ada 2012 for implicit anonymous 13867 -- access conversions, for AI05-0149). 13868 13869 if Is_Access_Type (Right_Type) then 13870 Left_Type := Designated_Type (Left_Type); 13871 Right_Type := Designated_Type (Right_Type); 13872 end if; 13873 13874 if Is_Class_Wide_Type (Left_Type) then 13875 Left_Type := Root_Type (Left_Type); 13876 end if; 13877 13878 if Is_Class_Wide_Type (Right_Type) then 13879 Full_R_Typ := Underlying_Type (Root_Type (Right_Type)); 13880 else 13881 Full_R_Typ := Underlying_Type (Right_Type); 13882 end if; 13883 13884 Obj_Tag := 13885 Make_Selected_Component (Loc, 13886 Prefix => Relocate_Node (Left), 13887 Selector_Name => 13888 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc)); 13889 13890 if Is_Class_Wide_Type (Right_Type) then 13891 13892 -- No need to issue a run-time check if we statically know that the 13893 -- result of this membership test is always true. For example, 13894 -- considering the following declarations: 13895 13896 -- type Iface is interface; 13897 -- type T is tagged null record; 13898 -- type DT is new T and Iface with null record; 13899 13900 -- Obj1 : T; 13901 -- Obj2 : DT; 13902 13903 -- These membership tests are always true: 13904 13905 -- Obj1 in T'Class 13906 -- Obj2 in T'Class; 13907 -- Obj2 in Iface'Class; 13908 13909 -- We do not need to handle cases where the membership is illegal. 13910 -- For example: 13911 13912 -- Obj1 in DT'Class; -- Compile time error 13913 -- Obj1 in Iface'Class; -- Compile time error 13914 13915 if not Is_Class_Wide_Type (Left_Type) 13916 and then (Is_Ancestor (Etype (Right_Type), Left_Type, 13917 Use_Full_View => True) 13918 or else (Is_Interface (Etype (Right_Type)) 13919 and then Interface_Present_In_Ancestor 13920 (Typ => Left_Type, 13921 Iface => Etype (Right_Type)))) 13922 then 13923 Result := New_Occurrence_Of (Standard_True, Loc); 13924 return; 13925 end if; 13926 13927 -- Ada 2005 (AI-251): Class-wide applied to interfaces 13928 13929 if Is_Interface (Etype (Class_Wide_Type (Right_Type))) 13930 13931 -- Support to: "Iface_CW_Typ in Typ'Class" 13932 13933 or else Is_Interface (Left_Type) 13934 then 13935 -- Issue error if IW_Membership operation not available in a 13936 -- configurable run time setting. 13937 13938 if not RTE_Available (RE_IW_Membership) then 13939 Error_Msg_CRT 13940 ("dynamic membership test on interface types", N); 13941 Result := Empty; 13942 return; 13943 end if; 13944 13945 Result := 13946 Make_Function_Call (Loc, 13947 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), 13948 Parameter_Associations => New_List ( 13949 Make_Attribute_Reference (Loc, 13950 Prefix => Obj_Tag, 13951 Attribute_Name => Name_Address), 13952 New_Occurrence_Of ( 13953 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), 13954 Loc))); 13955 13956 -- Ada 95: Normal case 13957 13958 else 13959 Build_CW_Membership (Loc, 13960 Obj_Tag_Node => Obj_Tag, 13961 Typ_Tag_Node => 13962 New_Occurrence_Of ( 13963 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc), 13964 Related_Nod => N, 13965 New_Node => New_Node); 13966 13967 -- Generate the SCIL node for this class-wide membership test. 13968 -- Done here because the previous call to Build_CW_Membership 13969 -- relocates Obj_Tag. 13970 13971 if Generate_SCIL then 13972 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); 13973 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); 13974 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); 13975 end if; 13976 13977 Result := New_Node; 13978 end if; 13979 13980 -- Right_Type is not a class-wide type 13981 13982 else 13983 -- No need to check the tag of the object if Right_Typ is abstract 13984 13985 if Is_Abstract_Type (Right_Type) then 13986 Result := New_Occurrence_Of (Standard_False, Loc); 13987 13988 else 13989 Result := 13990 Make_Op_Eq (Loc, 13991 Left_Opnd => Obj_Tag, 13992 Right_Opnd => 13993 New_Occurrence_Of 13994 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc)); 13995 end if; 13996 end if; 13997 end Tagged_Membership; 13998 13999 ------------------------------ 14000 -- Unary_Op_Validity_Checks -- 14001 ------------------------------ 14002 14003 procedure Unary_Op_Validity_Checks (N : Node_Id) is 14004 begin 14005 if Validity_Checks_On and Validity_Check_Operands then 14006 Ensure_Valid (Right_Opnd (N)); 14007 end if; 14008 end Unary_Op_Validity_Checks; 14009 14010end Exp_Ch4; 14011