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