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; 75with Warnsw; use Warnsw; 76 77package body Exp_Ch4 is 78 79 ----------------------- 80 -- Local Subprograms -- 81 ----------------------- 82 83 procedure Binary_Op_Validity_Checks (N : Node_Id); 84 pragma Inline (Binary_Op_Validity_Checks); 85 -- Performs validity checks for a binary operator 86 87 procedure Build_Boolean_Array_Proc_Call 88 (N : Node_Id; 89 Op1 : Node_Id; 90 Op2 : Node_Id); 91 -- If a boolean array assignment can be done in place, build call to 92 -- corresponding library procedure. 93 94 procedure Displace_Allocator_Pointer (N : Node_Id); 95 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and 96 -- Expand_Allocator_Expression. Allocating class-wide interface objects 97 -- this routine displaces the pointer to the allocated object to reference 98 -- the component referencing the corresponding secondary dispatch table. 99 100 procedure Expand_Allocator_Expression (N : Node_Id); 101 -- Subsidiary to Expand_N_Allocator, for the case when the expression 102 -- is a qualified expression or an aggregate. 103 104 procedure Expand_Array_Comparison (N : Node_Id); 105 -- This routine handles expansion of the comparison operators (N_Op_Lt, 106 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic 107 -- code for these operators is similar, differing only in the details of 108 -- the actual comparison call that is made. Special processing (call a 109 -- run-time routine) 110 111 function Expand_Array_Equality 112 (Nod : Node_Id; 113 Lhs : Node_Id; 114 Rhs : Node_Id; 115 Bodies : List_Id; 116 Typ : Entity_Id) return Node_Id; 117 -- Expand an array equality into a call to a function implementing this 118 -- equality, and a call to it. Loc is the location for the generated nodes. 119 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list 120 -- on which to attach bodies of local functions that are created in the 121 -- process. It is the responsibility of the caller to insert those bodies 122 -- at the right place. Nod provides the Sloc value for the generated code. 123 -- Normally the types used for the generated equality routine are taken 124 -- from Lhs and Rhs. However, in some situations of generated code, the 125 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies 126 -- the type to be used for the formal parameters. 127 128 procedure Expand_Boolean_Operator (N : Node_Id); 129 -- Common expansion processing for Boolean operators (And, Or, Xor) for the 130 -- case of array type arguments. 131 132 procedure Expand_Nonbinary_Modular_Op (N : Node_Id); 133 -- When generating C code, convert nonbinary modular arithmetic operations 134 -- into code that relies on the front-end expansion of operator Mod. No 135 -- expansion is performed if N is not a nonbinary modular operand. 136 137 procedure Expand_Short_Circuit_Operator (N : Node_Id); 138 -- Common expansion processing for short-circuit boolean operators 139 140 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id); 141 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is 142 -- where we allow comparison of "out of range" values. 143 144 function Expand_Composite_Equality 145 (Nod : Node_Id; 146 Typ : Entity_Id; 147 Lhs : Node_Id; 148 Rhs : Node_Id; 149 Bodies : List_Id) return Node_Id; 150 -- Local recursive function used to expand equality for nested composite 151 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which 152 -- to attach bodies of local functions that are created in the process. It 153 -- is the responsibility of the caller to insert those bodies at the right 154 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are 155 -- the left and right sides for the comparison, and Typ is the type of the 156 -- objects to compare. 157 158 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); 159 -- Routine to expand concatenation of a sequence of two or more operands 160 -- (in the list Operands) and replace node Cnode with the result of the 161 -- concatenation. The operands can be of any appropriate type, and can 162 -- include both arrays and singleton elements. 163 164 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id); 165 -- N is an N_In membership test mode, with the overflow check mode set to 166 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed 167 -- integer type. This is a case where top level processing is required to 168 -- handle overflow checks in subtrees. 169 170 procedure Fixup_Universal_Fixed_Operation (N : Node_Id); 171 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal 172 -- fixed. We do not have such a type at runtime, so the purpose of this 173 -- routine is to find the real type by looking up the tree. We also 174 -- determine if the operation must be rounded. 175 176 function Has_Inferable_Discriminants (N : Node_Id) return Boolean; 177 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable 178 -- discriminants if it has a constrained nominal type, unless the object 179 -- is a component of an enclosing Unchecked_Union object that is subject 180 -- to a per-object constraint and the enclosing object lacks inferable 181 -- discriminants. 182 -- 183 -- An expression of an Unchecked_Union type has inferable discriminants 184 -- if it is either a name of an object with inferable discriminants or a 185 -- qualified expression whose subtype mark denotes a constrained subtype. 186 187 procedure Insert_Dereference_Action (N : Node_Id); 188 -- N is an expression whose type is an access. When the type of the 189 -- associated storage pool is derived from Checked_Pool, generate a 190 -- call to the 'Dereference' primitive operation. 191 192 function Make_Array_Comparison_Op 193 (Typ : Entity_Id; 194 Nod : Node_Id) return Node_Id; 195 -- Comparisons between arrays are expanded in line. This function produces 196 -- the body of the implementation of (a > b), where a and b are one- 197 -- dimensional arrays of some discrete type. The original node is then 198 -- expanded into the appropriate call to this function. Nod provides the 199 -- Sloc value for the generated code. 200 201 function Make_Boolean_Array_Op 202 (Typ : Entity_Id; 203 N : Node_Id) return Node_Id; 204 -- Boolean operations on boolean arrays are expanded in line. This function 205 -- produce the body for the node N, which is (a and b), (a or b), or (a xor 206 -- b). It is used only the normal case and not the packed case. The type 207 -- involved, Typ, is the Boolean array type, and the logical operations in 208 -- the body are simple boolean operations. Note that Typ is always a 209 -- constrained type (the caller has ensured this by using 210 -- Convert_To_Actual_Subtype if necessary). 211 212 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean; 213 -- For signed arithmetic operations when the current overflow mode is 214 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks 215 -- as the first thing we do. We then return. We count on the recursive 216 -- apparatus for overflow checks to call us back with an equivalent 217 -- operation that is in CHECKED mode, avoiding a recursive entry into this 218 -- routine, and that is when we will proceed with the expansion of the 219 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do 220 -- these optimizations without first making this check, since there may be 221 -- operands further down the tree that are relying on the recursive calls 222 -- triggered by the top level nodes to properly process overflow checking 223 -- and remaining expansion on these nodes. Note that this call back may be 224 -- skipped if the operation is done in Bignum mode but that's fine, since 225 -- the Bignum call takes care of everything. 226 227 procedure Optimize_Length_Comparison (N : Node_Id); 228 -- Given an expression, if it is of the form X'Length op N (or the other 229 -- way round), where N is known at compile time to be 0 or 1, and X is a 230 -- simple entity, and op is a comparison operator, optimizes it into a 231 -- comparison of First and Last. 232 233 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id); 234 -- Inspect and process statement list Stmt of if or case expression N for 235 -- transient objects. If such objects are found, the routine generates code 236 -- to clean them up when the context of the expression is evaluated. 237 238 procedure Process_Transient_In_Expression 239 (Obj_Decl : Node_Id; 240 Expr : Node_Id; 241 Stmts : List_Id); 242 -- Subsidiary routine to the expansion of expression_with_actions, if and 243 -- case expressions. Generate all necessary code to finalize a transient 244 -- object when the enclosing context is elaborated or evaluated. Obj_Decl 245 -- denotes the declaration of the transient object, which is usually the 246 -- result of a controlled function call. Expr denotes the expression with 247 -- actions, if expression, or case expression node. Stmts denotes the 248 -- statement list which contains Decl, either at the top level or within a 249 -- nested construct. 250 251 procedure Rewrite_Comparison (N : Node_Id); 252 -- If N is the node for a comparison whose outcome can be determined at 253 -- compile time, then the node N can be rewritten with True or False. If 254 -- the outcome cannot be determined at compile time, the call has no 255 -- effect. If N is a type conversion, then this processing is applied to 256 -- its expression. If N is neither comparison nor a type conversion, the 257 -- call has no effect. 258 259 procedure Tagged_Membership 260 (N : Node_Id; 261 SCIL_Node : out Node_Id; 262 Result : out Node_Id); 263 -- Construct the expression corresponding to the tagged membership test. 264 -- Deals with a second operand being (or not) a class-wide type. 265 266 function Safe_In_Place_Array_Op 267 (Lhs : Node_Id; 268 Op1 : Node_Id; 269 Op2 : Node_Id) return Boolean; 270 -- In the context of an assignment, where the right-hand side is a boolean 271 -- operation on arrays, check whether operation can be performed in place. 272 273 procedure Unary_Op_Validity_Checks (N : Node_Id); 274 pragma Inline (Unary_Op_Validity_Checks); 275 -- Performs validity checks for a unary operator 276 277 ------------------------------- 278 -- Binary_Op_Validity_Checks -- 279 ------------------------------- 280 281 procedure Binary_Op_Validity_Checks (N : Node_Id) is 282 begin 283 if Validity_Checks_On and Validity_Check_Operands then 284 Ensure_Valid (Left_Opnd (N)); 285 Ensure_Valid (Right_Opnd (N)); 286 end if; 287 end Binary_Op_Validity_Checks; 288 289 ------------------------------------ 290 -- Build_Boolean_Array_Proc_Call -- 291 ------------------------------------ 292 293 procedure Build_Boolean_Array_Proc_Call 294 (N : Node_Id; 295 Op1 : Node_Id; 296 Op2 : Node_Id) 297 is 298 Loc : constant Source_Ptr := Sloc (N); 299 Kind : constant Node_Kind := Nkind (Expression (N)); 300 Target : constant Node_Id := 301 Make_Attribute_Reference (Loc, 302 Prefix => Name (N), 303 Attribute_Name => Name_Address); 304 305 Arg1 : Node_Id := Op1; 306 Arg2 : Node_Id := Op2; 307 Call_Node : Node_Id; 308 Proc_Name : Entity_Id; 309 310 begin 311 if Kind = N_Op_Not then 312 if Nkind (Op1) in N_Binary_Op then 313 314 -- Use negated version of the binary operators 315 316 if Nkind (Op1) = N_Op_And then 317 Proc_Name := RTE (RE_Vector_Nand); 318 319 elsif Nkind (Op1) = N_Op_Or then 320 Proc_Name := RTE (RE_Vector_Nor); 321 322 else pragma Assert (Nkind (Op1) = N_Op_Xor); 323 Proc_Name := RTE (RE_Vector_Xor); 324 end if; 325 326 Call_Node := 327 Make_Procedure_Call_Statement (Loc, 328 Name => New_Occurrence_Of (Proc_Name, Loc), 329 330 Parameter_Associations => New_List ( 331 Target, 332 Make_Attribute_Reference (Loc, 333 Prefix => Left_Opnd (Op1), 334 Attribute_Name => Name_Address), 335 336 Make_Attribute_Reference (Loc, 337 Prefix => Right_Opnd (Op1), 338 Attribute_Name => Name_Address), 339 340 Make_Attribute_Reference (Loc, 341 Prefix => Left_Opnd (Op1), 342 Attribute_Name => Name_Length))); 343 344 else 345 Proc_Name := RTE (RE_Vector_Not); 346 347 Call_Node := 348 Make_Procedure_Call_Statement (Loc, 349 Name => New_Occurrence_Of (Proc_Name, Loc), 350 Parameter_Associations => New_List ( 351 Target, 352 353 Make_Attribute_Reference (Loc, 354 Prefix => Op1, 355 Attribute_Name => Name_Address), 356 357 Make_Attribute_Reference (Loc, 358 Prefix => Op1, 359 Attribute_Name => Name_Length))); 360 end if; 361 362 else 363 -- We use the following equivalences: 364 365 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) 366 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) 367 -- (not X) xor (not Y) = X xor Y 368 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) 369 370 if Nkind (Op1) = N_Op_Not then 371 Arg1 := Right_Opnd (Op1); 372 Arg2 := Right_Opnd (Op2); 373 374 if Kind = N_Op_And then 375 Proc_Name := RTE (RE_Vector_Nor); 376 elsif Kind = N_Op_Or then 377 Proc_Name := RTE (RE_Vector_Nand); 378 else 379 Proc_Name := RTE (RE_Vector_Xor); 380 end if; 381 382 else 383 if Kind = N_Op_And then 384 Proc_Name := RTE (RE_Vector_And); 385 elsif Kind = N_Op_Or then 386 Proc_Name := RTE (RE_Vector_Or); 387 elsif Nkind (Op2) = N_Op_Not then 388 Proc_Name := RTE (RE_Vector_Nxor); 389 Arg2 := Right_Opnd (Op2); 390 else 391 Proc_Name := RTE (RE_Vector_Xor); 392 end if; 393 end if; 394 395 Call_Node := 396 Make_Procedure_Call_Statement (Loc, 397 Name => New_Occurrence_Of (Proc_Name, Loc), 398 Parameter_Associations => New_List ( 399 Target, 400 Make_Attribute_Reference (Loc, 401 Prefix => Arg1, 402 Attribute_Name => Name_Address), 403 Make_Attribute_Reference (Loc, 404 Prefix => Arg2, 405 Attribute_Name => Name_Address), 406 Make_Attribute_Reference (Loc, 407 Prefix => Arg1, 408 Attribute_Name => Name_Length))); 409 end if; 410 411 Rewrite (N, Call_Node); 412 Analyze (N); 413 414 exception 415 when RE_Not_Available => 416 return; 417 end Build_Boolean_Array_Proc_Call; 418 419 ----------------------- 420 -- Build_Eq_Call -- 421 ----------------------- 422 423 function Build_Eq_Call 424 (Typ : Entity_Id; 425 Loc : Source_Ptr; 426 Lhs : Node_Id; 427 Rhs : Node_Id) return Node_Id 428 is 429 Prim : Node_Id; 430 Prim_E : Elmt_Id; 431 432 begin 433 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); 434 while Present (Prim_E) loop 435 Prim := Node (Prim_E); 436 437 -- Locate primitive equality with the right signature 438 439 if Chars (Prim) = Name_Op_Eq 440 and then Etype (First_Formal (Prim)) = 441 Etype (Next_Formal (First_Formal (Prim))) 442 and then Etype (Prim) = Standard_Boolean 443 then 444 if Is_Abstract_Subprogram (Prim) then 445 return 446 Make_Raise_Program_Error (Loc, 447 Reason => PE_Explicit_Raise); 448 449 else 450 return 451 Make_Function_Call (Loc, 452 Name => New_Occurrence_Of (Prim, Loc), 453 Parameter_Associations => New_List (Lhs, Rhs)); 454 end if; 455 end if; 456 457 Next_Elmt (Prim_E); 458 end loop; 459 460 -- If not found, predefined operation will be used 461 462 return Empty; 463 end Build_Eq_Call; 464 465 -------------------------------- 466 -- Displace_Allocator_Pointer -- 467 -------------------------------- 468 469 procedure Displace_Allocator_Pointer (N : Node_Id) is 470 Loc : constant Source_Ptr := Sloc (N); 471 Orig_Node : constant Node_Id := Original_Node (N); 472 Dtyp : Entity_Id; 473 Etyp : Entity_Id; 474 PtrT : Entity_Id; 475 476 begin 477 -- Do nothing in case of VM targets: the virtual machine will handle 478 -- interfaces directly. 479 480 if not Tagged_Type_Expansion then 481 return; 482 end if; 483 484 pragma Assert (Nkind (N) = N_Identifier 485 and then Nkind (Orig_Node) = N_Allocator); 486 487 PtrT := Etype (Orig_Node); 488 Dtyp := Available_View (Designated_Type (PtrT)); 489 Etyp := Etype (Expression (Orig_Node)); 490 491 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then 492 493 -- If the type of the allocator expression is not an interface type 494 -- we can generate code to reference the record component containing 495 -- the pointer to the secondary dispatch table. 496 497 if not Is_Interface (Etyp) then 498 declare 499 Saved_Typ : constant Entity_Id := Etype (Orig_Node); 500 501 begin 502 -- 1) Get access to the allocated object 503 504 Rewrite (N, 505 Make_Explicit_Dereference (Loc, Relocate_Node (N))); 506 Set_Etype (N, Etyp); 507 Set_Analyzed (N); 508 509 -- 2) Add the conversion to displace the pointer to reference 510 -- the secondary dispatch table. 511 512 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N))); 513 Analyze_And_Resolve (N, Dtyp); 514 515 -- 3) The 'access to the secondary dispatch table will be used 516 -- as the value returned by the allocator. 517 518 Rewrite (N, 519 Make_Attribute_Reference (Loc, 520 Prefix => Relocate_Node (N), 521 Attribute_Name => Name_Access)); 522 Set_Etype (N, Saved_Typ); 523 Set_Analyzed (N); 524 end; 525 526 -- If the type of the allocator expression is an interface type we 527 -- generate a run-time call to displace "this" to reference the 528 -- component containing the pointer to the secondary dispatch table 529 -- or else raise Constraint_Error if the actual object does not 530 -- implement the target interface. This case corresponds to the 531 -- following example: 532 533 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is 534 -- begin 535 -- return new Iface_2'Class'(Obj); 536 -- end Op; 537 538 else 539 Rewrite (N, 540 Unchecked_Convert_To (PtrT, 541 Make_Function_Call (Loc, 542 Name => New_Occurrence_Of (RTE (RE_Displace), Loc), 543 Parameter_Associations => New_List ( 544 Unchecked_Convert_To (RTE (RE_Address), 545 Relocate_Node (N)), 546 547 New_Occurrence_Of 548 (Elists.Node 549 (First_Elmt 550 (Access_Disp_Table (Etype (Base_Type (Dtyp))))), 551 Loc))))); 552 Analyze_And_Resolve (N, PtrT); 553 end if; 554 end if; 555 end Displace_Allocator_Pointer; 556 557 --------------------------------- 558 -- Expand_Allocator_Expression -- 559 --------------------------------- 560 561 procedure Expand_Allocator_Expression (N : Node_Id) is 562 Loc : constant Source_Ptr := Sloc (N); 563 Exp : constant Node_Id := Expression (Expression (N)); 564 PtrT : constant Entity_Id := Etype (N); 565 DesigT : constant Entity_Id := Designated_Type (PtrT); 566 567 procedure Apply_Accessibility_Check 568 (Ref : Node_Id; 569 Built_In_Place : Boolean := False); 570 -- Ada 2005 (AI-344): For an allocator with a class-wide designated 571 -- type, generate an accessibility check to verify that the level of the 572 -- type of the created object is not deeper than the level of the access 573 -- type. If the type of the qualified expression is class-wide, then 574 -- always generate the check (except in the case where it is known to be 575 -- unnecessary, see comment below). Otherwise, only generate the check 576 -- if the level of the qualified expression type is statically deeper 577 -- than the access type. 578 -- 579 -- Although the static accessibility will generally have been performed 580 -- as a legality check, it won't have been done in cases where the 581 -- allocator appears in generic body, so a run-time check is needed in 582 -- general. One special case is when the access type is declared in the 583 -- same scope as the class-wide allocator, in which case the check can 584 -- never fail, so it need not be generated. 585 -- 586 -- As an open issue, there seem to be cases where the static level 587 -- associated with the class-wide object's underlying type is not 588 -- sufficient to perform the proper accessibility check, such as for 589 -- allocators in nested subprograms or accept statements initialized by 590 -- class-wide formals when the actual originates outside at a deeper 591 -- static level. The nested subprogram case might require passing 592 -- accessibility levels along with class-wide parameters, and the task 593 -- case seems to be an actual gap in the language rules that needs to 594 -- be fixed by the ARG. ??? 595 596 ------------------------------- 597 -- Apply_Accessibility_Check -- 598 ------------------------------- 599 600 procedure Apply_Accessibility_Check 601 (Ref : Node_Id; 602 Built_In_Place : Boolean := False) 603 is 604 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); 605 Cond : Node_Id; 606 Fin_Call : Node_Id; 607 Free_Stmt : Node_Id; 608 Obj_Ref : Node_Id; 609 Stmts : List_Id; 610 611 begin 612 if Ada_Version >= Ada_2005 613 and then Is_Class_Wide_Type (DesigT) 614 and then Tagged_Type_Expansion 615 and then not Scope_Suppress.Suppress (Accessibility_Check) 616 and then 617 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) 618 or else 619 (Is_Class_Wide_Type (Etype (Exp)) 620 and then Scope (PtrT) /= Current_Scope)) 621 then 622 -- If the allocator was built in place, Ref is already a reference 623 -- to the access object initialized to the result of the allocator 624 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call 625 -- Remove_Side_Effects for cases where the build-in-place call may 626 -- still be the prefix of the reference (to avoid generating 627 -- duplicate calls). Otherwise, it is the entity associated with 628 -- the object containing the address of the allocated object. 629 630 if Built_In_Place then 631 Remove_Side_Effects (Ref); 632 Obj_Ref := New_Copy_Tree (Ref); 633 else 634 Obj_Ref := New_Occurrence_Of (Ref, Loc); 635 end if; 636 637 -- For access to interface types we must generate code to displace 638 -- the pointer to the base of the object since the subsequent code 639 -- references components located in the TSD of the object (which 640 -- is associated with the primary dispatch table --see a-tags.ads) 641 -- and also generates code invoking Free, which requires also a 642 -- reference to the base of the unallocated object. 643 644 if Is_Interface (DesigT) and then Tagged_Type_Expansion then 645 Obj_Ref := 646 Unchecked_Convert_To (Etype (Obj_Ref), 647 Make_Function_Call (Loc, 648 Name => 649 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 650 Parameter_Associations => New_List ( 651 Unchecked_Convert_To (RTE (RE_Address), 652 New_Copy_Tree (Obj_Ref))))); 653 end if; 654 655 -- Step 1: Create the object clean up code 656 657 Stmts := New_List; 658 659 -- Deallocate the object if the accessibility check fails. This 660 -- is done only on targets or profiles that support deallocation. 661 662 -- Free (Obj_Ref); 663 664 if RTE_Available (RE_Free) then 665 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref)); 666 Set_Storage_Pool (Free_Stmt, Pool_Id); 667 668 Append_To (Stmts, Free_Stmt); 669 670 -- The target or profile cannot deallocate objects 671 672 else 673 Free_Stmt := Empty; 674 end if; 675 676 -- Finalize the object if applicable. Generate: 677 678 -- [Deep_]Finalize (Obj_Ref.all); 679 680 if Needs_Finalization (DesigT) 681 and then not No_Heap_Finalization (PtrT) 682 then 683 Fin_Call := 684 Make_Final_Call 685 (Obj_Ref => 686 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), 687 Typ => DesigT); 688 689 -- Guard against a missing [Deep_]Finalize when the designated 690 -- type was not properly frozen. 691 692 if No (Fin_Call) then 693 Fin_Call := Make_Null_Statement (Loc); 694 end if; 695 696 -- When the target or profile supports deallocation, wrap the 697 -- finalization call in a block to ensure proper deallocation 698 -- even if finalization fails. Generate: 699 700 -- begin 701 -- <Fin_Call> 702 -- exception 703 -- when others => 704 -- <Free_Stmt> 705 -- raise; 706 -- end; 707 708 if Present (Free_Stmt) then 709 Fin_Call := 710 Make_Block_Statement (Loc, 711 Handled_Statement_Sequence => 712 Make_Handled_Sequence_Of_Statements (Loc, 713 Statements => New_List (Fin_Call), 714 715 Exception_Handlers => New_List ( 716 Make_Exception_Handler (Loc, 717 Exception_Choices => New_List ( 718 Make_Others_Choice (Loc)), 719 Statements => New_List ( 720 New_Copy_Tree (Free_Stmt), 721 Make_Raise_Statement (Loc)))))); 722 end if; 723 724 Prepend_To (Stmts, Fin_Call); 725 end if; 726 727 -- Signal the accessibility failure through a Program_Error 728 729 Append_To (Stmts, 730 Make_Raise_Program_Error (Loc, 731 Condition => New_Occurrence_Of (Standard_True, Loc), 732 Reason => PE_Accessibility_Check_Failed)); 733 734 -- Step 2: Create the accessibility comparison 735 736 -- Generate: 737 -- Ref'Tag 738 739 Obj_Ref := 740 Make_Attribute_Reference (Loc, 741 Prefix => Obj_Ref, 742 Attribute_Name => Name_Tag); 743 744 -- For tagged types, determine the accessibility level by looking 745 -- at the type specific data of the dispatch table. Generate: 746 747 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level 748 749 if Tagged_Type_Expansion then 750 Cond := Build_Get_Access_Level (Loc, Obj_Ref); 751 752 -- Use a runtime call to determine the accessibility level when 753 -- compiling on virtual machine targets. Generate: 754 755 -- Get_Access_Level (Ref'Tag) 756 757 else 758 Cond := 759 Make_Function_Call (Loc, 760 Name => 761 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc), 762 Parameter_Associations => New_List (Obj_Ref)); 763 end if; 764 765 Cond := 766 Make_Op_Gt (Loc, 767 Left_Opnd => Cond, 768 Right_Opnd => 769 Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); 770 771 -- Due to the complexity and side effects of the check, utilize an 772 -- if statement instead of the regular Program_Error circuitry. 773 774 Insert_Action (N, 775 Make_Implicit_If_Statement (N, 776 Condition => Cond, 777 Then_Statements => Stmts)); 778 end if; 779 end Apply_Accessibility_Check; 780 781 -- Local variables 782 783 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); 784 Indic : constant Node_Id := Subtype_Mark (Expression (N)); 785 T : constant Entity_Id := Entity (Indic); 786 Adj_Call : Node_Id; 787 Node : Node_Id; 788 Tag_Assign : Node_Id; 789 Temp : Entity_Id; 790 Temp_Decl : Node_Id; 791 792 TagT : Entity_Id := Empty; 793 -- Type used as source for tag assignment 794 795 TagR : Node_Id := Empty; 796 -- Target reference for tag assignment 797 798 -- Start of processing for Expand_Allocator_Expression 799 800 begin 801 -- Handle call to C++ constructor 802 803 if Is_CPP_Constructor_Call (Exp) then 804 Make_CPP_Constructor_Call_In_Allocator 805 (Allocator => N, 806 Function_Call => Exp); 807 return; 808 end if; 809 810 -- In the case of an Ada 2012 allocator whose initial value comes from a 811 -- function call, pass "the accessibility level determined by the point 812 -- of call" (AI05-0234) to the function. Conceptually, this belongs in 813 -- Expand_Call but it couldn't be done there (because the Etype of the 814 -- allocator wasn't set then) so we generate the parameter here. See 815 -- the Boolean variable Defer in (a block within) Expand_Call. 816 817 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then 818 declare 819 Subp : Entity_Id; 820 821 begin 822 if Nkind (Name (Exp)) = N_Explicit_Dereference then 823 Subp := Designated_Type (Etype (Prefix (Name (Exp)))); 824 else 825 Subp := Entity (Name (Exp)); 826 end if; 827 828 Subp := Ultimate_Alias (Subp); 829 830 if Present (Extra_Accessibility_Of_Result (Subp)) then 831 Add_Extra_Actual_To_Call 832 (Subprogram_Call => Exp, 833 Extra_Formal => Extra_Accessibility_Of_Result (Subp), 834 Extra_Actual => Dynamic_Accessibility_Level (PtrT)); 835 end if; 836 end; 837 end if; 838 839 -- Case of tagged type or type requiring finalization 840 841 if Is_Tagged_Type (T) or else Needs_Finalization (T) then 842 843 -- Ada 2005 (AI-318-02): If the initialization expression is a call 844 -- to a build-in-place function, then access to the allocated object 845 -- must be passed to the function. 846 847 if Is_Build_In_Place_Function_Call (Exp) then 848 Make_Build_In_Place_Call_In_Allocator (N, Exp); 849 Apply_Accessibility_Check (N, Built_In_Place => True); 850 return; 851 852 -- Ada 2005 (AI-318-02): Specialization of the previous case for 853 -- expressions containing a build-in-place function call whose 854 -- returned object covers interface types, and Expr has calls to 855 -- Ada.Tags.Displace to displace the pointer to the returned build- 856 -- in-place object to reference the secondary dispatch table of a 857 -- covered interface type. 858 859 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then 860 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp); 861 Apply_Accessibility_Check (N, Built_In_Place => True); 862 return; 863 end if; 864 865 -- Actions inserted before: 866 -- Temp : constant ptr_T := new T'(Expression); 867 -- Temp._tag = T'tag; -- when not class-wide 868 -- [Deep_]Adjust (Temp.all); 869 870 -- We analyze by hand the new internal allocator to avoid any 871 -- recursion and inappropriate call to Initialize. 872 873 -- We don't want to remove side effects when the expression must be 874 -- built in place. In the case of a build-in-place function call, 875 -- that could lead to a duplication of the call, which was already 876 -- substituted for the allocator. 877 878 if not Aggr_In_Place then 879 Remove_Side_Effects (Exp); 880 end if; 881 882 Temp := Make_Temporary (Loc, 'P', N); 883 884 -- For a class wide allocation generate the following code: 885 886 -- type Equiv_Record is record ... end record; 887 -- implicit subtype CW is <Class_Wide_Subytpe>; 888 -- temp : PtrT := new CW'(CW!(expr)); 889 890 if Is_Class_Wide_Type (T) then 891 Expand_Subtype_From_Expr (Empty, T, Indic, Exp); 892 893 -- Ada 2005 (AI-251): If the expression is a class-wide interface 894 -- object we generate code to move up "this" to reference the 895 -- base of the object before allocating the new object. 896 897 -- Note that Exp'Address is recursively expanded into a call 898 -- to Base_Address (Exp.Tag) 899 900 if Is_Class_Wide_Type (Etype (Exp)) 901 and then Is_Interface (Etype (Exp)) 902 and then Tagged_Type_Expansion 903 then 904 Set_Expression 905 (Expression (N), 906 Unchecked_Convert_To (Entity (Indic), 907 Make_Explicit_Dereference (Loc, 908 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 909 Make_Attribute_Reference (Loc, 910 Prefix => Exp, 911 Attribute_Name => Name_Address))))); 912 else 913 Set_Expression 914 (Expression (N), 915 Unchecked_Convert_To (Entity (Indic), Exp)); 916 end if; 917 918 Analyze_And_Resolve (Expression (N), Entity (Indic)); 919 end if; 920 921 -- Processing for allocators returning non-interface types 922 923 if not Is_Interface (Directly_Designated_Type (PtrT)) then 924 if Aggr_In_Place then 925 Temp_Decl := 926 Make_Object_Declaration (Loc, 927 Defining_Identifier => Temp, 928 Object_Definition => New_Occurrence_Of (PtrT, Loc), 929 Expression => 930 Make_Allocator (Loc, 931 Expression => 932 New_Occurrence_Of (Etype (Exp), Loc))); 933 934 -- Copy the Comes_From_Source flag for the allocator we just 935 -- built, since logically this allocator is a replacement of 936 -- the original allocator node. This is for proper handling of 937 -- restriction No_Implicit_Heap_Allocations. 938 939 Set_Comes_From_Source 940 (Expression (Temp_Decl), Comes_From_Source (N)); 941 942 Set_No_Initialization (Expression (Temp_Decl)); 943 Insert_Action (N, Temp_Decl); 944 945 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 946 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 947 948 else 949 Node := Relocate_Node (N); 950 Set_Analyzed (Node); 951 952 Temp_Decl := 953 Make_Object_Declaration (Loc, 954 Defining_Identifier => Temp, 955 Constant_Present => True, 956 Object_Definition => New_Occurrence_Of (PtrT, Loc), 957 Expression => Node); 958 959 Insert_Action (N, Temp_Decl); 960 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 961 end if; 962 963 -- Ada 2005 (AI-251): Handle allocators whose designated type is an 964 -- interface type. In this case we use the type of the qualified 965 -- expression to allocate the object. 966 967 else 968 declare 969 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 970 New_Decl : Node_Id; 971 972 begin 973 New_Decl := 974 Make_Full_Type_Declaration (Loc, 975 Defining_Identifier => Def_Id, 976 Type_Definition => 977 Make_Access_To_Object_Definition (Loc, 978 All_Present => True, 979 Null_Exclusion_Present => False, 980 Constant_Present => 981 Is_Access_Constant (Etype (N)), 982 Subtype_Indication => 983 New_Occurrence_Of (Etype (Exp), Loc))); 984 985 Insert_Action (N, New_Decl); 986 987 -- Inherit the allocation-related attributes from the original 988 -- access type. 989 990 Set_Finalization_Master 991 (Def_Id, Finalization_Master (PtrT)); 992 993 Set_Associated_Storage_Pool 994 (Def_Id, Associated_Storage_Pool (PtrT)); 995 996 -- Declare the object using the previous type declaration 997 998 if Aggr_In_Place then 999 Temp_Decl := 1000 Make_Object_Declaration (Loc, 1001 Defining_Identifier => Temp, 1002 Object_Definition => New_Occurrence_Of (Def_Id, Loc), 1003 Expression => 1004 Make_Allocator (Loc, 1005 New_Occurrence_Of (Etype (Exp), Loc))); 1006 1007 -- Copy the Comes_From_Source flag for the allocator we just 1008 -- built, since logically this allocator is a replacement of 1009 -- the original allocator node. This is for proper handling 1010 -- of restriction No_Implicit_Heap_Allocations. 1011 1012 Set_Comes_From_Source 1013 (Expression (Temp_Decl), Comes_From_Source (N)); 1014 1015 Set_No_Initialization (Expression (Temp_Decl)); 1016 Insert_Action (N, Temp_Decl); 1017 1018 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1019 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1020 1021 else 1022 Node := Relocate_Node (N); 1023 Set_Analyzed (Node); 1024 1025 Temp_Decl := 1026 Make_Object_Declaration (Loc, 1027 Defining_Identifier => Temp, 1028 Constant_Present => True, 1029 Object_Definition => New_Occurrence_Of (Def_Id, Loc), 1030 Expression => Node); 1031 1032 Insert_Action (N, Temp_Decl); 1033 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1034 end if; 1035 1036 -- Generate an additional object containing the address of the 1037 -- returned object. The type of this second object declaration 1038 -- is the correct type required for the common processing that 1039 -- is still performed by this subprogram. The displacement of 1040 -- this pointer to reference the component associated with the 1041 -- interface type will be done at the end of common processing. 1042 1043 New_Decl := 1044 Make_Object_Declaration (Loc, 1045 Defining_Identifier => Make_Temporary (Loc, 'P'), 1046 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1047 Expression => 1048 Unchecked_Convert_To (PtrT, 1049 New_Occurrence_Of (Temp, Loc))); 1050 1051 Insert_Action (N, New_Decl); 1052 1053 Temp_Decl := New_Decl; 1054 Temp := Defining_Identifier (New_Decl); 1055 end; 1056 end if; 1057 1058 -- Generate the tag assignment 1059 1060 -- Suppress the tag assignment for VM targets because VM tags are 1061 -- represented implicitly in objects. 1062 1063 if not Tagged_Type_Expansion then 1064 null; 1065 1066 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide 1067 -- interface objects because in this case the tag does not change. 1068 1069 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then 1070 pragma Assert (Is_Class_Wide_Type 1071 (Directly_Designated_Type (Etype (N)))); 1072 null; 1073 1074 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then 1075 TagT := T; 1076 TagR := New_Occurrence_Of (Temp, Loc); 1077 1078 elsif Is_Private_Type (T) 1079 and then Is_Tagged_Type (Underlying_Type (T)) 1080 then 1081 TagT := Underlying_Type (T); 1082 TagR := 1083 Unchecked_Convert_To (Underlying_Type (T), 1084 Make_Explicit_Dereference (Loc, 1085 Prefix => New_Occurrence_Of (Temp, Loc))); 1086 end if; 1087 1088 if Present (TagT) then 1089 declare 1090 Full_T : constant Entity_Id := Underlying_Type (TagT); 1091 1092 begin 1093 Tag_Assign := 1094 Make_Assignment_Statement (Loc, 1095 Name => 1096 Make_Selected_Component (Loc, 1097 Prefix => TagR, 1098 Selector_Name => 1099 New_Occurrence_Of 1100 (First_Tag_Component (Full_T), Loc)), 1101 1102 Expression => 1103 Unchecked_Convert_To (RTE (RE_Tag), 1104 New_Occurrence_Of 1105 (Elists.Node 1106 (First_Elmt (Access_Disp_Table (Full_T))), Loc))); 1107 end; 1108 1109 -- The previous assignment has to be done in any case 1110 1111 Set_Assignment_OK (Name (Tag_Assign)); 1112 Insert_Action (N, Tag_Assign); 1113 end if; 1114 1115 -- Generate an Adjust call if the object will be moved. In Ada 2005, 1116 -- the object may be inherently limited, in which case there is no 1117 -- Adjust procedure, and the object is built in place. In Ada 95, the 1118 -- object can be limited but not inherently limited if this allocator 1119 -- came from a return statement (we're allocating the result on the 1120 -- secondary stack). In that case, the object will be moved, so we do 1121 -- want to Adjust. However, if it's a nonlimited build-in-place 1122 -- function call, Adjust is not wanted. 1123 1124 if Needs_Finalization (DesigT) 1125 and then Needs_Finalization (T) 1126 and then not Aggr_In_Place 1127 and then not Is_Limited_View (T) 1128 and then not Alloc_For_BIP_Return (N) 1129 and then not Is_Build_In_Place_Function_Call (Expression (N)) 1130 then 1131 -- An unchecked conversion is needed in the classwide case because 1132 -- the designated type can be an ancestor of the subtype mark of 1133 -- the allocator. 1134 1135 Adj_Call := 1136 Make_Adjust_Call 1137 (Obj_Ref => 1138 Unchecked_Convert_To (T, 1139 Make_Explicit_Dereference (Loc, 1140 Prefix => New_Occurrence_Of (Temp, Loc))), 1141 Typ => T); 1142 1143 if Present (Adj_Call) then 1144 Insert_Action (N, Adj_Call); 1145 end if; 1146 end if; 1147 1148 -- Note: the accessibility check must be inserted after the call to 1149 -- [Deep_]Adjust to ensure proper completion of the assignment. 1150 1151 Apply_Accessibility_Check (Temp); 1152 1153 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1154 Analyze_And_Resolve (N, PtrT); 1155 1156 -- Ada 2005 (AI-251): Displace the pointer to reference the record 1157 -- component containing the secondary dispatch table of the interface 1158 -- type. 1159 1160 if Is_Interface (Directly_Designated_Type (PtrT)) then 1161 Displace_Allocator_Pointer (N); 1162 end if; 1163 1164 -- Always force the generation of a temporary for aggregates when 1165 -- generating C code, to simplify the work in the code generator. 1166 1167 elsif Aggr_In_Place 1168 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate) 1169 then 1170 Temp := Make_Temporary (Loc, 'P', N); 1171 Temp_Decl := 1172 Make_Object_Declaration (Loc, 1173 Defining_Identifier => Temp, 1174 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1175 Expression => 1176 Make_Allocator (Loc, 1177 Expression => New_Occurrence_Of (Etype (Exp), Loc))); 1178 1179 -- Copy the Comes_From_Source flag for the allocator we just built, 1180 -- since logically this allocator is a replacement of the original 1181 -- allocator node. This is for proper handling of restriction 1182 -- No_Implicit_Heap_Allocations. 1183 1184 Set_Comes_From_Source 1185 (Expression (Temp_Decl), Comes_From_Source (N)); 1186 1187 Set_No_Initialization (Expression (Temp_Decl)); 1188 Insert_Action (N, Temp_Decl); 1189 1190 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1191 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1192 1193 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1194 Analyze_And_Resolve (N, PtrT); 1195 1196 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then 1197 Install_Null_Excluding_Check (Exp); 1198 1199 elsif Is_Access_Type (DesigT) 1200 and then Nkind (Exp) = N_Allocator 1201 and then Nkind (Expression (Exp)) /= N_Qualified_Expression 1202 then 1203 -- Apply constraint to designated subtype indication 1204 1205 Apply_Constraint_Check 1206 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True); 1207 1208 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then 1209 1210 -- Propagate constraint_error to enclosing allocator 1211 1212 Rewrite (Exp, New_Copy (Expression (Exp))); 1213 end if; 1214 1215 else 1216 Build_Allocate_Deallocate_Proc (N, True); 1217 1218 -- If we have: 1219 -- type A is access T1; 1220 -- X : A := new T2'(...); 1221 -- T1 and T2 can be different subtypes, and we might need to check 1222 -- both constraints. First check against the type of the qualified 1223 -- expression. 1224 1225 Apply_Constraint_Check (Exp, T, No_Sliding => True); 1226 1227 if Do_Range_Check (Exp) then 1228 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 1229 end if; 1230 1231 -- A check is also needed in cases where the designated subtype is 1232 -- constrained and differs from the subtype given in the qualified 1233 -- expression. Note that the check on the qualified expression does 1234 -- not allow sliding, but this check does (a relaxation from Ada 83). 1235 1236 if Is_Constrained (DesigT) 1237 and then not Subtypes_Statically_Match (T, DesigT) 1238 then 1239 Apply_Constraint_Check 1240 (Exp, DesigT, No_Sliding => False); 1241 1242 if Do_Range_Check (Exp) then 1243 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 1244 end if; 1245 end if; 1246 1247 -- For an access to unconstrained packed array, GIGI needs to see an 1248 -- expression with a constrained subtype in order to compute the 1249 -- proper size for the allocator. 1250 1251 if Is_Array_Type (T) 1252 and then not Is_Constrained (T) 1253 and then Is_Packed (T) 1254 then 1255 declare 1256 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); 1257 Internal_Exp : constant Node_Id := Relocate_Node (Exp); 1258 begin 1259 Insert_Action (Exp, 1260 Make_Subtype_Declaration (Loc, 1261 Defining_Identifier => ConstrT, 1262 Subtype_Indication => 1263 Make_Subtype_From_Expr (Internal_Exp, T))); 1264 Freeze_Itype (ConstrT, Exp); 1265 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); 1266 end; 1267 end if; 1268 1269 -- Ada 2005 (AI-318-02): If the initialization expression is a call 1270 -- to a build-in-place function, then access to the allocated object 1271 -- must be passed to the function. 1272 1273 if Is_Build_In_Place_Function_Call (Exp) then 1274 Make_Build_In_Place_Call_In_Allocator (N, Exp); 1275 end if; 1276 end if; 1277 1278 exception 1279 when RE_Not_Available => 1280 return; 1281 end Expand_Allocator_Expression; 1282 1283 ----------------------------- 1284 -- Expand_Array_Comparison -- 1285 ----------------------------- 1286 1287 -- Expansion is only required in the case of array types. For the unpacked 1288 -- case, an appropriate runtime routine is called. For packed cases, and 1289 -- also in some other cases where a runtime routine cannot be called, the 1290 -- form of the expansion is: 1291 1292 -- [body for greater_nn; boolean_expression] 1293 1294 -- The body is built by Make_Array_Comparison_Op, and the form of the 1295 -- Boolean expression depends on the operator involved. 1296 1297 procedure Expand_Array_Comparison (N : Node_Id) is 1298 Loc : constant Source_Ptr := Sloc (N); 1299 Op1 : Node_Id := Left_Opnd (N); 1300 Op2 : Node_Id := Right_Opnd (N); 1301 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 1302 Ctyp : constant Entity_Id := Component_Type (Typ1); 1303 1304 Expr : Node_Id; 1305 Func_Body : Node_Id; 1306 Func_Name : Entity_Id; 1307 1308 Comp : RE_Id; 1309 1310 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; 1311 -- True for byte addressable target 1312 1313 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; 1314 -- Returns True if the length of the given operand is known to be less 1315 -- than 4. Returns False if this length is known to be four or greater 1316 -- or is not known at compile time. 1317 1318 ------------------------ 1319 -- Length_Less_Than_4 -- 1320 ------------------------ 1321 1322 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is 1323 Otyp : constant Entity_Id := Etype (Opnd); 1324 1325 begin 1326 if Ekind (Otyp) = E_String_Literal_Subtype then 1327 return String_Literal_Length (Otyp) < 4; 1328 1329 else 1330 declare 1331 Ityp : constant Entity_Id := Etype (First_Index (Otyp)); 1332 Lo : constant Node_Id := Type_Low_Bound (Ityp); 1333 Hi : constant Node_Id := Type_High_Bound (Ityp); 1334 Lov : Uint; 1335 Hiv : Uint; 1336 1337 begin 1338 if Compile_Time_Known_Value (Lo) then 1339 Lov := Expr_Value (Lo); 1340 else 1341 return False; 1342 end if; 1343 1344 if Compile_Time_Known_Value (Hi) then 1345 Hiv := Expr_Value (Hi); 1346 else 1347 return False; 1348 end if; 1349 1350 return Hiv < Lov + 3; 1351 end; 1352 end if; 1353 end Length_Less_Than_4; 1354 1355 -- Start of processing for Expand_Array_Comparison 1356 1357 begin 1358 -- Deal first with unpacked case, where we can call a runtime routine 1359 -- except that we avoid this for targets for which are not addressable 1360 -- by bytes. 1361 1362 if not Is_Bit_Packed_Array (Typ1) 1363 and then Byte_Addressable 1364 then 1365 -- The call we generate is: 1366 1367 -- Compare_Array_xn[_Unaligned] 1368 -- (left'address, right'address, left'length, right'length) <op> 0 1369 1370 -- x = U for unsigned, S for signed 1371 -- n = 8,16,32,64 for component size 1372 -- Add _Unaligned if length < 4 and component size is 8. 1373 -- <op> is the standard comparison operator 1374 1375 if Component_Size (Typ1) = 8 then 1376 if Length_Less_Than_4 (Op1) 1377 or else 1378 Length_Less_Than_4 (Op2) 1379 then 1380 if Is_Unsigned_Type (Ctyp) then 1381 Comp := RE_Compare_Array_U8_Unaligned; 1382 else 1383 Comp := RE_Compare_Array_S8_Unaligned; 1384 end if; 1385 1386 else 1387 if Is_Unsigned_Type (Ctyp) then 1388 Comp := RE_Compare_Array_U8; 1389 else 1390 Comp := RE_Compare_Array_S8; 1391 end if; 1392 end if; 1393 1394 elsif Component_Size (Typ1) = 16 then 1395 if Is_Unsigned_Type (Ctyp) then 1396 Comp := RE_Compare_Array_U16; 1397 else 1398 Comp := RE_Compare_Array_S16; 1399 end if; 1400 1401 elsif Component_Size (Typ1) = 32 then 1402 if Is_Unsigned_Type (Ctyp) then 1403 Comp := RE_Compare_Array_U32; 1404 else 1405 Comp := RE_Compare_Array_S32; 1406 end if; 1407 1408 else pragma Assert (Component_Size (Typ1) = 64); 1409 if Is_Unsigned_Type (Ctyp) then 1410 Comp := RE_Compare_Array_U64; 1411 else 1412 Comp := RE_Compare_Array_S64; 1413 end if; 1414 end if; 1415 1416 if RTE_Available (Comp) then 1417 1418 -- Expand to a call only if the runtime function is available, 1419 -- otherwise fall back to inline code. 1420 1421 Remove_Side_Effects (Op1, Name_Req => True); 1422 Remove_Side_Effects (Op2, Name_Req => True); 1423 1424 Rewrite (Op1, 1425 Make_Function_Call (Sloc (Op1), 1426 Name => New_Occurrence_Of (RTE (Comp), Loc), 1427 1428 Parameter_Associations => New_List ( 1429 Make_Attribute_Reference (Loc, 1430 Prefix => Relocate_Node (Op1), 1431 Attribute_Name => Name_Address), 1432 1433 Make_Attribute_Reference (Loc, 1434 Prefix => Relocate_Node (Op2), 1435 Attribute_Name => Name_Address), 1436 1437 Make_Attribute_Reference (Loc, 1438 Prefix => Relocate_Node (Op1), 1439 Attribute_Name => Name_Length), 1440 1441 Make_Attribute_Reference (Loc, 1442 Prefix => Relocate_Node (Op2), 1443 Attribute_Name => Name_Length)))); 1444 1445 Rewrite (Op2, 1446 Make_Integer_Literal (Sloc (Op2), 1447 Intval => Uint_0)); 1448 1449 Analyze_And_Resolve (Op1, Standard_Integer); 1450 Analyze_And_Resolve (Op2, Standard_Integer); 1451 return; 1452 end if; 1453 end if; 1454 1455 -- Cases where we cannot make runtime call 1456 1457 -- For (a <= b) we convert to not (a > b) 1458 1459 if Chars (N) = Name_Op_Le then 1460 Rewrite (N, 1461 Make_Op_Not (Loc, 1462 Right_Opnd => 1463 Make_Op_Gt (Loc, 1464 Left_Opnd => Op1, 1465 Right_Opnd => Op2))); 1466 Analyze_And_Resolve (N, Standard_Boolean); 1467 return; 1468 1469 -- For < the Boolean expression is 1470 -- greater__nn (op2, op1) 1471 1472 elsif Chars (N) = Name_Op_Lt then 1473 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1474 1475 -- Switch operands 1476 1477 Op1 := Right_Opnd (N); 1478 Op2 := Left_Opnd (N); 1479 1480 -- For (a >= b) we convert to not (a < b) 1481 1482 elsif Chars (N) = Name_Op_Ge then 1483 Rewrite (N, 1484 Make_Op_Not (Loc, 1485 Right_Opnd => 1486 Make_Op_Lt (Loc, 1487 Left_Opnd => Op1, 1488 Right_Opnd => Op2))); 1489 Analyze_And_Resolve (N, Standard_Boolean); 1490 return; 1491 1492 -- For > the Boolean expression is 1493 -- greater__nn (op1, op2) 1494 1495 else 1496 pragma Assert (Chars (N) = Name_Op_Gt); 1497 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1498 end if; 1499 1500 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 1501 Expr := 1502 Make_Function_Call (Loc, 1503 Name => New_Occurrence_Of (Func_Name, Loc), 1504 Parameter_Associations => New_List (Op1, Op2)); 1505 1506 Insert_Action (N, Func_Body); 1507 Rewrite (N, Expr); 1508 Analyze_And_Resolve (N, Standard_Boolean); 1509 end Expand_Array_Comparison; 1510 1511 --------------------------- 1512 -- Expand_Array_Equality -- 1513 --------------------------- 1514 1515 -- Expand an equality function for multi-dimensional arrays. Here is an 1516 -- example of such a function for Nb_Dimension = 2 1517 1518 -- function Enn (A : atyp; B : btyp) return boolean is 1519 -- begin 1520 -- if (A'length (1) = 0 or else A'length (2) = 0) 1521 -- and then 1522 -- (B'length (1) = 0 or else B'length (2) = 0) 1523 -- then 1524 -- return True; -- RM 4.5.2(22) 1525 -- end if; 1526 1527 -- if A'length (1) /= B'length (1) 1528 -- or else 1529 -- A'length (2) /= B'length (2) 1530 -- then 1531 -- return False; -- RM 4.5.2(23) 1532 -- end if; 1533 1534 -- declare 1535 -- A1 : Index_T1 := A'first (1); 1536 -- B1 : Index_T1 := B'first (1); 1537 -- begin 1538 -- loop 1539 -- declare 1540 -- A2 : Index_T2 := A'first (2); 1541 -- B2 : Index_T2 := B'first (2); 1542 -- begin 1543 -- loop 1544 -- if A (A1, A2) /= B (B1, B2) then 1545 -- return False; 1546 -- end if; 1547 1548 -- exit when A2 = A'last (2); 1549 -- A2 := Index_T2'succ (A2); 1550 -- B2 := Index_T2'succ (B2); 1551 -- end loop; 1552 -- end; 1553 1554 -- exit when A1 = A'last (1); 1555 -- A1 := Index_T1'succ (A1); 1556 -- B1 := Index_T1'succ (B1); 1557 -- end loop; 1558 -- end; 1559 1560 -- return true; 1561 -- end Enn; 1562 1563 -- Note on the formal types used (atyp and btyp). If either of the arrays 1564 -- is of a private type, we use the underlying type, and do an unchecked 1565 -- conversion of the actual. If either of the arrays has a bound depending 1566 -- on a discriminant, then we use the base type since otherwise we have an 1567 -- escaped discriminant in the function. 1568 1569 -- If both arrays are constrained and have the same bounds, we can generate 1570 -- a loop with an explicit iteration scheme using a 'Range attribute over 1571 -- the first array. 1572 1573 function Expand_Array_Equality 1574 (Nod : Node_Id; 1575 Lhs : Node_Id; 1576 Rhs : Node_Id; 1577 Bodies : List_Id; 1578 Typ : Entity_Id) return Node_Id 1579 is 1580 Loc : constant Source_Ptr := Sloc (Nod); 1581 Decls : constant List_Id := New_List; 1582 Index_List1 : constant List_Id := New_List; 1583 Index_List2 : constant List_Id := New_List; 1584 1585 First_Idx : Node_Id; 1586 Formals : List_Id; 1587 Func_Name : Entity_Id; 1588 Func_Body : Node_Id; 1589 1590 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 1591 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 1592 1593 Ltyp : Entity_Id; 1594 Rtyp : Entity_Id; 1595 -- The parameter types to be used for the formals 1596 1597 New_Lhs : Node_Id; 1598 New_Rhs : Node_Id; 1599 -- The LHS and RHS converted to the parameter types 1600 1601 function Arr_Attr 1602 (Arr : Entity_Id; 1603 Nam : Name_Id; 1604 Num : Int) return Node_Id; 1605 -- This builds the attribute reference Arr'Nam (Expr) 1606 1607 function Component_Equality (Typ : Entity_Id) return Node_Id; 1608 -- Create one statement to compare corresponding components, designated 1609 -- by a full set of indexes. 1610 1611 function Get_Arg_Type (N : Node_Id) return Entity_Id; 1612 -- Given one of the arguments, computes the appropriate type to be used 1613 -- for that argument in the corresponding function formal 1614 1615 function Handle_One_Dimension 1616 (N : Int; 1617 Index : Node_Id) return Node_Id; 1618 -- This procedure returns the following code 1619 -- 1620 -- declare 1621 -- Bn : Index_T := B'First (N); 1622 -- begin 1623 -- loop 1624 -- xxx 1625 -- exit when An = A'Last (N); 1626 -- An := Index_T'Succ (An) 1627 -- Bn := Index_T'Succ (Bn) 1628 -- end loop; 1629 -- end; 1630 -- 1631 -- If both indexes are constrained and identical, the procedure 1632 -- returns a simpler loop: 1633 -- 1634 -- for An in A'Range (N) loop 1635 -- xxx 1636 -- end loop 1637 -- 1638 -- N is the dimension for which we are generating a loop. Index is the 1639 -- N'th index node, whose Etype is Index_Type_n in the above code. The 1640 -- xxx statement is either the loop or declare for the next dimension 1641 -- or if this is the last dimension the comparison of corresponding 1642 -- components of the arrays. 1643 -- 1644 -- The actual way the code works is to return the comparison of 1645 -- corresponding components for the N+1 call. That's neater. 1646 1647 function Test_Empty_Arrays return Node_Id; 1648 -- This function constructs the test for both arrays being empty 1649 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) 1650 -- and then 1651 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) 1652 1653 function Test_Lengths_Correspond return Node_Id; 1654 -- This function constructs the test for arrays having different lengths 1655 -- in at least one index position, in which case the resulting code is: 1656 1657 -- A'length (1) /= B'length (1) 1658 -- or else 1659 -- A'length (2) /= B'length (2) 1660 -- or else 1661 -- ... 1662 1663 -------------- 1664 -- Arr_Attr -- 1665 -------------- 1666 1667 function Arr_Attr 1668 (Arr : Entity_Id; 1669 Nam : Name_Id; 1670 Num : Int) return Node_Id 1671 is 1672 begin 1673 return 1674 Make_Attribute_Reference (Loc, 1675 Attribute_Name => Nam, 1676 Prefix => New_Occurrence_Of (Arr, Loc), 1677 Expressions => New_List (Make_Integer_Literal (Loc, Num))); 1678 end Arr_Attr; 1679 1680 ------------------------ 1681 -- Component_Equality -- 1682 ------------------------ 1683 1684 function Component_Equality (Typ : Entity_Id) return Node_Id is 1685 Test : Node_Id; 1686 L, R : Node_Id; 1687 1688 begin 1689 -- if a(i1...) /= b(j1...) then return false; end if; 1690 1691 L := 1692 Make_Indexed_Component (Loc, 1693 Prefix => Make_Identifier (Loc, Chars (A)), 1694 Expressions => Index_List1); 1695 1696 R := 1697 Make_Indexed_Component (Loc, 1698 Prefix => Make_Identifier (Loc, Chars (B)), 1699 Expressions => Index_List2); 1700 1701 Test := Expand_Composite_Equality 1702 (Nod, Component_Type (Typ), L, R, Decls); 1703 1704 -- If some (sub)component is an unchecked_union, the whole operation 1705 -- will raise program error. 1706 1707 if Nkind (Test) = N_Raise_Program_Error then 1708 1709 -- This node is going to be inserted at a location where a 1710 -- statement is expected: clear its Etype so analysis will set 1711 -- it to the expected Standard_Void_Type. 1712 1713 Set_Etype (Test, Empty); 1714 return Test; 1715 1716 else 1717 return 1718 Make_Implicit_If_Statement (Nod, 1719 Condition => Make_Op_Not (Loc, Right_Opnd => Test), 1720 Then_Statements => New_List ( 1721 Make_Simple_Return_Statement (Loc, 1722 Expression => New_Occurrence_Of (Standard_False, Loc)))); 1723 end if; 1724 end Component_Equality; 1725 1726 ------------------ 1727 -- Get_Arg_Type -- 1728 ------------------ 1729 1730 function Get_Arg_Type (N : Node_Id) return Entity_Id is 1731 T : Entity_Id; 1732 X : Node_Id; 1733 1734 begin 1735 T := Etype (N); 1736 1737 if No (T) then 1738 return Typ; 1739 1740 else 1741 T := Underlying_Type (T); 1742 1743 X := First_Index (T); 1744 while Present (X) loop 1745 if Denotes_Discriminant (Type_Low_Bound (Etype (X))) 1746 or else 1747 Denotes_Discriminant (Type_High_Bound (Etype (X))) 1748 then 1749 T := Base_Type (T); 1750 exit; 1751 end if; 1752 1753 Next_Index (X); 1754 end loop; 1755 1756 return T; 1757 end if; 1758 end Get_Arg_Type; 1759 1760 -------------------------- 1761 -- Handle_One_Dimension -- 1762 --------------------------- 1763 1764 function Handle_One_Dimension 1765 (N : Int; 1766 Index : Node_Id) return Node_Id 1767 is 1768 Need_Separate_Indexes : constant Boolean := 1769 Ltyp /= Rtyp or else not Is_Constrained (Ltyp); 1770 -- If the index types are identical, and we are working with 1771 -- constrained types, then we can use the same index for both 1772 -- of the arrays. 1773 1774 An : constant Entity_Id := Make_Temporary (Loc, 'A'); 1775 1776 Bn : Entity_Id; 1777 Index_T : Entity_Id; 1778 Stm_List : List_Id; 1779 Loop_Stm : Node_Id; 1780 1781 begin 1782 if N > Number_Dimensions (Ltyp) then 1783 return Component_Equality (Ltyp); 1784 end if; 1785 1786 -- Case where we generate a loop 1787 1788 Index_T := Base_Type (Etype (Index)); 1789 1790 if Need_Separate_Indexes then 1791 Bn := Make_Temporary (Loc, 'B'); 1792 else 1793 Bn := An; 1794 end if; 1795 1796 Append (New_Occurrence_Of (An, Loc), Index_List1); 1797 Append (New_Occurrence_Of (Bn, Loc), Index_List2); 1798 1799 Stm_List := New_List ( 1800 Handle_One_Dimension (N + 1, Next_Index (Index))); 1801 1802 if Need_Separate_Indexes then 1803 1804 -- Generate guard for loop, followed by increments of indexes 1805 1806 Append_To (Stm_List, 1807 Make_Exit_Statement (Loc, 1808 Condition => 1809 Make_Op_Eq (Loc, 1810 Left_Opnd => New_Occurrence_Of (An, Loc), 1811 Right_Opnd => Arr_Attr (A, Name_Last, N)))); 1812 1813 Append_To (Stm_List, 1814 Make_Assignment_Statement (Loc, 1815 Name => New_Occurrence_Of (An, Loc), 1816 Expression => 1817 Make_Attribute_Reference (Loc, 1818 Prefix => New_Occurrence_Of (Index_T, Loc), 1819 Attribute_Name => Name_Succ, 1820 Expressions => New_List ( 1821 New_Occurrence_Of (An, Loc))))); 1822 1823 Append_To (Stm_List, 1824 Make_Assignment_Statement (Loc, 1825 Name => New_Occurrence_Of (Bn, Loc), 1826 Expression => 1827 Make_Attribute_Reference (Loc, 1828 Prefix => New_Occurrence_Of (Index_T, Loc), 1829 Attribute_Name => Name_Succ, 1830 Expressions => New_List ( 1831 New_Occurrence_Of (Bn, Loc))))); 1832 end if; 1833 1834 -- If separate indexes, we need a declare block for An and Bn, and a 1835 -- loop without an iteration scheme. 1836 1837 if Need_Separate_Indexes then 1838 Loop_Stm := 1839 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); 1840 1841 return 1842 Make_Block_Statement (Loc, 1843 Declarations => New_List ( 1844 Make_Object_Declaration (Loc, 1845 Defining_Identifier => An, 1846 Object_Definition => New_Occurrence_Of (Index_T, Loc), 1847 Expression => Arr_Attr (A, Name_First, N)), 1848 1849 Make_Object_Declaration (Loc, 1850 Defining_Identifier => Bn, 1851 Object_Definition => New_Occurrence_Of (Index_T, Loc), 1852 Expression => Arr_Attr (B, Name_First, N))), 1853 1854 Handled_Statement_Sequence => 1855 Make_Handled_Sequence_Of_Statements (Loc, 1856 Statements => New_List (Loop_Stm))); 1857 1858 -- If no separate indexes, return loop statement with explicit 1859 -- iteration scheme on its own. 1860 1861 else 1862 Loop_Stm := 1863 Make_Implicit_Loop_Statement (Nod, 1864 Statements => Stm_List, 1865 Iteration_Scheme => 1866 Make_Iteration_Scheme (Loc, 1867 Loop_Parameter_Specification => 1868 Make_Loop_Parameter_Specification (Loc, 1869 Defining_Identifier => An, 1870 Discrete_Subtype_Definition => 1871 Arr_Attr (A, Name_Range, N)))); 1872 return Loop_Stm; 1873 end if; 1874 end Handle_One_Dimension; 1875 1876 ----------------------- 1877 -- Test_Empty_Arrays -- 1878 ----------------------- 1879 1880 function Test_Empty_Arrays return Node_Id is 1881 Alist : Node_Id; 1882 Blist : Node_Id; 1883 1884 Atest : Node_Id; 1885 Btest : Node_Id; 1886 1887 begin 1888 Alist := Empty; 1889 Blist := Empty; 1890 for J in 1 .. Number_Dimensions (Ltyp) loop 1891 Atest := 1892 Make_Op_Eq (Loc, 1893 Left_Opnd => Arr_Attr (A, Name_Length, J), 1894 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1895 1896 Btest := 1897 Make_Op_Eq (Loc, 1898 Left_Opnd => Arr_Attr (B, Name_Length, J), 1899 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1900 1901 if No (Alist) then 1902 Alist := Atest; 1903 Blist := Btest; 1904 1905 else 1906 Alist := 1907 Make_Or_Else (Loc, 1908 Left_Opnd => Relocate_Node (Alist), 1909 Right_Opnd => Atest); 1910 1911 Blist := 1912 Make_Or_Else (Loc, 1913 Left_Opnd => Relocate_Node (Blist), 1914 Right_Opnd => Btest); 1915 end if; 1916 end loop; 1917 1918 return 1919 Make_And_Then (Loc, 1920 Left_Opnd => Alist, 1921 Right_Opnd => Blist); 1922 end Test_Empty_Arrays; 1923 1924 ----------------------------- 1925 -- Test_Lengths_Correspond -- 1926 ----------------------------- 1927 1928 function Test_Lengths_Correspond return Node_Id is 1929 Result : Node_Id; 1930 Rtest : Node_Id; 1931 1932 begin 1933 Result := Empty; 1934 for J in 1 .. Number_Dimensions (Ltyp) loop 1935 Rtest := 1936 Make_Op_Ne (Loc, 1937 Left_Opnd => Arr_Attr (A, Name_Length, J), 1938 Right_Opnd => Arr_Attr (B, Name_Length, J)); 1939 1940 if No (Result) then 1941 Result := Rtest; 1942 else 1943 Result := 1944 Make_Or_Else (Loc, 1945 Left_Opnd => Relocate_Node (Result), 1946 Right_Opnd => Rtest); 1947 end if; 1948 end loop; 1949 1950 return Result; 1951 end Test_Lengths_Correspond; 1952 1953 -- Start of processing for Expand_Array_Equality 1954 1955 begin 1956 Ltyp := Get_Arg_Type (Lhs); 1957 Rtyp := Get_Arg_Type (Rhs); 1958 1959 -- For now, if the argument types are not the same, go to the base type, 1960 -- since the code assumes that the formals have the same type. This is 1961 -- fixable in future ??? 1962 1963 if Ltyp /= Rtyp then 1964 Ltyp := Base_Type (Ltyp); 1965 Rtyp := Base_Type (Rtyp); 1966 pragma Assert (Ltyp = Rtyp); 1967 end if; 1968 1969 -- If the array type is distinct from the type of the arguments, it 1970 -- is the full view of a private type. Apply an unchecked conversion 1971 -- to ensure that analysis of the code below succeeds. 1972 1973 if No (Etype (Lhs)) 1974 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp) 1975 then 1976 New_Lhs := OK_Convert_To (Ltyp, Lhs); 1977 else 1978 New_Lhs := Lhs; 1979 end if; 1980 1981 if No (Etype (Rhs)) 1982 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp) 1983 then 1984 New_Rhs := OK_Convert_To (Rtyp, Rhs); 1985 else 1986 New_Rhs := Rhs; 1987 end if; 1988 1989 First_Idx := First_Index (Ltyp); 1990 1991 -- If optimization is enabled and the array boils down to a couple of 1992 -- consecutive elements, generate a simple conjunction of comparisons 1993 -- which should be easier to optimize by the code generator. 1994 1995 if Optimization_Level > 0 1996 and then Ltyp = Rtyp 1997 and then Is_Constrained (Ltyp) 1998 and then Number_Dimensions (Ltyp) = 1 1999 and then Nkind (First_Idx) = N_Range 2000 and then Compile_Time_Known_Value (Low_Bound (First_Idx)) 2001 and then Compile_Time_Known_Value (High_Bound (First_Idx)) 2002 and then Expr_Value (High_Bound (First_Idx)) = 2003 Expr_Value (Low_Bound (First_Idx)) + 1 2004 then 2005 declare 2006 Ctyp : constant Entity_Id := Component_Type (Ltyp); 2007 L, R : Node_Id; 2008 TestL, TestH : Node_Id; 2009 Index_List : List_Id; 2010 2011 begin 2012 Index_List := New_List (New_Copy_Tree (Low_Bound (First_Idx))); 2013 2014 L := 2015 Make_Indexed_Component (Loc, 2016 Prefix => New_Copy_Tree (New_Lhs), 2017 Expressions => Index_List); 2018 2019 R := 2020 Make_Indexed_Component (Loc, 2021 Prefix => New_Copy_Tree (New_Rhs), 2022 Expressions => Index_List); 2023 2024 TestL := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies); 2025 2026 Index_List := New_List (New_Copy_Tree (High_Bound (First_Idx))); 2027 2028 L := 2029 Make_Indexed_Component (Loc, 2030 Prefix => New_Lhs, 2031 Expressions => Index_List); 2032 2033 R := 2034 Make_Indexed_Component (Loc, 2035 Prefix => New_Rhs, 2036 Expressions => Index_List); 2037 2038 TestH := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies); 2039 2040 return 2041 Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH); 2042 end; 2043 end if; 2044 2045 -- Build list of formals for function 2046 2047 Formals := New_List ( 2048 Make_Parameter_Specification (Loc, 2049 Defining_Identifier => A, 2050 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)), 2051 2052 Make_Parameter_Specification (Loc, 2053 Defining_Identifier => B, 2054 Parameter_Type => New_Occurrence_Of (Rtyp, Loc))); 2055 2056 Func_Name := Make_Temporary (Loc, 'E'); 2057 2058 -- Build statement sequence for function 2059 2060 Func_Body := 2061 Make_Subprogram_Body (Loc, 2062 Specification => 2063 Make_Function_Specification (Loc, 2064 Defining_Unit_Name => Func_Name, 2065 Parameter_Specifications => Formals, 2066 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 2067 2068 Declarations => Decls, 2069 2070 Handled_Statement_Sequence => 2071 Make_Handled_Sequence_Of_Statements (Loc, 2072 Statements => New_List ( 2073 2074 Make_Implicit_If_Statement (Nod, 2075 Condition => Test_Empty_Arrays, 2076 Then_Statements => New_List ( 2077 Make_Simple_Return_Statement (Loc, 2078 Expression => 2079 New_Occurrence_Of (Standard_True, Loc)))), 2080 2081 Make_Implicit_If_Statement (Nod, 2082 Condition => Test_Lengths_Correspond, 2083 Then_Statements => New_List ( 2084 Make_Simple_Return_Statement (Loc, 2085 Expression => New_Occurrence_Of (Standard_False, Loc)))), 2086 2087 Handle_One_Dimension (1, First_Idx), 2088 2089 Make_Simple_Return_Statement (Loc, 2090 Expression => New_Occurrence_Of (Standard_True, Loc))))); 2091 2092 Set_Has_Completion (Func_Name, True); 2093 Set_Is_Inlined (Func_Name); 2094 2095 Append_To (Bodies, Func_Body); 2096 2097 return 2098 Make_Function_Call (Loc, 2099 Name => New_Occurrence_Of (Func_Name, Loc), 2100 Parameter_Associations => New_List (New_Lhs, New_Rhs)); 2101 end Expand_Array_Equality; 2102 2103 ----------------------------- 2104 -- Expand_Boolean_Operator -- 2105 ----------------------------- 2106 2107 -- Note that we first get the actual subtypes of the operands, since we 2108 -- always want to deal with types that have bounds. 2109 2110 procedure Expand_Boolean_Operator (N : Node_Id) is 2111 Typ : constant Entity_Id := Etype (N); 2112 2113 begin 2114 -- Special case of bit packed array where both operands are known to be 2115 -- properly aligned. In this case we use an efficient run time routine 2116 -- to carry out the operation (see System.Bit_Ops). 2117 2118 if Is_Bit_Packed_Array (Typ) 2119 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) 2120 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 2121 then 2122 Expand_Packed_Boolean_Operator (N); 2123 return; 2124 end if; 2125 2126 -- For the normal non-packed case, the general expansion is to build 2127 -- function for carrying out the comparison (use Make_Boolean_Array_Op) 2128 -- and then inserting it into the tree. The original operator node is 2129 -- then rewritten as a call to this function. We also use this in the 2130 -- packed case if either operand is a possibly unaligned object. 2131 2132 declare 2133 Loc : constant Source_Ptr := Sloc (N); 2134 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 2135 R : Node_Id := Relocate_Node (Right_Opnd (N)); 2136 Func_Body : Node_Id; 2137 Func_Name : Entity_Id; 2138 2139 begin 2140 Convert_To_Actual_Subtype (L); 2141 Convert_To_Actual_Subtype (R); 2142 Ensure_Defined (Etype (L), N); 2143 Ensure_Defined (Etype (R), N); 2144 Apply_Length_Check (R, Etype (L)); 2145 2146 if Nkind (N) = N_Op_Xor then 2147 R := Duplicate_Subexpr (R); 2148 Silly_Boolean_Array_Xor_Test (N, R, Etype (L)); 2149 end if; 2150 2151 if Nkind (Parent (N)) = N_Assignment_Statement 2152 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) 2153 then 2154 Build_Boolean_Array_Proc_Call (Parent (N), L, R); 2155 2156 elsif Nkind (Parent (N)) = N_Op_Not 2157 and then Nkind (N) = N_Op_And 2158 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 2159 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) 2160 then 2161 return; 2162 else 2163 2164 Func_Body := Make_Boolean_Array_Op (Etype (L), N); 2165 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 2166 Insert_Action (N, Func_Body); 2167 2168 -- Now rewrite the expression with a call 2169 2170 Rewrite (N, 2171 Make_Function_Call (Loc, 2172 Name => New_Occurrence_Of (Func_Name, Loc), 2173 Parameter_Associations => 2174 New_List ( 2175 L, 2176 Make_Type_Conversion 2177 (Loc, New_Occurrence_Of (Etype (L), Loc), R)))); 2178 2179 Analyze_And_Resolve (N, Typ); 2180 end if; 2181 end; 2182 end Expand_Boolean_Operator; 2183 2184 ------------------------------------------------ 2185 -- Expand_Compare_Minimize_Eliminate_Overflow -- 2186 ------------------------------------------------ 2187 2188 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is 2189 Loc : constant Source_Ptr := Sloc (N); 2190 2191 Result_Type : constant Entity_Id := Etype (N); 2192 -- Capture result type (could be a derived boolean type) 2193 2194 Llo, Lhi : Uint; 2195 Rlo, Rhi : Uint; 2196 2197 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 2198 -- Entity for Long_Long_Integer'Base 2199 2200 Check : constant Overflow_Mode_Type := Overflow_Check_Mode; 2201 -- Current overflow checking mode 2202 2203 procedure Set_True; 2204 procedure Set_False; 2205 -- These procedures rewrite N with an occurrence of Standard_True or 2206 -- Standard_False, and then makes a call to Warn_On_Known_Condition. 2207 2208 --------------- 2209 -- Set_False -- 2210 --------------- 2211 2212 procedure Set_False is 2213 begin 2214 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 2215 Warn_On_Known_Condition (N); 2216 end Set_False; 2217 2218 -------------- 2219 -- Set_True -- 2220 -------------- 2221 2222 procedure Set_True is 2223 begin 2224 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 2225 Warn_On_Known_Condition (N); 2226 end Set_True; 2227 2228 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow 2229 2230 begin 2231 -- Nothing to do unless we have a comparison operator with operands 2232 -- that are signed integer types, and we are operating in either 2233 -- MINIMIZED or ELIMINATED overflow checking mode. 2234 2235 if Nkind (N) not in N_Op_Compare 2236 or else Check not in Minimized_Or_Eliminated 2237 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N))) 2238 then 2239 return; 2240 end if; 2241 2242 -- OK, this is the case we are interested in. First step is to process 2243 -- our operands using the Minimize_Eliminate circuitry which applies 2244 -- this processing to the two operand subtrees. 2245 2246 Minimize_Eliminate_Overflows 2247 (Left_Opnd (N), Llo, Lhi, Top_Level => False); 2248 Minimize_Eliminate_Overflows 2249 (Right_Opnd (N), Rlo, Rhi, Top_Level => False); 2250 2251 -- See if the range information decides the result of the comparison. 2252 -- We can only do this if we in fact have full range information (which 2253 -- won't be the case if either operand is bignum at this stage). 2254 2255 if Llo /= No_Uint and then Rlo /= No_Uint then 2256 case N_Op_Compare (Nkind (N)) is 2257 when N_Op_Eq => 2258 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2259 Set_True; 2260 elsif Llo > Rhi or else Lhi < Rlo then 2261 Set_False; 2262 end if; 2263 2264 when N_Op_Ge => 2265 if Llo >= Rhi then 2266 Set_True; 2267 elsif Lhi < Rlo then 2268 Set_False; 2269 end if; 2270 2271 when N_Op_Gt => 2272 if Llo > Rhi then 2273 Set_True; 2274 elsif Lhi <= Rlo then 2275 Set_False; 2276 end if; 2277 2278 when N_Op_Le => 2279 if Llo > Rhi then 2280 Set_False; 2281 elsif Lhi <= Rlo then 2282 Set_True; 2283 end if; 2284 2285 when N_Op_Lt => 2286 if Llo >= Rhi then 2287 Set_False; 2288 elsif Lhi < Rlo then 2289 Set_True; 2290 end if; 2291 2292 when N_Op_Ne => 2293 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2294 Set_False; 2295 elsif Llo > Rhi or else Lhi < Rlo then 2296 Set_True; 2297 end if; 2298 end case; 2299 2300 -- All done if we did the rewrite 2301 2302 if Nkind (N) not in N_Op_Compare then 2303 return; 2304 end if; 2305 end if; 2306 2307 -- Otherwise, time to do the comparison 2308 2309 declare 2310 Ltype : constant Entity_Id := Etype (Left_Opnd (N)); 2311 Rtype : constant Entity_Id := Etype (Right_Opnd (N)); 2312 2313 begin 2314 -- If the two operands have the same signed integer type we are 2315 -- all set, nothing more to do. This is the case where either 2316 -- both operands were unchanged, or we rewrote both of them to 2317 -- be Long_Long_Integer. 2318 2319 -- Note: Entity for the comparison may be wrong, but it's not worth 2320 -- the effort to change it, since the back end does not use it. 2321 2322 if Is_Signed_Integer_Type (Ltype) 2323 and then Base_Type (Ltype) = Base_Type (Rtype) 2324 then 2325 return; 2326 2327 -- Here if bignums are involved (can only happen in ELIMINATED mode) 2328 2329 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then 2330 declare 2331 Left : Node_Id := Left_Opnd (N); 2332 Right : Node_Id := Right_Opnd (N); 2333 -- Bignum references for left and right operands 2334 2335 begin 2336 if not Is_RTE (Ltype, RE_Bignum) then 2337 Left := Convert_To_Bignum (Left); 2338 elsif not Is_RTE (Rtype, RE_Bignum) then 2339 Right := Convert_To_Bignum (Right); 2340 end if; 2341 2342 -- We rewrite our node with: 2343 2344 -- do 2345 -- Bnn : Result_Type; 2346 -- declare 2347 -- M : Mark_Id := SS_Mark; 2348 -- begin 2349 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc) 2350 -- SS_Release (M); 2351 -- end; 2352 -- in 2353 -- Bnn 2354 -- end 2355 2356 declare 2357 Blk : constant Node_Id := Make_Bignum_Block (Loc); 2358 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 2359 Ent : RE_Id; 2360 2361 begin 2362 case N_Op_Compare (Nkind (N)) is 2363 when N_Op_Eq => Ent := RE_Big_EQ; 2364 when N_Op_Ge => Ent := RE_Big_GE; 2365 when N_Op_Gt => Ent := RE_Big_GT; 2366 when N_Op_Le => Ent := RE_Big_LE; 2367 when N_Op_Lt => Ent := RE_Big_LT; 2368 when N_Op_Ne => Ent := RE_Big_NE; 2369 end case; 2370 2371 -- Insert assignment to Bnn into the bignum block 2372 2373 Insert_Before 2374 (First (Statements (Handled_Statement_Sequence (Blk))), 2375 Make_Assignment_Statement (Loc, 2376 Name => New_Occurrence_Of (Bnn, Loc), 2377 Expression => 2378 Make_Function_Call (Loc, 2379 Name => 2380 New_Occurrence_Of (RTE (Ent), Loc), 2381 Parameter_Associations => New_List (Left, Right)))); 2382 2383 -- Now do the rewrite with expression actions 2384 2385 Rewrite (N, 2386 Make_Expression_With_Actions (Loc, 2387 Actions => New_List ( 2388 Make_Object_Declaration (Loc, 2389 Defining_Identifier => Bnn, 2390 Object_Definition => 2391 New_Occurrence_Of (Result_Type, Loc)), 2392 Blk), 2393 Expression => New_Occurrence_Of (Bnn, Loc))); 2394 Analyze_And_Resolve (N, Result_Type); 2395 end; 2396 end; 2397 2398 -- No bignums involved, but types are different, so we must have 2399 -- rewritten one of the operands as a Long_Long_Integer but not 2400 -- the other one. 2401 2402 -- If left operand is Long_Long_Integer, convert right operand 2403 -- and we are done (with a comparison of two Long_Long_Integers). 2404 2405 elsif Ltype = LLIB then 2406 Convert_To_And_Rewrite (LLIB, Right_Opnd (N)); 2407 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks); 2408 return; 2409 2410 -- If right operand is Long_Long_Integer, convert left operand 2411 -- and we are done (with a comparison of two Long_Long_Integers). 2412 2413 -- This is the only remaining possibility 2414 2415 else pragma Assert (Rtype = LLIB); 2416 Convert_To_And_Rewrite (LLIB, Left_Opnd (N)); 2417 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks); 2418 return; 2419 end if; 2420 end; 2421 end Expand_Compare_Minimize_Eliminate_Overflow; 2422 2423 ------------------------------- 2424 -- Expand_Composite_Equality -- 2425 ------------------------------- 2426 2427 -- This function is only called for comparing internal fields of composite 2428 -- types when these fields are themselves composites. This is a special 2429 -- case because it is not possible to respect normal Ada visibility rules. 2430 2431 function Expand_Composite_Equality 2432 (Nod : Node_Id; 2433 Typ : Entity_Id; 2434 Lhs : Node_Id; 2435 Rhs : Node_Id; 2436 Bodies : List_Id) return Node_Id 2437 is 2438 Loc : constant Source_Ptr := Sloc (Nod); 2439 Full_Type : Entity_Id; 2440 Eq_Op : Entity_Id; 2441 2442 -- Start of processing for Expand_Composite_Equality 2443 2444 begin 2445 if Is_Private_Type (Typ) then 2446 Full_Type := Underlying_Type (Typ); 2447 else 2448 Full_Type := Typ; 2449 end if; 2450 2451 -- If the private type has no completion the context may be the 2452 -- expansion of a composite equality for a composite type with some 2453 -- still incomplete components. The expression will not be analyzed 2454 -- until the enclosing type is completed, at which point this will be 2455 -- properly expanded, unless there is a bona fide completion error. 2456 2457 if No (Full_Type) then 2458 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2459 end if; 2460 2461 Full_Type := Base_Type (Full_Type); 2462 2463 -- When the base type itself is private, use the full view to expand 2464 -- the composite equality. 2465 2466 if Is_Private_Type (Full_Type) then 2467 Full_Type := Underlying_Type (Full_Type); 2468 end if; 2469 2470 -- Case of array types 2471 2472 if Is_Array_Type (Full_Type) then 2473 2474 -- If the operand is an elementary type other than a floating-point 2475 -- type, then we can simply use the built-in block bitwise equality, 2476 -- since the predefined equality operators always apply and bitwise 2477 -- equality is fine for all these cases. 2478 2479 if Is_Elementary_Type (Component_Type (Full_Type)) 2480 and then not Is_Floating_Point_Type (Component_Type (Full_Type)) 2481 then 2482 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2483 2484 -- For composite component types, and floating-point types, use the 2485 -- expansion. This deals with tagged component types (where we use 2486 -- the applicable equality routine) and floating-point (where we 2487 -- need to worry about negative zeroes), and also the case of any 2488 -- composite type recursively containing such fields. 2489 2490 else 2491 declare 2492 Comp_Typ : Entity_Id; 2493 Hi : Node_Id; 2494 Indx : Node_Id; 2495 Ityp : Entity_Id; 2496 Lo : Node_Id; 2497 2498 begin 2499 -- Do the comparison in the type (or its full view) and not in 2500 -- its unconstrained base type, because the latter operation is 2501 -- more complex and would also require an unchecked conversion. 2502 2503 if Is_Private_Type (Typ) then 2504 Comp_Typ := Underlying_Type (Typ); 2505 else 2506 Comp_Typ := Typ; 2507 end if; 2508 2509 -- Except for the case where the bounds of the type depend on a 2510 -- discriminant, or else we would run into scoping issues. 2511 2512 Indx := First_Index (Comp_Typ); 2513 while Present (Indx) loop 2514 Ityp := Etype (Indx); 2515 2516 Lo := Type_Low_Bound (Ityp); 2517 Hi := Type_High_Bound (Ityp); 2518 2519 if (Nkind (Lo) = N_Identifier 2520 and then Ekind (Entity (Lo)) = E_Discriminant) 2521 or else 2522 (Nkind (Hi) = N_Identifier 2523 and then Ekind (Entity (Hi)) = E_Discriminant) 2524 then 2525 Comp_Typ := Full_Type; 2526 exit; 2527 end if; 2528 2529 Next_Index (Indx); 2530 end loop; 2531 2532 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Comp_Typ); 2533 end; 2534 end if; 2535 2536 -- Case of tagged record types 2537 2538 elsif Is_Tagged_Type (Full_Type) then 2539 Eq_Op := Find_Primitive_Eq (Typ); 2540 pragma Assert (Present (Eq_Op)); 2541 2542 return 2543 Make_Function_Call (Loc, 2544 Name => New_Occurrence_Of (Eq_Op, Loc), 2545 Parameter_Associations => 2546 New_List 2547 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), 2548 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); 2549 2550 -- Case of untagged record types 2551 2552 elsif Is_Record_Type (Full_Type) then 2553 Eq_Op := TSS (Full_Type, TSS_Composite_Equality); 2554 2555 if Present (Eq_Op) then 2556 if Etype (First_Formal (Eq_Op)) /= Full_Type then 2557 2558 -- Inherited equality from parent type. Convert the actuals to 2559 -- match signature of operation. 2560 2561 declare 2562 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2563 2564 begin 2565 return 2566 Make_Function_Call (Loc, 2567 Name => New_Occurrence_Of (Eq_Op, Loc), 2568 Parameter_Associations => New_List ( 2569 OK_Convert_To (T, Lhs), 2570 OK_Convert_To (T, Rhs))); 2571 end; 2572 2573 else 2574 -- Comparison between Unchecked_Union components 2575 2576 if Is_Unchecked_Union (Full_Type) then 2577 declare 2578 Lhs_Type : Node_Id := Full_Type; 2579 Rhs_Type : Node_Id := Full_Type; 2580 Lhs_Discr_Val : Node_Id; 2581 Rhs_Discr_Val : Node_Id; 2582 2583 begin 2584 -- Lhs subtype 2585 2586 if Nkind (Lhs) = N_Selected_Component then 2587 Lhs_Type := Etype (Entity (Selector_Name (Lhs))); 2588 end if; 2589 2590 -- Rhs subtype 2591 2592 if Nkind (Rhs) = N_Selected_Component then 2593 Rhs_Type := Etype (Entity (Selector_Name (Rhs))); 2594 end if; 2595 2596 -- Lhs of the composite equality 2597 2598 if Is_Constrained (Lhs_Type) then 2599 2600 -- Since the enclosing record type can never be an 2601 -- Unchecked_Union (this code is executed for records 2602 -- that do not have variants), we may reference its 2603 -- discriminant(s). 2604 2605 if Nkind (Lhs) = N_Selected_Component 2606 and then Has_Per_Object_Constraint 2607 (Entity (Selector_Name (Lhs))) 2608 then 2609 Lhs_Discr_Val := 2610 Make_Selected_Component (Loc, 2611 Prefix => Prefix (Lhs), 2612 Selector_Name => 2613 New_Copy 2614 (Get_Discriminant_Value 2615 (First_Discriminant (Lhs_Type), 2616 Lhs_Type, 2617 Stored_Constraint (Lhs_Type)))); 2618 2619 else 2620 Lhs_Discr_Val := 2621 New_Copy 2622 (Get_Discriminant_Value 2623 (First_Discriminant (Lhs_Type), 2624 Lhs_Type, 2625 Stored_Constraint (Lhs_Type))); 2626 2627 end if; 2628 else 2629 -- It is not possible to infer the discriminant since 2630 -- the subtype is not constrained. 2631 2632 return 2633 Make_Raise_Program_Error (Loc, 2634 Reason => PE_Unchecked_Union_Restriction); 2635 end if; 2636 2637 -- Rhs of the composite equality 2638 2639 if Is_Constrained (Rhs_Type) then 2640 if Nkind (Rhs) = N_Selected_Component 2641 and then Has_Per_Object_Constraint 2642 (Entity (Selector_Name (Rhs))) 2643 then 2644 Rhs_Discr_Val := 2645 Make_Selected_Component (Loc, 2646 Prefix => Prefix (Rhs), 2647 Selector_Name => 2648 New_Copy 2649 (Get_Discriminant_Value 2650 (First_Discriminant (Rhs_Type), 2651 Rhs_Type, 2652 Stored_Constraint (Rhs_Type)))); 2653 2654 else 2655 Rhs_Discr_Val := 2656 New_Copy 2657 (Get_Discriminant_Value 2658 (First_Discriminant (Rhs_Type), 2659 Rhs_Type, 2660 Stored_Constraint (Rhs_Type))); 2661 2662 end if; 2663 else 2664 return 2665 Make_Raise_Program_Error (Loc, 2666 Reason => PE_Unchecked_Union_Restriction); 2667 end if; 2668 2669 -- Call the TSS equality function with the inferred 2670 -- discriminant values. 2671 2672 return 2673 Make_Function_Call (Loc, 2674 Name => New_Occurrence_Of (Eq_Op, Loc), 2675 Parameter_Associations => New_List ( 2676 Lhs, 2677 Rhs, 2678 Lhs_Discr_Val, 2679 Rhs_Discr_Val)); 2680 end; 2681 2682 -- All cases other than comparing Unchecked_Union types 2683 2684 else 2685 declare 2686 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2687 begin 2688 return 2689 Make_Function_Call (Loc, 2690 Name => 2691 New_Occurrence_Of (Eq_Op, Loc), 2692 Parameter_Associations => New_List ( 2693 OK_Convert_To (T, Lhs), 2694 OK_Convert_To (T, Rhs))); 2695 end; 2696 end if; 2697 end if; 2698 2699 -- Equality composes in Ada 2012 for untagged record types. It also 2700 -- composes for bounded strings, because they are part of the 2701 -- predefined environment. We could make it compose for bounded 2702 -- strings by making them tagged, or by making sure all subcomponents 2703 -- are set to the same value, even when not used. Instead, we have 2704 -- this special case in the compiler, because it's more efficient. 2705 2706 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then 2707 2708 -- If no TSS has been created for the type, check whether there is 2709 -- a primitive equality declared for it. 2710 2711 declare 2712 Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs); 2713 2714 begin 2715 -- Use user-defined primitive if it exists, otherwise use 2716 -- predefined equality. 2717 2718 if Present (Op) then 2719 return Op; 2720 else 2721 return Make_Op_Eq (Loc, Lhs, Rhs); 2722 end if; 2723 end; 2724 2725 else 2726 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); 2727 end if; 2728 2729 -- Non-composite types (always use predefined equality) 2730 2731 else 2732 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2733 end if; 2734 end Expand_Composite_Equality; 2735 2736 ------------------------ 2737 -- Expand_Concatenate -- 2738 ------------------------ 2739 2740 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is 2741 Loc : constant Source_Ptr := Sloc (Cnode); 2742 2743 Atyp : constant Entity_Id := Base_Type (Etype (Cnode)); 2744 -- Result type of concatenation 2745 2746 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode))); 2747 -- Component type. Elements of this component type can appear as one 2748 -- of the operands of concatenation as well as arrays. 2749 2750 Istyp : constant Entity_Id := Etype (First_Index (Atyp)); 2751 -- Index subtype 2752 2753 Ityp : constant Entity_Id := Base_Type (Istyp); 2754 -- Index type. This is the base type of the index subtype, and is used 2755 -- for all computed bounds (which may be out of range of Istyp in the 2756 -- case of null ranges). 2757 2758 Artyp : Entity_Id; 2759 -- This is the type we use to do arithmetic to compute the bounds and 2760 -- lengths of operands. The choice of this type is a little subtle and 2761 -- is discussed in a separate section at the start of the body code. 2762 2763 Concatenation_Error : exception; 2764 -- Raised if concatenation is sure to raise a CE 2765 2766 Result_May_Be_Null : Boolean := True; 2767 -- Reset to False if at least one operand is encountered which is known 2768 -- at compile time to be non-null. Used for handling the special case 2769 -- of setting the high bound to the last operand high bound for a null 2770 -- result, thus ensuring a proper high bound in the super-flat case. 2771 2772 N : constant Nat := List_Length (Opnds); 2773 -- Number of concatenation operands including possibly null operands 2774 2775 NN : Nat := 0; 2776 -- Number of operands excluding any known to be null, except that the 2777 -- last operand is always retained, in case it provides the bounds for 2778 -- a null result. 2779 2780 Opnd : Node_Id := Empty; 2781 -- Current operand being processed in the loop through operands. After 2782 -- this loop is complete, always contains the last operand (which is not 2783 -- the same as Operands (NN), since null operands are skipped). 2784 2785 -- Arrays describing the operands, only the first NN entries of each 2786 -- array are set (NN < N when we exclude known null operands). 2787 2788 Is_Fixed_Length : array (1 .. N) of Boolean; 2789 -- True if length of corresponding operand known at compile time 2790 2791 Operands : array (1 .. N) of Node_Id; 2792 -- Set to the corresponding entry in the Opnds list (but note that null 2793 -- operands are excluded, so not all entries in the list are stored). 2794 2795 Fixed_Length : array (1 .. N) of Uint; 2796 -- Set to length of operand. Entries in this array are set only if the 2797 -- corresponding entry in Is_Fixed_Length is True. 2798 2799 Opnd_Low_Bound : array (1 .. N) of Node_Id; 2800 -- Set to lower bound of operand. Either an integer literal in the case 2801 -- where the bound is known at compile time, else actual lower bound. 2802 -- The operand low bound is of type Ityp. 2803 2804 Var_Length : array (1 .. N) of Entity_Id; 2805 -- Set to an entity of type Natural that contains the length of an 2806 -- operand whose length is not known at compile time. Entries in this 2807 -- array are set only if the corresponding entry in Is_Fixed_Length 2808 -- is False. The entity is of type Artyp. 2809 2810 Aggr_Length : array (0 .. N) of Node_Id; 2811 -- The J'th entry in an expression node that represents the total length 2812 -- of operands 1 through J. It is either an integer literal node, or a 2813 -- reference to a constant entity with the right value, so it is fine 2814 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth 2815 -- entry always is set to zero. The length is of type Artyp. 2816 2817 Low_Bound : Node_Id; 2818 -- A tree node representing the low bound of the result (of type Ityp). 2819 -- This is either an integer literal node, or an identifier reference to 2820 -- a constant entity initialized to the appropriate value. 2821 2822 Last_Opnd_Low_Bound : Node_Id := Empty; 2823 -- A tree node representing the low bound of the last operand. This 2824 -- need only be set if the result could be null. It is used for the 2825 -- special case of setting the right low bound for a null result. 2826 -- This is of type Ityp. 2827 2828 Last_Opnd_High_Bound : Node_Id := Empty; 2829 -- A tree node representing the high bound of the last operand. This 2830 -- need only be set if the result could be null. It is used for the 2831 -- special case of setting the right high bound for a null result. 2832 -- This is of type Ityp. 2833 2834 High_Bound : Node_Id := Empty; 2835 -- A tree node representing the high bound of the result (of type Ityp) 2836 2837 Result : Node_Id; 2838 -- Result of the concatenation (of type Ityp) 2839 2840 Actions : constant List_Id := New_List; 2841 -- Collect actions to be inserted 2842 2843 Known_Non_Null_Operand_Seen : Boolean; 2844 -- Set True during generation of the assignments of operands into 2845 -- result once an operand known to be non-null has been seen. 2846 2847 function Library_Level_Target return Boolean; 2848 -- Return True if the concatenation is within the expression of the 2849 -- declaration of a library-level object. 2850 2851 function Make_Artyp_Literal (Val : Nat) return Node_Id; 2852 -- This function makes an N_Integer_Literal node that is returned in 2853 -- analyzed form with the type set to Artyp. Importantly this literal 2854 -- is not flagged as static, so that if we do computations with it that 2855 -- result in statically detected out of range conditions, we will not 2856 -- generate error messages but instead warning messages. 2857 2858 function To_Artyp (X : Node_Id) return Node_Id; 2859 -- Given a node of type Ityp, returns the corresponding value of type 2860 -- Artyp. For non-enumeration types, this is a plain integer conversion. 2861 -- For enum types, the Pos of the value is returned. 2862 2863 function To_Ityp (X : Node_Id) return Node_Id; 2864 -- The inverse function (uses Val in the case of enumeration types) 2865 2866 -------------------------- 2867 -- Library_Level_Target -- 2868 -------------------------- 2869 2870 function Library_Level_Target return Boolean is 2871 P : Node_Id := Parent (Cnode); 2872 2873 begin 2874 while Present (P) loop 2875 if Nkind (P) = N_Object_Declaration then 2876 return Is_Library_Level_Entity (Defining_Identifier (P)); 2877 2878 -- Prevent the search from going too far 2879 2880 elsif Is_Body_Or_Package_Declaration (P) then 2881 return False; 2882 end if; 2883 2884 P := Parent (P); 2885 end loop; 2886 2887 return False; 2888 end Library_Level_Target; 2889 2890 ------------------------ 2891 -- Make_Artyp_Literal -- 2892 ------------------------ 2893 2894 function Make_Artyp_Literal (Val : Nat) return Node_Id is 2895 Result : constant Node_Id := Make_Integer_Literal (Loc, Val); 2896 begin 2897 Set_Etype (Result, Artyp); 2898 Set_Analyzed (Result, True); 2899 Set_Is_Static_Expression (Result, False); 2900 return Result; 2901 end Make_Artyp_Literal; 2902 2903 -------------- 2904 -- To_Artyp -- 2905 -------------- 2906 2907 function To_Artyp (X : Node_Id) return Node_Id is 2908 begin 2909 if Ityp = Base_Type (Artyp) then 2910 return X; 2911 2912 elsif Is_Enumeration_Type (Ityp) then 2913 return 2914 Make_Attribute_Reference (Loc, 2915 Prefix => New_Occurrence_Of (Ityp, Loc), 2916 Attribute_Name => Name_Pos, 2917 Expressions => New_List (X)); 2918 2919 else 2920 return Convert_To (Artyp, X); 2921 end if; 2922 end To_Artyp; 2923 2924 ------------- 2925 -- To_Ityp -- 2926 ------------- 2927 2928 function To_Ityp (X : Node_Id) return Node_Id is 2929 begin 2930 if Is_Enumeration_Type (Ityp) then 2931 return 2932 Make_Attribute_Reference (Loc, 2933 Prefix => New_Occurrence_Of (Ityp, Loc), 2934 Attribute_Name => Name_Val, 2935 Expressions => New_List (X)); 2936 2937 -- Case where we will do a type conversion 2938 2939 else 2940 if Ityp = Base_Type (Artyp) then 2941 return X; 2942 else 2943 return Convert_To (Ityp, X); 2944 end if; 2945 end if; 2946 end To_Ityp; 2947 2948 -- Local Declarations 2949 2950 Opnd_Typ : Entity_Id; 2951 Ent : Entity_Id; 2952 Len : Uint; 2953 J : Nat; 2954 Clen : Node_Id; 2955 Set : Boolean; 2956 2957 -- Start of processing for Expand_Concatenate 2958 2959 begin 2960 -- Choose an appropriate computational type 2961 2962 -- We will be doing calculations of lengths and bounds in this routine 2963 -- and computing one from the other in some cases, e.g. getting the high 2964 -- bound by adding the length-1 to the low bound. 2965 2966 -- We can't just use the index type, or even its base type for this 2967 -- purpose for two reasons. First it might be an enumeration type which 2968 -- is not suitable for computations of any kind, and second it may 2969 -- simply not have enough range. For example if the index type is 2970 -- -128..+127 then lengths can be up to 256, which is out of range of 2971 -- the type. 2972 2973 -- For enumeration types, we can simply use Standard_Integer, this is 2974 -- sufficient since the actual number of enumeration literals cannot 2975 -- possibly exceed the range of integer (remember we will be doing the 2976 -- arithmetic with POS values, not representation values). 2977 2978 if Is_Enumeration_Type (Ityp) then 2979 Artyp := Standard_Integer; 2980 2981 -- If index type is Positive, we use the standard unsigned type, to give 2982 -- more room on the top of the range, obviating the need for an overflow 2983 -- check when creating the upper bound. This is needed to avoid junk 2984 -- overflow checks in the common case of String types. 2985 2986 -- ??? Disabled for now 2987 2988 -- elsif Istyp = Standard_Positive then 2989 -- Artyp := Standard_Unsigned; 2990 2991 -- For modular types, we use a 32-bit modular type for types whose size 2992 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the 2993 -- identity type, and for larger unsigned types we use 64-bits. 2994 2995 elsif Is_Modular_Integer_Type (Ityp) then 2996 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then 2997 Artyp := Standard_Unsigned; 2998 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then 2999 Artyp := Ityp; 3000 else 3001 Artyp := RTE (RE_Long_Long_Unsigned); 3002 end if; 3003 3004 -- Similar treatment for signed types 3005 3006 else 3007 if RM_Size (Ityp) < RM_Size (Standard_Integer) then 3008 Artyp := Standard_Integer; 3009 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then 3010 Artyp := Ityp; 3011 else 3012 Artyp := Standard_Long_Long_Integer; 3013 end if; 3014 end if; 3015 3016 -- Supply dummy entry at start of length array 3017 3018 Aggr_Length (0) := Make_Artyp_Literal (0); 3019 3020 -- Go through operands setting up the above arrays 3021 3022 J := 1; 3023 while J <= N loop 3024 Opnd := Remove_Head (Opnds); 3025 Opnd_Typ := Etype (Opnd); 3026 3027 -- The parent got messed up when we put the operands in a list, 3028 -- so now put back the proper parent for the saved operand, that 3029 -- is to say the concatenation node, to make sure that each operand 3030 -- is seen as a subexpression, e.g. if actions must be inserted. 3031 3032 Set_Parent (Opnd, Cnode); 3033 3034 -- Set will be True when we have setup one entry in the array 3035 3036 Set := False; 3037 3038 -- Singleton element (or character literal) case 3039 3040 if Base_Type (Opnd_Typ) = Ctyp then 3041 NN := NN + 1; 3042 Operands (NN) := Opnd; 3043 Is_Fixed_Length (NN) := True; 3044 Fixed_Length (NN) := Uint_1; 3045 Result_May_Be_Null := False; 3046 3047 -- Set low bound of operand (no need to set Last_Opnd_High_Bound 3048 -- since we know that the result cannot be null). 3049 3050 Opnd_Low_Bound (NN) := 3051 Make_Attribute_Reference (Loc, 3052 Prefix => New_Occurrence_Of (Istyp, Loc), 3053 Attribute_Name => Name_First); 3054 3055 Set := True; 3056 3057 -- String literal case (can only occur for strings of course) 3058 3059 elsif Nkind (Opnd) = N_String_Literal then 3060 Len := String_Literal_Length (Opnd_Typ); 3061 3062 if Len /= 0 then 3063 Result_May_Be_Null := False; 3064 end if; 3065 3066 -- Capture last operand low and high bound if result could be null 3067 3068 if J = N and then Result_May_Be_Null then 3069 Last_Opnd_Low_Bound := 3070 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3071 3072 Last_Opnd_High_Bound := 3073 Make_Op_Subtract (Loc, 3074 Left_Opnd => 3075 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), 3076 Right_Opnd => Make_Integer_Literal (Loc, 1)); 3077 end if; 3078 3079 -- Skip null string literal 3080 3081 if J < N and then Len = 0 then 3082 goto Continue; 3083 end if; 3084 3085 NN := NN + 1; 3086 Operands (NN) := Opnd; 3087 Is_Fixed_Length (NN) := True; 3088 3089 -- Set length and bounds 3090 3091 Fixed_Length (NN) := Len; 3092 3093 Opnd_Low_Bound (NN) := 3094 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3095 3096 Set := True; 3097 3098 -- All other cases 3099 3100 else 3101 -- Check constrained case with known bounds 3102 3103 if Is_Constrained (Opnd_Typ) then 3104 declare 3105 Index : constant Node_Id := First_Index (Opnd_Typ); 3106 Indx_Typ : constant Entity_Id := Etype (Index); 3107 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ); 3108 Hi : constant Node_Id := Type_High_Bound (Indx_Typ); 3109 3110 begin 3111 -- Fixed length constrained array type with known at compile 3112 -- time bounds is last case of fixed length operand. 3113 3114 if Compile_Time_Known_Value (Lo) 3115 and then 3116 Compile_Time_Known_Value (Hi) 3117 then 3118 declare 3119 Loval : constant Uint := Expr_Value (Lo); 3120 Hival : constant Uint := Expr_Value (Hi); 3121 Len : constant Uint := 3122 UI_Max (Hival - Loval + 1, Uint_0); 3123 3124 begin 3125 if Len > 0 then 3126 Result_May_Be_Null := False; 3127 end if; 3128 3129 -- Capture last operand bounds if result could be null 3130 3131 if J = N and then Result_May_Be_Null then 3132 Last_Opnd_Low_Bound := 3133 Convert_To (Ityp, 3134 Make_Integer_Literal (Loc, Expr_Value (Lo))); 3135 3136 Last_Opnd_High_Bound := 3137 Convert_To (Ityp, 3138 Make_Integer_Literal (Loc, Expr_Value (Hi))); 3139 end if; 3140 3141 -- Exclude null length case unless last operand 3142 3143 if J < N and then Len = 0 then 3144 goto Continue; 3145 end if; 3146 3147 NN := NN + 1; 3148 Operands (NN) := Opnd; 3149 Is_Fixed_Length (NN) := True; 3150 Fixed_Length (NN) := Len; 3151 3152 Opnd_Low_Bound (NN) := 3153 To_Ityp 3154 (Make_Integer_Literal (Loc, Expr_Value (Lo))); 3155 Set := True; 3156 end; 3157 end if; 3158 end; 3159 end if; 3160 3161 -- All cases where the length is not known at compile time, or the 3162 -- special case of an operand which is known to be null but has a 3163 -- lower bound other than 1 or is other than a string type. 3164 3165 if not Set then 3166 NN := NN + 1; 3167 3168 -- Capture operand bounds 3169 3170 Opnd_Low_Bound (NN) := 3171 Make_Attribute_Reference (Loc, 3172 Prefix => 3173 Duplicate_Subexpr (Opnd, Name_Req => True), 3174 Attribute_Name => Name_First); 3175 3176 -- Capture last operand bounds if result could be null 3177 3178 if J = N and Result_May_Be_Null then 3179 Last_Opnd_Low_Bound := 3180 Convert_To (Ityp, 3181 Make_Attribute_Reference (Loc, 3182 Prefix => 3183 Duplicate_Subexpr (Opnd, Name_Req => True), 3184 Attribute_Name => Name_First)); 3185 3186 Last_Opnd_High_Bound := 3187 Convert_To (Ityp, 3188 Make_Attribute_Reference (Loc, 3189 Prefix => 3190 Duplicate_Subexpr (Opnd, Name_Req => True), 3191 Attribute_Name => Name_Last)); 3192 end if; 3193 3194 -- Capture length of operand in entity 3195 3196 Operands (NN) := Opnd; 3197 Is_Fixed_Length (NN) := False; 3198 3199 Var_Length (NN) := Make_Temporary (Loc, 'L'); 3200 3201 Append_To (Actions, 3202 Make_Object_Declaration (Loc, 3203 Defining_Identifier => Var_Length (NN), 3204 Constant_Present => True, 3205 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3206 Expression => 3207 Make_Attribute_Reference (Loc, 3208 Prefix => 3209 Duplicate_Subexpr (Opnd, Name_Req => True), 3210 Attribute_Name => Name_Length))); 3211 end if; 3212 end if; 3213 3214 -- Set next entry in aggregate length array 3215 3216 -- For first entry, make either integer literal for fixed length 3217 -- or a reference to the saved length for variable length. 3218 3219 if NN = 1 then 3220 if Is_Fixed_Length (1) then 3221 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1)); 3222 else 3223 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc); 3224 end if; 3225 3226 -- If entry is fixed length and only fixed lengths so far, make 3227 -- appropriate new integer literal adding new length. 3228 3229 elsif Is_Fixed_Length (NN) 3230 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal 3231 then 3232 Aggr_Length (NN) := 3233 Make_Integer_Literal (Loc, 3234 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1))); 3235 3236 -- All other cases, construct an addition node for the length and 3237 -- create an entity initialized to this length. 3238 3239 else 3240 Ent := Make_Temporary (Loc, 'L'); 3241 3242 if Is_Fixed_Length (NN) then 3243 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); 3244 else 3245 Clen := New_Occurrence_Of (Var_Length (NN), Loc); 3246 end if; 3247 3248 Append_To (Actions, 3249 Make_Object_Declaration (Loc, 3250 Defining_Identifier => Ent, 3251 Constant_Present => True, 3252 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3253 Expression => 3254 Make_Op_Add (Loc, 3255 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)), 3256 Right_Opnd => Clen))); 3257 3258 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent)); 3259 end if; 3260 3261 <<Continue>> 3262 J := J + 1; 3263 end loop; 3264 3265 -- If we have only skipped null operands, return the last operand 3266 3267 if NN = 0 then 3268 Result := Opnd; 3269 goto Done; 3270 end if; 3271 3272 -- If we have only one non-null operand, return it and we are done. 3273 -- There is one case in which this cannot be done, and that is when 3274 -- the sole operand is of the element type, in which case it must be 3275 -- converted to an array, and the easiest way of doing that is to go 3276 -- through the normal general circuit. 3277 3278 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then 3279 Result := Operands (1); 3280 goto Done; 3281 end if; 3282 3283 -- Cases where we have a real concatenation 3284 3285 -- Next step is to find the low bound for the result array that we 3286 -- will allocate. The rules for this are in (RM 4.5.6(5-7)). 3287 3288 -- If the ultimate ancestor of the index subtype is a constrained array 3289 -- definition, then the lower bound is that of the index subtype as 3290 -- specified by (RM 4.5.3(6)). 3291 3292 -- The right test here is to go to the root type, and then the ultimate 3293 -- ancestor is the first subtype of this root type. 3294 3295 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then 3296 Low_Bound := 3297 Make_Attribute_Reference (Loc, 3298 Prefix => 3299 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc), 3300 Attribute_Name => Name_First); 3301 3302 -- If the first operand in the list has known length we know that 3303 -- the lower bound of the result is the lower bound of this operand. 3304 3305 elsif Is_Fixed_Length (1) then 3306 Low_Bound := Opnd_Low_Bound (1); 3307 3308 -- OK, we don't know the lower bound, we have to build a horrible 3309 -- if expression node of the form 3310 3311 -- if Cond1'Length /= 0 then 3312 -- Opnd1 low bound 3313 -- else 3314 -- if Opnd2'Length /= 0 then 3315 -- Opnd2 low bound 3316 -- else 3317 -- ... 3318 3319 -- The nesting ends either when we hit an operand whose length is known 3320 -- at compile time, or on reaching the last operand, whose low bound we 3321 -- take unconditionally whether or not it is null. It's easiest to do 3322 -- this with a recursive procedure: 3323 3324 else 3325 declare 3326 function Get_Known_Bound (J : Nat) return Node_Id; 3327 -- Returns the lower bound determined by operands J .. NN 3328 3329 --------------------- 3330 -- Get_Known_Bound -- 3331 --------------------- 3332 3333 function Get_Known_Bound (J : Nat) return Node_Id is 3334 begin 3335 if Is_Fixed_Length (J) or else J = NN then 3336 return New_Copy_Tree (Opnd_Low_Bound (J)); 3337 3338 else 3339 return 3340 Make_If_Expression (Loc, 3341 Expressions => New_List ( 3342 3343 Make_Op_Ne (Loc, 3344 Left_Opnd => 3345 New_Occurrence_Of (Var_Length (J), Loc), 3346 Right_Opnd => 3347 Make_Integer_Literal (Loc, 0)), 3348 3349 New_Copy_Tree (Opnd_Low_Bound (J)), 3350 Get_Known_Bound (J + 1))); 3351 end if; 3352 end Get_Known_Bound; 3353 3354 begin 3355 Ent := Make_Temporary (Loc, 'L'); 3356 3357 Append_To (Actions, 3358 Make_Object_Declaration (Loc, 3359 Defining_Identifier => Ent, 3360 Constant_Present => True, 3361 Object_Definition => New_Occurrence_Of (Ityp, Loc), 3362 Expression => Get_Known_Bound (1))); 3363 3364 Low_Bound := New_Occurrence_Of (Ent, Loc); 3365 end; 3366 end if; 3367 3368 -- Now we can safely compute the upper bound, normally 3369 -- Low_Bound + Length - 1. 3370 3371 High_Bound := 3372 To_Ityp 3373 (Make_Op_Add (Loc, 3374 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3375 Right_Opnd => 3376 Make_Op_Subtract (Loc, 3377 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3378 Right_Opnd => Make_Artyp_Literal (1)))); 3379 3380 -- Note that calculation of the high bound may cause overflow in some 3381 -- very weird cases, so in the general case we need an overflow check on 3382 -- the high bound. We can avoid this for the common case of string types 3383 -- and other types whose index is Positive, since we chose a wider range 3384 -- for the arithmetic type. If checks are suppressed we do not set the 3385 -- flag, and possibly superfluous warnings will be omitted. 3386 3387 if Istyp /= Standard_Positive 3388 and then not Overflow_Checks_Suppressed (Istyp) 3389 then 3390 Activate_Overflow_Check (High_Bound); 3391 end if; 3392 3393 -- Handle the exceptional case where the result is null, in which case 3394 -- case the bounds come from the last operand (so that we get the proper 3395 -- bounds if the last operand is super-flat). 3396 3397 if Result_May_Be_Null then 3398 Low_Bound := 3399 Make_If_Expression (Loc, 3400 Expressions => New_List ( 3401 Make_Op_Eq (Loc, 3402 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3403 Right_Opnd => Make_Artyp_Literal (0)), 3404 Last_Opnd_Low_Bound, 3405 Low_Bound)); 3406 3407 High_Bound := 3408 Make_If_Expression (Loc, 3409 Expressions => New_List ( 3410 Make_Op_Eq (Loc, 3411 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3412 Right_Opnd => Make_Artyp_Literal (0)), 3413 Last_Opnd_High_Bound, 3414 High_Bound)); 3415 end if; 3416 3417 -- Here is where we insert the saved up actions 3418 3419 Insert_Actions (Cnode, Actions, Suppress => All_Checks); 3420 3421 -- Now we construct an array object with appropriate bounds. We mark 3422 -- the target as internal to prevent useless initialization when 3423 -- Initialize_Scalars is enabled. Also since this is the actual result 3424 -- entity, we make sure we have debug information for the result. 3425 3426 Ent := Make_Temporary (Loc, 'S'); 3427 Set_Is_Internal (Ent); 3428 Set_Debug_Info_Needed (Ent); 3429 3430 -- If the bound is statically known to be out of range, we do not want 3431 -- to abort, we want a warning and a runtime constraint error. Note that 3432 -- we have arranged that the result will not be treated as a static 3433 -- constant, so we won't get an illegality during this insertion. 3434 3435 Insert_Action (Cnode, 3436 Make_Object_Declaration (Loc, 3437 Defining_Identifier => Ent, 3438 Object_Definition => 3439 Make_Subtype_Indication (Loc, 3440 Subtype_Mark => New_Occurrence_Of (Atyp, Loc), 3441 Constraint => 3442 Make_Index_Or_Discriminant_Constraint (Loc, 3443 Constraints => New_List ( 3444 Make_Range (Loc, 3445 Low_Bound => Low_Bound, 3446 High_Bound => High_Bound))))), 3447 Suppress => All_Checks); 3448 3449 -- If the result of the concatenation appears as the initializing 3450 -- expression of an object declaration, we can just rename the 3451 -- result, rather than copying it. 3452 3453 Set_OK_To_Rename (Ent); 3454 3455 -- Catch the static out of range case now 3456 3457 if Raises_Constraint_Error (High_Bound) then 3458 raise Concatenation_Error; 3459 end if; 3460 3461 -- Now we will generate the assignments to do the actual concatenation 3462 3463 -- There is one case in which we will not do this, namely when all the 3464 -- following conditions are met: 3465 3466 -- The result type is Standard.String 3467 3468 -- There are nine or fewer retained (non-null) operands 3469 3470 -- The optimization level is -O0 or the debug flag gnatd.C is set, 3471 -- and the debug flag gnatd.c is not set. 3472 3473 -- The corresponding System.Concat_n.Str_Concat_n routine is 3474 -- available in the run time. 3475 3476 -- If all these conditions are met then we generate a call to the 3477 -- relevant concatenation routine. The purpose of this is to avoid 3478 -- undesirable code bloat at -O0. 3479 3480 -- If the concatenation is within the declaration of a library-level 3481 -- object, we call the built-in concatenation routines to prevent code 3482 -- bloat, regardless of the optimization level. This is space efficient 3483 -- and prevents linking problems when units are compiled with different 3484 -- optimization levels. 3485 3486 if Atyp = Standard_String 3487 and then NN in 2 .. 9 3488 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC) 3489 and then not Debug_Flag_Dot_C) 3490 or else Library_Level_Target) 3491 then 3492 declare 3493 RR : constant array (Nat range 2 .. 9) of RE_Id := 3494 (RE_Str_Concat_2, 3495 RE_Str_Concat_3, 3496 RE_Str_Concat_4, 3497 RE_Str_Concat_5, 3498 RE_Str_Concat_6, 3499 RE_Str_Concat_7, 3500 RE_Str_Concat_8, 3501 RE_Str_Concat_9); 3502 3503 begin 3504 if RTE_Available (RR (NN)) then 3505 declare 3506 Opnds : constant List_Id := 3507 New_List (New_Occurrence_Of (Ent, Loc)); 3508 3509 begin 3510 for J in 1 .. NN loop 3511 if Is_List_Member (Operands (J)) then 3512 Remove (Operands (J)); 3513 end if; 3514 3515 if Base_Type (Etype (Operands (J))) = Ctyp then 3516 Append_To (Opnds, 3517 Make_Aggregate (Loc, 3518 Component_Associations => New_List ( 3519 Make_Component_Association (Loc, 3520 Choices => New_List ( 3521 Make_Integer_Literal (Loc, 1)), 3522 Expression => Operands (J))))); 3523 3524 else 3525 Append_To (Opnds, Operands (J)); 3526 end if; 3527 end loop; 3528 3529 Insert_Action (Cnode, 3530 Make_Procedure_Call_Statement (Loc, 3531 Name => New_Occurrence_Of (RTE (RR (NN)), Loc), 3532 Parameter_Associations => Opnds)); 3533 3534 Result := New_Occurrence_Of (Ent, Loc); 3535 goto Done; 3536 end; 3537 end if; 3538 end; 3539 end if; 3540 3541 -- Not special case so generate the assignments 3542 3543 Known_Non_Null_Operand_Seen := False; 3544 3545 for J in 1 .. NN loop 3546 declare 3547 Lo : constant Node_Id := 3548 Make_Op_Add (Loc, 3549 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3550 Right_Opnd => Aggr_Length (J - 1)); 3551 3552 Hi : constant Node_Id := 3553 Make_Op_Add (Loc, 3554 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3555 Right_Opnd => 3556 Make_Op_Subtract (Loc, 3557 Left_Opnd => Aggr_Length (J), 3558 Right_Opnd => Make_Artyp_Literal (1))); 3559 3560 begin 3561 -- Singleton case, simple assignment 3562 3563 if Base_Type (Etype (Operands (J))) = Ctyp then 3564 Known_Non_Null_Operand_Seen := True; 3565 Insert_Action (Cnode, 3566 Make_Assignment_Statement (Loc, 3567 Name => 3568 Make_Indexed_Component (Loc, 3569 Prefix => New_Occurrence_Of (Ent, Loc), 3570 Expressions => New_List (To_Ityp (Lo))), 3571 Expression => Operands (J)), 3572 Suppress => All_Checks); 3573 3574 -- Array case, slice assignment, skipped when argument is fixed 3575 -- length and known to be null. 3576 3577 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then 3578 declare 3579 Assign : Node_Id := 3580 Make_Assignment_Statement (Loc, 3581 Name => 3582 Make_Slice (Loc, 3583 Prefix => 3584 New_Occurrence_Of (Ent, Loc), 3585 Discrete_Range => 3586 Make_Range (Loc, 3587 Low_Bound => To_Ityp (Lo), 3588 High_Bound => To_Ityp (Hi))), 3589 Expression => Operands (J)); 3590 begin 3591 if Is_Fixed_Length (J) then 3592 Known_Non_Null_Operand_Seen := True; 3593 3594 elsif not Known_Non_Null_Operand_Seen then 3595 3596 -- Here if operand length is not statically known and no 3597 -- operand known to be non-null has been processed yet. 3598 -- If operand length is 0, we do not need to perform the 3599 -- assignment, and we must avoid the evaluation of the 3600 -- high bound of the slice, since it may underflow if the 3601 -- low bound is Ityp'First. 3602 3603 Assign := 3604 Make_Implicit_If_Statement (Cnode, 3605 Condition => 3606 Make_Op_Ne (Loc, 3607 Left_Opnd => 3608 New_Occurrence_Of (Var_Length (J), Loc), 3609 Right_Opnd => Make_Integer_Literal (Loc, 0)), 3610 Then_Statements => New_List (Assign)); 3611 end if; 3612 3613 Insert_Action (Cnode, Assign, Suppress => All_Checks); 3614 end; 3615 end if; 3616 end; 3617 end loop; 3618 3619 -- Finally we build the result, which is a reference to the array object 3620 3621 Result := New_Occurrence_Of (Ent, Loc); 3622 3623 <<Done>> 3624 Rewrite (Cnode, Result); 3625 Analyze_And_Resolve (Cnode, Atyp); 3626 3627 exception 3628 when Concatenation_Error => 3629 3630 -- Kill warning generated for the declaration of the static out of 3631 -- range high bound, and instead generate a Constraint_Error with 3632 -- an appropriate specific message. 3633 3634 Kill_Dead_Code (Declaration_Node (Entity (High_Bound))); 3635 Apply_Compile_Time_Constraint_Error 3636 (N => Cnode, 3637 Msg => "concatenation result upper bound out of range??", 3638 Reason => CE_Range_Check_Failed); 3639 end Expand_Concatenate; 3640 3641 --------------------------------------------------- 3642 -- Expand_Membership_Minimize_Eliminate_Overflow -- 3643 --------------------------------------------------- 3644 3645 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is 3646 pragma Assert (Nkind (N) = N_In); 3647 -- Despite the name, this routine applies only to N_In, not to 3648 -- N_Not_In. The latter is always rewritten as not (X in Y). 3649 3650 Result_Type : constant Entity_Id := Etype (N); 3651 -- Capture result type, may be a derived boolean type 3652 3653 Loc : constant Source_Ptr := Sloc (N); 3654 Lop : constant Node_Id := Left_Opnd (N); 3655 Rop : constant Node_Id := Right_Opnd (N); 3656 3657 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It 3658 -- is thus tempting to capture these values, but due to the rewrites 3659 -- that occur as a result of overflow checking, these values change 3660 -- as we go along, and it is safe just to always use Etype explicitly. 3661 3662 Restype : constant Entity_Id := Etype (N); 3663 -- Save result type 3664 3665 Lo, Hi : Uint; 3666 -- Bounds in Minimize calls, not used currently 3667 3668 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 3669 -- Entity for Long_Long_Integer'Base (Standard should export this???) 3670 3671 begin 3672 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False); 3673 3674 -- If right operand is a subtype name, and the subtype name has no 3675 -- predicate, then we can just replace the right operand with an 3676 -- explicit range T'First .. T'Last, and use the explicit range code. 3677 3678 if Nkind (Rop) /= N_Range 3679 and then No (Predicate_Function (Etype (Rop))) 3680 then 3681 declare 3682 Rtyp : constant Entity_Id := Etype (Rop); 3683 begin 3684 Rewrite (Rop, 3685 Make_Range (Loc, 3686 Low_Bound => 3687 Make_Attribute_Reference (Loc, 3688 Attribute_Name => Name_First, 3689 Prefix => New_Occurrence_Of (Rtyp, Loc)), 3690 High_Bound => 3691 Make_Attribute_Reference (Loc, 3692 Attribute_Name => Name_Last, 3693 Prefix => New_Occurrence_Of (Rtyp, Loc)))); 3694 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks); 3695 end; 3696 end if; 3697 3698 -- Here for the explicit range case. Note that the bounds of the range 3699 -- have not been processed for minimized or eliminated checks. 3700 3701 if Nkind (Rop) = N_Range then 3702 Minimize_Eliminate_Overflows 3703 (Low_Bound (Rop), Lo, Hi, Top_Level => False); 3704 Minimize_Eliminate_Overflows 3705 (High_Bound (Rop), Lo, Hi, Top_Level => False); 3706 3707 -- We have A in B .. C, treated as A >= B and then A <= C 3708 3709 -- Bignum case 3710 3711 if Is_RTE (Etype (Lop), RE_Bignum) 3712 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum) 3713 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum) 3714 then 3715 declare 3716 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3717 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3718 L : constant Entity_Id := 3719 Make_Defining_Identifier (Loc, Name_uL); 3720 Lopnd : constant Node_Id := Convert_To_Bignum (Lop); 3721 Lbound : constant Node_Id := 3722 Convert_To_Bignum (Low_Bound (Rop)); 3723 Hbound : constant Node_Id := 3724 Convert_To_Bignum (High_Bound (Rop)); 3725 3726 -- Now we rewrite the membership test node to look like 3727 3728 -- do 3729 -- Bnn : Result_Type; 3730 -- declare 3731 -- M : Mark_Id := SS_Mark; 3732 -- L : Bignum := Lopnd; 3733 -- begin 3734 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound) 3735 -- SS_Release (M); 3736 -- end; 3737 -- in 3738 -- Bnn 3739 -- end 3740 3741 begin 3742 -- Insert declaration of L into declarations of bignum block 3743 3744 Insert_After 3745 (Last (Declarations (Blk)), 3746 Make_Object_Declaration (Loc, 3747 Defining_Identifier => L, 3748 Object_Definition => 3749 New_Occurrence_Of (RTE (RE_Bignum), Loc), 3750 Expression => Lopnd)); 3751 3752 -- Insert assignment to Bnn into expressions of bignum block 3753 3754 Insert_Before 3755 (First (Statements (Handled_Statement_Sequence (Blk))), 3756 Make_Assignment_Statement (Loc, 3757 Name => New_Occurrence_Of (Bnn, Loc), 3758 Expression => 3759 Make_And_Then (Loc, 3760 Left_Opnd => 3761 Make_Function_Call (Loc, 3762 Name => 3763 New_Occurrence_Of (RTE (RE_Big_GE), Loc), 3764 Parameter_Associations => New_List ( 3765 New_Occurrence_Of (L, Loc), 3766 Lbound)), 3767 3768 Right_Opnd => 3769 Make_Function_Call (Loc, 3770 Name => 3771 New_Occurrence_Of (RTE (RE_Big_LE), Loc), 3772 Parameter_Associations => New_List ( 3773 New_Occurrence_Of (L, Loc), 3774 Hbound))))); 3775 3776 -- Now rewrite the node 3777 3778 Rewrite (N, 3779 Make_Expression_With_Actions (Loc, 3780 Actions => New_List ( 3781 Make_Object_Declaration (Loc, 3782 Defining_Identifier => Bnn, 3783 Object_Definition => 3784 New_Occurrence_Of (Result_Type, Loc)), 3785 Blk), 3786 Expression => New_Occurrence_Of (Bnn, Loc))); 3787 Analyze_And_Resolve (N, Result_Type); 3788 return; 3789 end; 3790 3791 -- Here if no bignums around 3792 3793 else 3794 -- Case where types are all the same 3795 3796 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop))) 3797 and then 3798 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop))) 3799 then 3800 null; 3801 3802 -- If types are not all the same, it means that we have rewritten 3803 -- at least one of them to be of type Long_Long_Integer, and we 3804 -- will convert the other operands to Long_Long_Integer. 3805 3806 else 3807 Convert_To_And_Rewrite (LLIB, Lop); 3808 Set_Analyzed (Lop, False); 3809 Analyze_And_Resolve (Lop, LLIB); 3810 3811 -- For the right operand, avoid unnecessary recursion into 3812 -- this routine, we know that overflow is not possible. 3813 3814 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop)); 3815 Convert_To_And_Rewrite (LLIB, High_Bound (Rop)); 3816 Set_Analyzed (Rop, False); 3817 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check); 3818 end if; 3819 3820 -- Now the three operands are of the same signed integer type, 3821 -- so we can use the normal expansion routine for membership, 3822 -- setting the flag to prevent recursion into this procedure. 3823 3824 Set_No_Minimize_Eliminate (N); 3825 Expand_N_In (N); 3826 end if; 3827 3828 -- Right operand is a subtype name and the subtype has a predicate. We 3829 -- have to make sure the predicate is checked, and for that we need to 3830 -- use the standard N_In circuitry with appropriate types. 3831 3832 else 3833 pragma Assert (Present (Predicate_Function (Etype (Rop)))); 3834 3835 -- If types are "right", just call Expand_N_In preventing recursion 3836 3837 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then 3838 Set_No_Minimize_Eliminate (N); 3839 Expand_N_In (N); 3840 3841 -- Bignum case 3842 3843 elsif Is_RTE (Etype (Lop), RE_Bignum) then 3844 3845 -- For X in T, we want to rewrite our node as 3846 3847 -- do 3848 -- Bnn : Result_Type; 3849 3850 -- declare 3851 -- M : Mark_Id := SS_Mark; 3852 -- Lnn : Long_Long_Integer'Base 3853 -- Nnn : Bignum; 3854 3855 -- begin 3856 -- Nnn := X; 3857 3858 -- if not Bignum_In_LLI_Range (Nnn) then 3859 -- Bnn := False; 3860 -- else 3861 -- Lnn := From_Bignum (Nnn); 3862 -- Bnn := 3863 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last) 3864 -- and then T'Base (Lnn) in T; 3865 -- end if; 3866 3867 -- SS_Release (M); 3868 -- end 3869 -- in 3870 -- Bnn 3871 -- end 3872 3873 -- A bit gruesome, but there doesn't seem to be a simpler way 3874 3875 declare 3876 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3877 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3878 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N); 3879 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N); 3880 T : constant Entity_Id := Etype (Rop); 3881 TB : constant Entity_Id := Base_Type (T); 3882 Nin : Node_Id; 3883 3884 begin 3885 -- Mark the last membership operation to prevent recursion 3886 3887 Nin := 3888 Make_In (Loc, 3889 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)), 3890 Right_Opnd => New_Occurrence_Of (T, Loc)); 3891 Set_No_Minimize_Eliminate (Nin); 3892 3893 -- Now decorate the block 3894 3895 Insert_After 3896 (Last (Declarations (Blk)), 3897 Make_Object_Declaration (Loc, 3898 Defining_Identifier => Lnn, 3899 Object_Definition => New_Occurrence_Of (LLIB, Loc))); 3900 3901 Insert_After 3902 (Last (Declarations (Blk)), 3903 Make_Object_Declaration (Loc, 3904 Defining_Identifier => Nnn, 3905 Object_Definition => 3906 New_Occurrence_Of (RTE (RE_Bignum), Loc))); 3907 3908 Insert_List_Before 3909 (First (Statements (Handled_Statement_Sequence (Blk))), 3910 New_List ( 3911 Make_Assignment_Statement (Loc, 3912 Name => New_Occurrence_Of (Nnn, Loc), 3913 Expression => Relocate_Node (Lop)), 3914 3915 Make_Implicit_If_Statement (N, 3916 Condition => 3917 Make_Op_Not (Loc, 3918 Right_Opnd => 3919 Make_Function_Call (Loc, 3920 Name => 3921 New_Occurrence_Of 3922 (RTE (RE_Bignum_In_LLI_Range), Loc), 3923 Parameter_Associations => New_List ( 3924 New_Occurrence_Of (Nnn, Loc)))), 3925 3926 Then_Statements => New_List ( 3927 Make_Assignment_Statement (Loc, 3928 Name => New_Occurrence_Of (Bnn, Loc), 3929 Expression => 3930 New_Occurrence_Of (Standard_False, Loc))), 3931 3932 Else_Statements => New_List ( 3933 Make_Assignment_Statement (Loc, 3934 Name => New_Occurrence_Of (Lnn, Loc), 3935 Expression => 3936 Make_Function_Call (Loc, 3937 Name => 3938 New_Occurrence_Of (RTE (RE_From_Bignum), Loc), 3939 Parameter_Associations => New_List ( 3940 New_Occurrence_Of (Nnn, Loc)))), 3941 3942 Make_Assignment_Statement (Loc, 3943 Name => New_Occurrence_Of (Bnn, Loc), 3944 Expression => 3945 Make_And_Then (Loc, 3946 Left_Opnd => 3947 Make_In (Loc, 3948 Left_Opnd => New_Occurrence_Of (Lnn, Loc), 3949 Right_Opnd => 3950 Make_Range (Loc, 3951 Low_Bound => 3952 Convert_To (LLIB, 3953 Make_Attribute_Reference (Loc, 3954 Attribute_Name => Name_First, 3955 Prefix => 3956 New_Occurrence_Of (TB, Loc))), 3957 3958 High_Bound => 3959 Convert_To (LLIB, 3960 Make_Attribute_Reference (Loc, 3961 Attribute_Name => Name_Last, 3962 Prefix => 3963 New_Occurrence_Of (TB, Loc))))), 3964 3965 Right_Opnd => Nin)))))); 3966 3967 -- Now we can do the rewrite 3968 3969 Rewrite (N, 3970 Make_Expression_With_Actions (Loc, 3971 Actions => New_List ( 3972 Make_Object_Declaration (Loc, 3973 Defining_Identifier => Bnn, 3974 Object_Definition => 3975 New_Occurrence_Of (Result_Type, Loc)), 3976 Blk), 3977 Expression => New_Occurrence_Of (Bnn, Loc))); 3978 Analyze_And_Resolve (N, Result_Type); 3979 return; 3980 end; 3981 3982 -- Not bignum case, but types don't match (this means we rewrote the 3983 -- left operand to be Long_Long_Integer). 3984 3985 else 3986 pragma Assert (Base_Type (Etype (Lop)) = LLIB); 3987 3988 -- We rewrite the membership test as (where T is the type with 3989 -- the predicate, i.e. the type of the right operand) 3990 3991 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last) 3992 -- and then T'Base (Lop) in T 3993 3994 declare 3995 T : constant Entity_Id := Etype (Rop); 3996 TB : constant Entity_Id := Base_Type (T); 3997 Nin : Node_Id; 3998 3999 begin 4000 -- The last membership test is marked to prevent recursion 4001 4002 Nin := 4003 Make_In (Loc, 4004 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)), 4005 Right_Opnd => New_Occurrence_Of (T, Loc)); 4006 Set_No_Minimize_Eliminate (Nin); 4007 4008 -- Now do the rewrite 4009 4010 Rewrite (N, 4011 Make_And_Then (Loc, 4012 Left_Opnd => 4013 Make_In (Loc, 4014 Left_Opnd => Lop, 4015 Right_Opnd => 4016 Make_Range (Loc, 4017 Low_Bound => 4018 Convert_To (LLIB, 4019 Make_Attribute_Reference (Loc, 4020 Attribute_Name => Name_First, 4021 Prefix => 4022 New_Occurrence_Of (TB, Loc))), 4023 High_Bound => 4024 Convert_To (LLIB, 4025 Make_Attribute_Reference (Loc, 4026 Attribute_Name => Name_Last, 4027 Prefix => 4028 New_Occurrence_Of (TB, Loc))))), 4029 Right_Opnd => Nin)); 4030 Set_Analyzed (N, False); 4031 Analyze_And_Resolve (N, Restype); 4032 end; 4033 end if; 4034 end if; 4035 end Expand_Membership_Minimize_Eliminate_Overflow; 4036 4037 --------------------------------- 4038 -- Expand_Nonbinary_Modular_Op -- 4039 --------------------------------- 4040 4041 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is 4042 Loc : constant Source_Ptr := Sloc (N); 4043 Typ : constant Entity_Id := Etype (N); 4044 4045 procedure Expand_Modular_Addition; 4046 -- Expand the modular addition, handling the special case of adding a 4047 -- constant. 4048 4049 procedure Expand_Modular_Op; 4050 -- Compute the general rule: (lhs OP rhs) mod Modulus 4051 4052 procedure Expand_Modular_Subtraction; 4053 -- Expand the modular addition, handling the special case of subtracting 4054 -- a constant. 4055 4056 ----------------------------- 4057 -- Expand_Modular_Addition -- 4058 ----------------------------- 4059 4060 procedure Expand_Modular_Addition is 4061 begin 4062 -- If this is not the addition of a constant then compute it using 4063 -- the general rule: (lhs + rhs) mod Modulus 4064 4065 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then 4066 Expand_Modular_Op; 4067 4068 -- If this is an addition of a constant, convert it to a subtraction 4069 -- plus a conditional expression since we can compute it faster than 4070 -- computing the modulus. 4071 4072 -- modMinusRhs = Modulus - rhs 4073 -- if lhs < modMinusRhs then lhs + rhs 4074 -- else lhs - modMinusRhs 4075 4076 else 4077 declare 4078 Mod_Minus_Right : constant Uint := 4079 Modulus (Typ) - Intval (Right_Opnd (N)); 4080 4081 Exprs : constant List_Id := New_List; 4082 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); 4083 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); 4084 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, 4085 Loc); 4086 begin 4087 -- To prevent spurious visibility issues, convert all 4088 -- operands to Standard.Unsigned. 4089 4090 Set_Left_Opnd (Cond_Expr, 4091 Unchecked_Convert_To (Standard_Unsigned, 4092 New_Copy_Tree (Left_Opnd (N)))); 4093 Set_Right_Opnd (Cond_Expr, 4094 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4095 Append_To (Exprs, Cond_Expr); 4096 4097 Set_Left_Opnd (Then_Expr, 4098 Unchecked_Convert_To (Standard_Unsigned, 4099 New_Copy_Tree (Left_Opnd (N)))); 4100 Set_Right_Opnd (Then_Expr, 4101 Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); 4102 Append_To (Exprs, Then_Expr); 4103 4104 Set_Left_Opnd (Else_Expr, 4105 Unchecked_Convert_To (Standard_Unsigned, 4106 New_Copy_Tree (Left_Opnd (N)))); 4107 Set_Right_Opnd (Else_Expr, 4108 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4109 Append_To (Exprs, Else_Expr); 4110 4111 Rewrite (N, 4112 Unchecked_Convert_To (Typ, 4113 Make_If_Expression (Loc, Expressions => Exprs))); 4114 end; 4115 end if; 4116 end Expand_Modular_Addition; 4117 4118 ----------------------- 4119 -- Expand_Modular_Op -- 4120 ----------------------- 4121 4122 procedure Expand_Modular_Op is 4123 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc); 4124 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc); 4125 4126 Target_Type : Entity_Id; 4127 4128 begin 4129 -- Convert nonbinary modular type operands into integer values. Thus 4130 -- we avoid never-ending loops expanding them, and we also ensure 4131 -- the back end never receives nonbinary modular type expressions. 4132 4133 if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then 4134 Set_Left_Opnd (Op_Expr, 4135 Unchecked_Convert_To (Standard_Unsigned, 4136 New_Copy_Tree (Left_Opnd (N)))); 4137 Set_Right_Opnd (Op_Expr, 4138 Unchecked_Convert_To (Standard_Unsigned, 4139 New_Copy_Tree (Right_Opnd (N)))); 4140 Set_Left_Opnd (Mod_Expr, 4141 Unchecked_Convert_To (Standard_Integer, Op_Expr)); 4142 4143 else 4144 -- If the modulus of the type is larger than Integer'Last use a 4145 -- larger type for the operands, to prevent spurious constraint 4146 -- errors on large legal literals of the type. 4147 4148 if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then 4149 Target_Type := Standard_Long_Integer; 4150 else 4151 Target_Type := Standard_Integer; 4152 end if; 4153 4154 Set_Left_Opnd (Op_Expr, 4155 Unchecked_Convert_To (Target_Type, 4156 New_Copy_Tree (Left_Opnd (N)))); 4157 Set_Right_Opnd (Op_Expr, 4158 Unchecked_Convert_To (Target_Type, 4159 New_Copy_Tree (Right_Opnd (N)))); 4160 4161 -- Link this node to the tree to analyze it 4162 4163 -- If the parent node is an expression with actions we link it to 4164 -- N since otherwise Force_Evaluation cannot identify if this node 4165 -- comes from the Expression and rejects generating the temporary. 4166 4167 if Nkind (Parent (N)) = N_Expression_With_Actions then 4168 Set_Parent (Op_Expr, N); 4169 4170 -- Common case 4171 4172 else 4173 Set_Parent (Op_Expr, Parent (N)); 4174 end if; 4175 4176 Analyze (Op_Expr); 4177 4178 -- Force generating a temporary because in the expansion of this 4179 -- expression we may generate code that performs this computation 4180 -- several times. 4181 4182 Force_Evaluation (Op_Expr, Mode => Strict); 4183 4184 Set_Left_Opnd (Mod_Expr, Op_Expr); 4185 end if; 4186 4187 Set_Right_Opnd (Mod_Expr, 4188 Make_Integer_Literal (Loc, Modulus (Typ))); 4189 4190 Rewrite (N, 4191 Unchecked_Convert_To (Typ, Mod_Expr)); 4192 end Expand_Modular_Op; 4193 4194 -------------------------------- 4195 -- Expand_Modular_Subtraction -- 4196 -------------------------------- 4197 4198 procedure Expand_Modular_Subtraction is 4199 begin 4200 -- If this is not the addition of a constant then compute it using 4201 -- the general rule: (lhs + rhs) mod Modulus 4202 4203 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then 4204 Expand_Modular_Op; 4205 4206 -- If this is an addition of a constant, convert it to a subtraction 4207 -- plus a conditional expression since we can compute it faster than 4208 -- computing the modulus. 4209 4210 -- modMinusRhs = Modulus - rhs 4211 -- if lhs < rhs then lhs + modMinusRhs 4212 -- else lhs - rhs 4213 4214 else 4215 declare 4216 Mod_Minus_Right : constant Uint := 4217 Modulus (Typ) - Intval (Right_Opnd (N)); 4218 4219 Exprs : constant List_Id := New_List; 4220 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); 4221 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); 4222 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, 4223 Loc); 4224 begin 4225 Set_Left_Opnd (Cond_Expr, 4226 Unchecked_Convert_To (Standard_Unsigned, 4227 New_Copy_Tree (Left_Opnd (N)))); 4228 Set_Right_Opnd (Cond_Expr, 4229 Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); 4230 Append_To (Exprs, Cond_Expr); 4231 4232 Set_Left_Opnd (Then_Expr, 4233 Unchecked_Convert_To (Standard_Unsigned, 4234 New_Copy_Tree (Left_Opnd (N)))); 4235 Set_Right_Opnd (Then_Expr, 4236 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4237 Append_To (Exprs, Then_Expr); 4238 4239 Set_Left_Opnd (Else_Expr, 4240 Unchecked_Convert_To (Standard_Unsigned, 4241 New_Copy_Tree (Left_Opnd (N)))); 4242 Set_Right_Opnd (Else_Expr, 4243 Unchecked_Convert_To (Standard_Unsigned, 4244 New_Copy_Tree (Right_Opnd (N)))); 4245 Append_To (Exprs, Else_Expr); 4246 4247 Rewrite (N, 4248 Unchecked_Convert_To (Typ, 4249 Make_If_Expression (Loc, Expressions => Exprs))); 4250 end; 4251 end if; 4252 end Expand_Modular_Subtraction; 4253 4254 -- Start of processing for Expand_Nonbinary_Modular_Op 4255 4256 begin 4257 -- No action needed if front-end expansion is not required or if we 4258 -- have a binary modular operand. 4259 4260 if not Expand_Nonbinary_Modular_Ops 4261 or else not Non_Binary_Modulus (Typ) 4262 then 4263 return; 4264 end if; 4265 4266 case Nkind (N) is 4267 when N_Op_Add => 4268 Expand_Modular_Addition; 4269 4270 when N_Op_Subtract => 4271 Expand_Modular_Subtraction; 4272 4273 when N_Op_Minus => 4274 4275 -- Expand -expr into (0 - expr) 4276 4277 Rewrite (N, 4278 Make_Op_Subtract (Loc, 4279 Left_Opnd => Make_Integer_Literal (Loc, 0), 4280 Right_Opnd => Right_Opnd (N))); 4281 Analyze_And_Resolve (N, Typ); 4282 4283 when others => 4284 Expand_Modular_Op; 4285 end case; 4286 4287 Analyze_And_Resolve (N, Typ); 4288 end Expand_Nonbinary_Modular_Op; 4289 4290 ------------------------ 4291 -- Expand_N_Allocator -- 4292 ------------------------ 4293 4294 procedure Expand_N_Allocator (N : Node_Id) is 4295 Etyp : constant Entity_Id := Etype (Expression (N)); 4296 Loc : constant Source_Ptr := Sloc (N); 4297 PtrT : constant Entity_Id := Etype (N); 4298 4299 procedure Rewrite_Coextension (N : Node_Id); 4300 -- Static coextensions have the same lifetime as the entity they 4301 -- constrain. Such occurrences can be rewritten as aliased objects 4302 -- and their unrestricted access used instead of the coextension. 4303 4304 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; 4305 -- Given a constrained array type E, returns a node representing the 4306 -- code to compute a close approximation of the size in storage elements 4307 -- for the given type; for indexes that are modular types we compute 4308 -- 'Last - First (instead of 'Length) because for large arrays computing 4309 -- 'Last -'First + 1 causes overflow. This is done without using the 4310 -- attribute 'Size_In_Storage_Elements (which malfunctions for large 4311 -- sizes ???). 4312 4313 ------------------------- 4314 -- Rewrite_Coextension -- 4315 ------------------------- 4316 4317 procedure Rewrite_Coextension (N : Node_Id) is 4318 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C'); 4319 Temp_Decl : Node_Id; 4320 4321 begin 4322 -- Generate: 4323 -- Cnn : aliased Etyp; 4324 4325 Temp_Decl := 4326 Make_Object_Declaration (Loc, 4327 Defining_Identifier => Temp_Id, 4328 Aliased_Present => True, 4329 Object_Definition => New_Occurrence_Of (Etyp, Loc)); 4330 4331 if Nkind (Expression (N)) = N_Qualified_Expression then 4332 Set_Expression (Temp_Decl, Expression (Expression (N))); 4333 end if; 4334 4335 Insert_Action (N, Temp_Decl); 4336 Rewrite (N, 4337 Make_Attribute_Reference (Loc, 4338 Prefix => New_Occurrence_Of (Temp_Id, Loc), 4339 Attribute_Name => Name_Unrestricted_Access)); 4340 4341 Analyze_And_Resolve (N, PtrT); 4342 end Rewrite_Coextension; 4343 4344 ------------------------------ 4345 -- Size_In_Storage_Elements -- 4346 ------------------------------ 4347 4348 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is 4349 begin 4350 -- Logically this just returns E'Max_Size_In_Storage_Elements. 4351 -- However, the reason for the existence of this function is 4352 -- to construct a test for sizes too large, which means near the 4353 -- 32-bit limit on a 32-bit machine, and precisely the trouble 4354 -- is that we get overflows when sizes are greater than 2**31. 4355 4356 -- So what we end up doing for array types is to use the expression: 4357 4358 -- number-of-elements * component_type'Max_Size_In_Storage_Elements 4359 4360 -- which avoids this problem. All this is a bit bogus, but it does 4361 -- mean we catch common cases of trying to allocate arrays that 4362 -- are too large, and which in the absence of a check results in 4363 -- undetected chaos ??? 4364 4365 -- Note in particular that this is a pessimistic estimate in the 4366 -- case of packed array types, where an array element might occupy 4367 -- just a fraction of a storage element??? 4368 4369 declare 4370 Idx : Node_Id := First_Index (E); 4371 Len : Node_Id; 4372 Res : Node_Id; 4373 pragma Warnings (Off, Res); 4374 4375 begin 4376 for J in 1 .. Number_Dimensions (E) loop 4377 4378 if not Is_Modular_Integer_Type (Etype (Idx)) then 4379 Len := 4380 Make_Attribute_Reference (Loc, 4381 Prefix => New_Occurrence_Of (E, Loc), 4382 Attribute_Name => Name_Length, 4383 Expressions => New_List 4384 (Make_Integer_Literal (Loc, J))); 4385 4386 -- For indexes that are modular types we cannot generate code 4387 -- to compute 'Length since for large arrays 'Last -'First + 1 4388 -- causes overflow; therefore we compute 'Last - 'First (which 4389 -- is not the exact number of components but it is valid for 4390 -- the purpose of this runtime check on 32-bit targets). 4391 4392 else 4393 declare 4394 Len_Minus_1_Expr : Node_Id; 4395 Test_Gt : Node_Id; 4396 4397 begin 4398 Test_Gt := 4399 Make_Op_Gt (Loc, 4400 Make_Attribute_Reference (Loc, 4401 Prefix => New_Occurrence_Of (E, Loc), 4402 Attribute_Name => Name_Last, 4403 Expressions => 4404 New_List (Make_Integer_Literal (Loc, J))), 4405 Make_Attribute_Reference (Loc, 4406 Prefix => New_Occurrence_Of (E, Loc), 4407 Attribute_Name => Name_First, 4408 Expressions => 4409 New_List (Make_Integer_Literal (Loc, J)))); 4410 4411 Len_Minus_1_Expr := 4412 Convert_To (Standard_Unsigned, 4413 Make_Op_Subtract (Loc, 4414 Make_Attribute_Reference (Loc, 4415 Prefix => New_Occurrence_Of (E, Loc), 4416 Attribute_Name => Name_Last, 4417 Expressions => 4418 New_List 4419 (Make_Integer_Literal (Loc, J))), 4420 Make_Attribute_Reference (Loc, 4421 Prefix => New_Occurrence_Of (E, Loc), 4422 Attribute_Name => Name_First, 4423 Expressions => 4424 New_List 4425 (Make_Integer_Literal (Loc, J))))); 4426 4427 -- Handle superflat arrays, i.e. arrays with such bounds 4428 -- as 4 .. 2, to ensure that the result is correct. 4429 4430 -- Generate: 4431 -- (if X'Last > X'First then X'Last - X'First else 0) 4432 4433 Len := 4434 Make_If_Expression (Loc, 4435 Expressions => New_List ( 4436 Test_Gt, 4437 Len_Minus_1_Expr, 4438 Make_Integer_Literal (Loc, Uint_0))); 4439 end; 4440 end if; 4441 4442 if J = 1 then 4443 Res := Len; 4444 4445 else 4446 Res := 4447 Make_Op_Multiply (Loc, 4448 Left_Opnd => Res, 4449 Right_Opnd => Len); 4450 end if; 4451 4452 Next_Index (Idx); 4453 end loop; 4454 4455 return 4456 Make_Op_Multiply (Loc, 4457 Left_Opnd => Len, 4458 Right_Opnd => 4459 Make_Attribute_Reference (Loc, 4460 Prefix => New_Occurrence_Of (Component_Type (E), Loc), 4461 Attribute_Name => Name_Max_Size_In_Storage_Elements)); 4462 end; 4463 end Size_In_Storage_Elements; 4464 4465 -- Local variables 4466 4467 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); 4468 Desig : Entity_Id; 4469 Nod : Node_Id; 4470 Pool : Entity_Id; 4471 Rel_Typ : Entity_Id; 4472 Temp : Entity_Id; 4473 4474 -- Start of processing for Expand_N_Allocator 4475 4476 begin 4477 -- Warn on the presence of an allocator of an anonymous access type when 4478 -- enabled, except when it's an object declaration at library level. 4479 4480 if Warn_On_Anonymous_Allocators 4481 and then Ekind (PtrT) = E_Anonymous_Access_Type 4482 and then not (Is_Library_Level_Entity (PtrT) 4483 and then Nkind (Associated_Node_For_Itype (PtrT)) = 4484 N_Object_Declaration) 4485 then 4486 Error_Msg_N ("?use of an anonymous access type allocator", N); 4487 end if; 4488 4489 -- RM E.2.3(22). We enforce that the expected type of an allocator 4490 -- shall not be a remote access-to-class-wide-limited-private type 4491 4492 -- Why is this being done at expansion time, seems clearly wrong ??? 4493 4494 Validate_Remote_Access_To_Class_Wide_Type (N); 4495 4496 -- Processing for anonymous access-to-controlled types. These access 4497 -- types receive a special finalization master which appears in the 4498 -- declarations of the enclosing semantic unit. This expansion is done 4499 -- now to ensure that any additional types generated by this routine or 4500 -- Expand_Allocator_Expression inherit the proper type attributes. 4501 4502 if (Ekind (PtrT) = E_Anonymous_Access_Type 4503 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT)))) 4504 and then Needs_Finalization (Dtyp) 4505 then 4506 -- Detect the allocation of an anonymous controlled object where the 4507 -- type of the context is named. For example: 4508 4509 -- procedure Proc (Ptr : Named_Access_Typ); 4510 -- Proc (new Designated_Typ); 4511 4512 -- Regardless of the anonymous-to-named access type conversion, the 4513 -- lifetime of the object must be associated with the named access 4514 -- type. Use the finalization-related attributes of this type. 4515 4516 if Nkind_In (Parent (N), N_Type_Conversion, 4517 N_Unchecked_Type_Conversion) 4518 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype, 4519 E_Access_Type, 4520 E_General_Access_Type) 4521 then 4522 Rel_Typ := Etype (Parent (N)); 4523 else 4524 Rel_Typ := Empty; 4525 end if; 4526 4527 -- Anonymous access-to-controlled types allocate on the global pool. 4528 -- Note that this is a "root type only" attribute. 4529 4530 if No (Associated_Storage_Pool (PtrT)) then 4531 if Present (Rel_Typ) then 4532 Set_Associated_Storage_Pool 4533 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ)); 4534 else 4535 Set_Associated_Storage_Pool 4536 (Root_Type (PtrT), RTE (RE_Global_Pool_Object)); 4537 end if; 4538 end if; 4539 4540 -- The finalization master must be inserted and analyzed as part of 4541 -- the current semantic unit. Note that the master is updated when 4542 -- analysis changes current units. Note that this is a "root type 4543 -- only" attribute. 4544 4545 if Present (Rel_Typ) then 4546 Set_Finalization_Master 4547 (Root_Type (PtrT), Finalization_Master (Rel_Typ)); 4548 else 4549 Build_Anonymous_Master (Root_Type (PtrT)); 4550 end if; 4551 end if; 4552 4553 -- Set the storage pool and find the appropriate version of Allocate to 4554 -- call. Do not overwrite the storage pool if it is already set, which 4555 -- can happen for build-in-place function returns (see 4556 -- Exp_Ch4.Expand_N_Extended_Return_Statement). 4557 4558 if No (Storage_Pool (N)) then 4559 Pool := Associated_Storage_Pool (Root_Type (PtrT)); 4560 4561 if Present (Pool) then 4562 Set_Storage_Pool (N, Pool); 4563 4564 if Is_RTE (Pool, RE_SS_Pool) then 4565 Check_Restriction (No_Secondary_Stack, N); 4566 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); 4567 4568 -- In the case of an allocator for a simple storage pool, locate 4569 -- and save a reference to the pool type's Allocate routine. 4570 4571 elsif Present (Get_Rep_Pragma 4572 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 4573 then 4574 declare 4575 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); 4576 Alloc_Op : Entity_Id; 4577 begin 4578 Alloc_Op := Get_Name_Entity_Id (Name_Allocate); 4579 while Present (Alloc_Op) loop 4580 if Scope (Alloc_Op) = Scope (Pool_Type) 4581 and then Present (First_Formal (Alloc_Op)) 4582 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 4583 then 4584 Set_Procedure_To_Call (N, Alloc_Op); 4585 exit; 4586 else 4587 Alloc_Op := Homonym (Alloc_Op); 4588 end if; 4589 end loop; 4590 end; 4591 4592 elsif Is_Class_Wide_Type (Etype (Pool)) then 4593 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); 4594 4595 else 4596 Set_Procedure_To_Call (N, 4597 Find_Prim_Op (Etype (Pool), Name_Allocate)); 4598 end if; 4599 end if; 4600 end if; 4601 4602 -- Under certain circumstances we can replace an allocator by an access 4603 -- to statically allocated storage. The conditions, as noted in AARM 4604 -- 3.10 (10c) are as follows: 4605 4606 -- Size and initial value is known at compile time 4607 -- Access type is access-to-constant 4608 4609 -- The allocator is not part of a constraint on a record component, 4610 -- because in that case the inserted actions are delayed until the 4611 -- record declaration is fully analyzed, which is too late for the 4612 -- analysis of the rewritten allocator. 4613 4614 if Is_Access_Constant (PtrT) 4615 and then Nkind (Expression (N)) = N_Qualified_Expression 4616 and then Compile_Time_Known_Value (Expression (Expression (N))) 4617 and then Size_Known_At_Compile_Time 4618 (Etype (Expression (Expression (N)))) 4619 and then not Is_Record_Type (Current_Scope) 4620 then 4621 -- Here we can do the optimization. For the allocator 4622 4623 -- new x'(y) 4624 4625 -- We insert an object declaration 4626 4627 -- Tnn : aliased x := y; 4628 4629 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is 4630 -- marked as requiring static allocation. 4631 4632 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); 4633 Desig := Subtype_Mark (Expression (N)); 4634 4635 -- If context is constrained, use constrained subtype directly, 4636 -- so that the constant is not labelled as having a nominally 4637 -- unconstrained subtype. 4638 4639 if Entity (Desig) = Base_Type (Dtyp) then 4640 Desig := New_Occurrence_Of (Dtyp, Loc); 4641 end if; 4642 4643 Insert_Action (N, 4644 Make_Object_Declaration (Loc, 4645 Defining_Identifier => Temp, 4646 Aliased_Present => True, 4647 Constant_Present => Is_Access_Constant (PtrT), 4648 Object_Definition => Desig, 4649 Expression => Expression (Expression (N)))); 4650 4651 Rewrite (N, 4652 Make_Attribute_Reference (Loc, 4653 Prefix => New_Occurrence_Of (Temp, Loc), 4654 Attribute_Name => Name_Unrestricted_Access)); 4655 4656 Analyze_And_Resolve (N, PtrT); 4657 4658 -- We set the variable as statically allocated, since we don't want 4659 -- it going on the stack of the current procedure. 4660 4661 Set_Is_Statically_Allocated (Temp); 4662 return; 4663 end if; 4664 4665 -- Same if the allocator is an access discriminant for a local object: 4666 -- instead of an allocator we create a local value and constrain the 4667 -- enclosing object with the corresponding access attribute. 4668 4669 if Is_Static_Coextension (N) then 4670 Rewrite_Coextension (N); 4671 return; 4672 end if; 4673 4674 -- Check for size too large, we do this because the back end misses 4675 -- proper checks here and can generate rubbish allocation calls when 4676 -- we are near the limit. We only do this for the 32-bit address case 4677 -- since that is from a practical point of view where we see a problem. 4678 4679 if System_Address_Size = 32 4680 and then not Storage_Checks_Suppressed (PtrT) 4681 and then not Storage_Checks_Suppressed (Dtyp) 4682 and then not Storage_Checks_Suppressed (Etyp) 4683 then 4684 -- The check we want to generate should look like 4685 4686 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then 4687 -- raise Storage_Error; 4688 -- end if; 4689 4690 -- where 3.5 gigabytes is a constant large enough to accommodate any 4691 -- reasonable request for. But we can't do it this way because at 4692 -- least at the moment we don't compute this attribute right, and 4693 -- can silently give wrong results when the result gets large. Since 4694 -- this is all about large results, that's bad, so instead we only 4695 -- apply the check for constrained arrays, and manually compute the 4696 -- value of the attribute ??? 4697 4698 -- The check on No_Initialization is used here to prevent generating 4699 -- this runtime check twice when the allocator is locally replaced by 4700 -- the expander with another one. 4701 4702 if Is_Array_Type (Etyp) and then not No_Initialization (N) then 4703 declare 4704 Cond : Node_Id; 4705 Ins_Nod : Node_Id := N; 4706 Siz_Typ : Entity_Id := Etyp; 4707 Expr : Node_Id; 4708 4709 begin 4710 -- For unconstrained array types initialized with a qualified 4711 -- expression we use its type to perform this check 4712 4713 if not Is_Constrained (Etyp) 4714 and then not No_Initialization (N) 4715 and then Nkind (Expression (N)) = N_Qualified_Expression 4716 then 4717 Expr := Expression (Expression (N)); 4718 Siz_Typ := Etype (Expression (Expression (N))); 4719 4720 -- If the qualified expression has been moved to an internal 4721 -- temporary (to remove side effects) then we must insert 4722 -- the runtime check before its declaration to ensure that 4723 -- the check is performed before the execution of the code 4724 -- computing the qualified expression. 4725 4726 if Nkind (Expr) = N_Identifier 4727 and then Is_Internal_Name (Chars (Expr)) 4728 and then 4729 Nkind (Parent (Entity (Expr))) = N_Object_Declaration 4730 then 4731 Ins_Nod := Parent (Entity (Expr)); 4732 else 4733 Ins_Nod := Expr; 4734 end if; 4735 end if; 4736 4737 if Is_Constrained (Siz_Typ) 4738 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype 4739 then 4740 -- For CCG targets, the largest array may have up to 2**31-1 4741 -- components (i.e. 2 gigabytes if each array component is 4742 -- one byte). This ensures that fat pointer fields do not 4743 -- overflow, since they are 32-bit integer types, and also 4744 -- ensures that 'Length can be computed at run time. 4745 4746 if Modify_Tree_For_C then 4747 Cond := 4748 Make_Op_Gt (Loc, 4749 Left_Opnd => Size_In_Storage_Elements (Siz_Typ), 4750 Right_Opnd => Make_Integer_Literal (Loc, 4751 Uint_2 ** 31 - Uint_1)); 4752 4753 -- For native targets the largest object is 3.5 gigabytes 4754 4755 else 4756 Cond := 4757 Make_Op_Gt (Loc, 4758 Left_Opnd => Size_In_Storage_Elements (Siz_Typ), 4759 Right_Opnd => Make_Integer_Literal (Loc, 4760 Uint_7 * (Uint_2 ** 29))); 4761 end if; 4762 4763 Insert_Action (Ins_Nod, 4764 Make_Raise_Storage_Error (Loc, 4765 Condition => Cond, 4766 Reason => SE_Object_Too_Large)); 4767 4768 if Entity (Cond) = Standard_True then 4769 Error_Msg_N 4770 ("object too large: Storage_Error will be raised at " 4771 & "run time??", N); 4772 end if; 4773 end if; 4774 end; 4775 end if; 4776 end if; 4777 4778 -- If no storage pool has been specified, or the storage pool 4779 -- is System.Pool_Global.Global_Pool_Object, and the restriction 4780 -- No_Standard_Allocators_After_Elaboration is present, then generate 4781 -- a call to Elaboration_Allocators.Check_Standard_Allocator. 4782 4783 if Nkind (N) = N_Allocator 4784 and then (No (Storage_Pool (N)) 4785 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object)) 4786 and then Restriction_Active (No_Standard_Allocators_After_Elaboration) 4787 then 4788 Insert_Action (N, 4789 Make_Procedure_Call_Statement (Loc, 4790 Name => 4791 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc))); 4792 end if; 4793 4794 -- Handle case of qualified expression (other than optimization above) 4795 -- First apply constraint checks, because the bounds or discriminants 4796 -- in the aggregate might not match the subtype mark in the allocator. 4797 4798 if Nkind (Expression (N)) = N_Qualified_Expression then 4799 declare 4800 Exp : constant Node_Id := Expression (Expression (N)); 4801 Typ : constant Entity_Id := Etype (Expression (N)); 4802 4803 begin 4804 Apply_Constraint_Check (Exp, Typ); 4805 Apply_Predicate_Check (Exp, Typ); 4806 end; 4807 4808 Expand_Allocator_Expression (N); 4809 return; 4810 end if; 4811 4812 -- If the allocator is for a type which requires initialization, and 4813 -- there is no initial value (i.e. operand is a subtype indication 4814 -- rather than a qualified expression), then we must generate a call to 4815 -- the initialization routine using an expressions action node: 4816 4817 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] 4818 4819 -- Here ptr_T is the pointer type for the allocator, and T is the 4820 -- subtype of the allocator. A special case arises if the designated 4821 -- type of the access type is a task or contains tasks. In this case 4822 -- the call to Init (Temp.all ...) is replaced by code that ensures 4823 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block 4824 -- for details). In addition, if the type T is a task type, then the 4825 -- first argument to Init must be converted to the task record type. 4826 4827 declare 4828 T : constant Entity_Id := Etype (Expression (N)); 4829 Args : List_Id; 4830 Decls : List_Id; 4831 Decl : Node_Id; 4832 Discr : Elmt_Id; 4833 Init : Entity_Id; 4834 Init_Arg1 : Node_Id; 4835 Init_Call : Node_Id; 4836 Temp_Decl : Node_Id; 4837 Temp_Type : Entity_Id; 4838 4839 begin 4840 if No_Initialization (N) then 4841 4842 -- Even though this might be a simple allocation, create a custom 4843 -- Allocate if the context requires it. 4844 4845 if Present (Finalization_Master (PtrT)) then 4846 Build_Allocate_Deallocate_Proc 4847 (N => N, 4848 Is_Allocate => True); 4849 end if; 4850 4851 -- Optimize the default allocation of an array object when pragma 4852 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an 4853 -- in-place initialization aggregate which may be convert into a fast 4854 -- memset by the backend. 4855 4856 elsif Init_Or_Norm_Scalars 4857 and then Is_Array_Type (T) 4858 4859 -- The array must lack atomic components because they are treated 4860 -- as non-static, and as a result the backend will not initialize 4861 -- the memory in one go. 4862 4863 and then not Has_Atomic_Components (T) 4864 4865 -- The array must not be packed because the invalid values in 4866 -- System.Scalar_Values are multiples of Storage_Unit. 4867 4868 and then not Is_Packed (T) 4869 4870 -- The array must have static non-empty ranges, otherwise the 4871 -- backend cannot initialize the memory in one go. 4872 4873 and then Has_Static_Non_Empty_Array_Bounds (T) 4874 4875 -- The optimization is only relevant for arrays of scalar types 4876 4877 and then Is_Scalar_Type (Component_Type (T)) 4878 4879 -- Similar to regular array initialization using a type init proc, 4880 -- predicate checks are not performed because the initialization 4881 -- values are intentionally invalid, and may violate the predicate. 4882 4883 and then not Has_Predicates (Component_Type (T)) 4884 4885 -- The component type must have a single initialization value 4886 4887 and then Needs_Simple_Initialization 4888 (Typ => Component_Type (T), 4889 Consider_IS => True) 4890 then 4891 Set_Analyzed (N); 4892 Temp := Make_Temporary (Loc, 'P'); 4893 4894 -- Generate: 4895 -- Temp : Ptr_Typ := new ...; 4896 4897 Insert_Action 4898 (Assoc_Node => N, 4899 Ins_Action => 4900 Make_Object_Declaration (Loc, 4901 Defining_Identifier => Temp, 4902 Object_Definition => New_Occurrence_Of (PtrT, Loc), 4903 Expression => Relocate_Node (N)), 4904 Suppress => All_Checks); 4905 4906 -- Generate: 4907 -- Temp.all := (others => ...); 4908 4909 Insert_Action 4910 (Assoc_Node => N, 4911 Ins_Action => 4912 Make_Assignment_Statement (Loc, 4913 Name => 4914 Make_Explicit_Dereference (Loc, 4915 Prefix => New_Occurrence_Of (Temp, Loc)), 4916 Expression => 4917 Get_Simple_Init_Val 4918 (Typ => T, 4919 N => N, 4920 Size => Esize (Component_Type (T)))), 4921 Suppress => All_Checks); 4922 4923 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 4924 Analyze_And_Resolve (N, PtrT); 4925 4926 -- Case of no initialization procedure present 4927 4928 elsif not Has_Non_Null_Base_Init_Proc (T) then 4929 4930 -- Case of simple initialization required 4931 4932 if Needs_Simple_Initialization (T) then 4933 Check_Restriction (No_Default_Initialization, N); 4934 Rewrite (Expression (N), 4935 Make_Qualified_Expression (Loc, 4936 Subtype_Mark => New_Occurrence_Of (T, Loc), 4937 Expression => Get_Simple_Init_Val (T, N))); 4938 4939 Analyze_And_Resolve (Expression (Expression (N)), T); 4940 Analyze_And_Resolve (Expression (N), T); 4941 Set_Paren_Count (Expression (Expression (N)), 1); 4942 Expand_N_Allocator (N); 4943 4944 -- No initialization required 4945 4946 else 4947 Build_Allocate_Deallocate_Proc 4948 (N => N, 4949 Is_Allocate => True); 4950 end if; 4951 4952 -- Case of initialization procedure present, must be called 4953 4954 -- NOTE: There is a *huge* amount of code duplication here from 4955 -- Build_Initialization_Call. We should probably refactor??? 4956 4957 else 4958 Check_Restriction (No_Default_Initialization, N); 4959 4960 if not Restriction_Active (No_Default_Initialization) then 4961 Init := Base_Init_Proc (T); 4962 Nod := N; 4963 Temp := Make_Temporary (Loc, 'P'); 4964 4965 -- Construct argument list for the initialization routine call 4966 4967 Init_Arg1 := 4968 Make_Explicit_Dereference (Loc, 4969 Prefix => 4970 New_Occurrence_Of (Temp, Loc)); 4971 4972 Set_Assignment_OK (Init_Arg1); 4973 Temp_Type := PtrT; 4974 4975 -- The initialization procedure expects a specific type. if the 4976 -- context is access to class wide, indicate that the object 4977 -- being allocated has the right specific type. 4978 4979 if Is_Class_Wide_Type (Dtyp) then 4980 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1); 4981 end if; 4982 4983 -- If designated type is a concurrent type or if it is private 4984 -- type whose definition is a concurrent type, the first 4985 -- argument in the Init routine has to be unchecked conversion 4986 -- to the corresponding record type. If the designated type is 4987 -- a derived type, also convert the argument to its root type. 4988 4989 if Is_Concurrent_Type (T) then 4990 Init_Arg1 := 4991 Unchecked_Convert_To ( 4992 Corresponding_Record_Type (T), Init_Arg1); 4993 4994 elsif Is_Private_Type (T) 4995 and then Present (Full_View (T)) 4996 and then Is_Concurrent_Type (Full_View (T)) 4997 then 4998 Init_Arg1 := 4999 Unchecked_Convert_To 5000 (Corresponding_Record_Type (Full_View (T)), Init_Arg1); 5001 5002 elsif Etype (First_Formal (Init)) /= Base_Type (T) then 5003 declare 5004 Ftyp : constant Entity_Id := Etype (First_Formal (Init)); 5005 5006 begin 5007 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1); 5008 Set_Etype (Init_Arg1, Ftyp); 5009 end; 5010 end if; 5011 5012 Args := New_List (Init_Arg1); 5013 5014 -- For the task case, pass the Master_Id of the access type as 5015 -- the value of the _Master parameter, and _Chain as the value 5016 -- of the _Chain parameter (_Chain will be defined as part of 5017 -- the generated code for the allocator). 5018 5019 -- In Ada 2005, the context may be a function that returns an 5020 -- anonymous access type. In that case the Master_Id has been 5021 -- created when expanding the function declaration. 5022 5023 if Has_Task (T) then 5024 if No (Master_Id (Base_Type (PtrT))) then 5025 5026 -- The designated type was an incomplete type, and the 5027 -- access type did not get expanded. Salvage it now. 5028 5029 if not Restriction_Active (No_Task_Hierarchy) then 5030 if Present (Parent (Base_Type (PtrT))) then 5031 Expand_N_Full_Type_Declaration 5032 (Parent (Base_Type (PtrT))); 5033 5034 -- The only other possibility is an itype. For this 5035 -- case, the master must exist in the context. This is 5036 -- the case when the allocator initializes an access 5037 -- component in an init-proc. 5038 5039 else 5040 pragma Assert (Is_Itype (PtrT)); 5041 Build_Master_Renaming (PtrT, N); 5042 end if; 5043 end if; 5044 end if; 5045 5046 -- If the context of the allocator is a declaration or an 5047 -- assignment, we can generate a meaningful image for it, 5048 -- even though subsequent assignments might remove the 5049 -- connection between task and entity. We build this image 5050 -- when the left-hand side is a simple variable, a simple 5051 -- indexed assignment or a simple selected component. 5052 5053 if Nkind (Parent (N)) = N_Assignment_Statement then 5054 declare 5055 Nam : constant Node_Id := Name (Parent (N)); 5056 5057 begin 5058 if Is_Entity_Name (Nam) then 5059 Decls := 5060 Build_Task_Image_Decls 5061 (Loc, 5062 New_Occurrence_Of 5063 (Entity (Nam), Sloc (Nam)), T); 5064 5065 elsif Nkind_In (Nam, N_Indexed_Component, 5066 N_Selected_Component) 5067 and then Is_Entity_Name (Prefix (Nam)) 5068 then 5069 Decls := 5070 Build_Task_Image_Decls 5071 (Loc, Nam, Etype (Prefix (Nam))); 5072 else 5073 Decls := Build_Task_Image_Decls (Loc, T, T); 5074 end if; 5075 end; 5076 5077 elsif Nkind (Parent (N)) = N_Object_Declaration then 5078 Decls := 5079 Build_Task_Image_Decls 5080 (Loc, Defining_Identifier (Parent (N)), T); 5081 5082 else 5083 Decls := Build_Task_Image_Decls (Loc, T, T); 5084 end if; 5085 5086 if Restriction_Active (No_Task_Hierarchy) then 5087 Append_To (Args, 5088 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 5089 else 5090 Append_To (Args, 5091 New_Occurrence_Of 5092 (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); 5093 end if; 5094 5095 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 5096 5097 Decl := Last (Decls); 5098 Append_To (Args, 5099 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 5100 5101 -- Has_Task is false, Decls not used 5102 5103 else 5104 Decls := No_List; 5105 end if; 5106 5107 -- Add discriminants if discriminated type 5108 5109 declare 5110 Dis : Boolean := False; 5111 Typ : Entity_Id := Empty; 5112 5113 begin 5114 if Has_Discriminants (T) then 5115 Dis := True; 5116 Typ := T; 5117 5118 -- Type may be a private type with no visible discriminants 5119 -- in which case check full view if in scope, or the 5120 -- underlying_full_view if dealing with a type whose full 5121 -- view may be derived from a private type whose own full 5122 -- view has discriminants. 5123 5124 elsif Is_Private_Type (T) then 5125 if Present (Full_View (T)) 5126 and then Has_Discriminants (Full_View (T)) 5127 then 5128 Dis := True; 5129 Typ := Full_View (T); 5130 5131 elsif Present (Underlying_Full_View (T)) 5132 and then Has_Discriminants (Underlying_Full_View (T)) 5133 then 5134 Dis := True; 5135 Typ := Underlying_Full_View (T); 5136 end if; 5137 end if; 5138 5139 if Dis then 5140 5141 -- If the allocated object will be constrained by the 5142 -- default values for discriminants, then build a subtype 5143 -- with those defaults, and change the allocated subtype 5144 -- to that. Note that this happens in fewer cases in Ada 5145 -- 2005 (AI-363). 5146 5147 if not Is_Constrained (Typ) 5148 and then Present (Discriminant_Default_Value 5149 (First_Discriminant (Typ))) 5150 and then (Ada_Version < Ada_2005 5151 or else not 5152 Object_Type_Has_Constrained_Partial_View 5153 (Typ, Current_Scope)) 5154 then 5155 Typ := Build_Default_Subtype (Typ, N); 5156 Set_Expression (N, New_Occurrence_Of (Typ, Loc)); 5157 end if; 5158 5159 Discr := First_Elmt (Discriminant_Constraint (Typ)); 5160 while Present (Discr) loop 5161 Nod := Node (Discr); 5162 Append (New_Copy_Tree (Node (Discr)), Args); 5163 5164 -- AI-416: when the discriminant constraint is an 5165 -- anonymous access type make sure an accessibility 5166 -- check is inserted if necessary (3.10.2(22.q/2)) 5167 5168 if Ada_Version >= Ada_2005 5169 and then 5170 Ekind (Etype (Nod)) = E_Anonymous_Access_Type 5171 then 5172 Apply_Accessibility_Check 5173 (Nod, Typ, Insert_Node => Nod); 5174 end if; 5175 5176 Next_Elmt (Discr); 5177 end loop; 5178 end if; 5179 end; 5180 5181 -- We set the allocator as analyzed so that when we analyze 5182 -- the if expression node, we do not get an unwanted recursive 5183 -- expansion of the allocator expression. 5184 5185 Set_Analyzed (N, True); 5186 Nod := Relocate_Node (N); 5187 5188 -- Here is the transformation: 5189 -- input: new Ctrl_Typ 5190 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ; 5191 -- Ctrl_TypIP (Temp.all, ...); 5192 -- [Deep_]Initialize (Temp.all); 5193 5194 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and 5195 -- is the subtype of the allocator. 5196 5197 Temp_Decl := 5198 Make_Object_Declaration (Loc, 5199 Defining_Identifier => Temp, 5200 Constant_Present => True, 5201 Object_Definition => New_Occurrence_Of (Temp_Type, Loc), 5202 Expression => Nod); 5203 5204 Set_Assignment_OK (Temp_Decl); 5205 Insert_Action (N, Temp_Decl, Suppress => All_Checks); 5206 5207 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 5208 5209 -- If the designated type is a task type or contains tasks, 5210 -- create block to activate created tasks, and insert 5211 -- declaration for Task_Image variable ahead of call. 5212 5213 if Has_Task (T) then 5214 declare 5215 L : constant List_Id := New_List; 5216 Blk : Node_Id; 5217 begin 5218 Build_Task_Allocate_Block (L, Nod, Args); 5219 Blk := Last (L); 5220 Insert_List_Before (First (Declarations (Blk)), Decls); 5221 Insert_Actions (N, L); 5222 end; 5223 5224 else 5225 Insert_Action (N, 5226 Make_Procedure_Call_Statement (Loc, 5227 Name => New_Occurrence_Of (Init, Loc), 5228 Parameter_Associations => Args)); 5229 end if; 5230 5231 if Needs_Finalization (T) then 5232 5233 -- Generate: 5234 -- [Deep_]Initialize (Init_Arg1); 5235 5236 Init_Call := 5237 Make_Init_Call 5238 (Obj_Ref => New_Copy_Tree (Init_Arg1), 5239 Typ => T); 5240 5241 -- Guard against a missing [Deep_]Initialize when the 5242 -- designated type was not properly frozen. 5243 5244 if Present (Init_Call) then 5245 Insert_Action (N, Init_Call); 5246 end if; 5247 end if; 5248 5249 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 5250 Analyze_And_Resolve (N, PtrT); 5251 end if; 5252 end if; 5253 end; 5254 5255 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface 5256 -- object that has been rewritten as a reference, we displace "this" 5257 -- to reference properly its secondary dispatch table. 5258 5259 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then 5260 Displace_Allocator_Pointer (N); 5261 end if; 5262 5263 exception 5264 when RE_Not_Available => 5265 return; 5266 end Expand_N_Allocator; 5267 5268 ----------------------- 5269 -- Expand_N_And_Then -- 5270 ----------------------- 5271 5272 procedure Expand_N_And_Then (N : Node_Id) 5273 renames Expand_Short_Circuit_Operator; 5274 5275 ------------------------------ 5276 -- Expand_N_Case_Expression -- 5277 ------------------------------ 5278 5279 procedure Expand_N_Case_Expression (N : Node_Id) is 5280 function Is_Copy_Type (Typ : Entity_Id) return Boolean; 5281 -- Return True if we can copy objects of this type when expanding a case 5282 -- expression. 5283 5284 ------------------ 5285 -- Is_Copy_Type -- 5286 ------------------ 5287 5288 function Is_Copy_Type (Typ : Entity_Id) return Boolean is 5289 begin 5290 -- If Minimize_Expression_With_Actions is True, we can afford to copy 5291 -- large objects, as long as they are constrained and not limited. 5292 5293 return 5294 Is_Elementary_Type (Underlying_Type (Typ)) 5295 or else 5296 (Minimize_Expression_With_Actions 5297 and then Is_Constrained (Underlying_Type (Typ)) 5298 and then not Is_Limited_Type (Underlying_Type (Typ))); 5299 end Is_Copy_Type; 5300 5301 -- Local variables 5302 5303 Loc : constant Source_Ptr := Sloc (N); 5304 Par : constant Node_Id := Parent (N); 5305 Typ : constant Entity_Id := Etype (N); 5306 5307 Acts : List_Id; 5308 Alt : Node_Id; 5309 Case_Stmt : Node_Id; 5310 Decl : Node_Id; 5311 Expr : Node_Id; 5312 Target : Entity_Id; 5313 Target_Typ : Entity_Id; 5314 5315 In_Predicate : Boolean := False; 5316 -- Flag set when the case expression appears within a predicate 5317 5318 Optimize_Return_Stmt : Boolean := False; 5319 -- Flag set when the case expression can be optimized in the context of 5320 -- a simple return statement. 5321 5322 -- Start of processing for Expand_N_Case_Expression 5323 5324 begin 5325 -- Check for MINIMIZED/ELIMINATED overflow mode 5326 5327 if Minimized_Eliminated_Overflow_Check (N) then 5328 Apply_Arithmetic_Overflow_Check (N); 5329 return; 5330 end if; 5331 5332 -- If the case expression is a predicate specification, and the type 5333 -- to which it applies has a static predicate aspect, do not expand, 5334 -- because it will be converted to the proper predicate form later. 5335 5336 if Ekind_In (Current_Scope, E_Function, E_Procedure) 5337 and then Is_Predicate_Function (Current_Scope) 5338 then 5339 In_Predicate := True; 5340 5341 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope))) 5342 then 5343 return; 5344 end if; 5345 end if; 5346 5347 -- When the type of the case expression is elementary, expand 5348 5349 -- (case X is when A => AX, when B => BX ...) 5350 5351 -- into 5352 5353 -- do 5354 -- Target : Typ; 5355 -- case X is 5356 -- when A => 5357 -- Target := AX; 5358 -- when B => 5359 -- Target := BX; 5360 -- ... 5361 -- end case; 5362 -- in Target end; 5363 5364 -- In all other cases expand into 5365 5366 -- do 5367 -- type Ptr_Typ is access all Typ; 5368 -- Target : Ptr_Typ; 5369 -- case X is 5370 -- when A => 5371 -- Target := AX'Unrestricted_Access; 5372 -- when B => 5373 -- Target := BX'Unrestricted_Access; 5374 -- ... 5375 -- end case; 5376 -- in Target.all end; 5377 5378 -- This approach avoids extra copies of potentially large objects. It 5379 -- also allows handling of values of limited or unconstrained types. 5380 -- Note that we do the copy also for constrained, nonlimited types 5381 -- when minimizing expressions with actions (e.g. when generating C 5382 -- code) since it allows us to do the optimization below in more cases. 5383 5384 -- Small optimization: when the case expression appears in the context 5385 -- of a simple return statement, expand into 5386 5387 -- case X is 5388 -- when A => 5389 -- return AX; 5390 -- when B => 5391 -- return BX; 5392 -- ... 5393 -- end case; 5394 5395 Case_Stmt := 5396 Make_Case_Statement (Loc, 5397 Expression => Expression (N), 5398 Alternatives => New_List); 5399 5400 -- Preserve the original context for which the case statement is being 5401 -- generated. This is needed by the finalization machinery to prevent 5402 -- the premature finalization of controlled objects found within the 5403 -- case statement. 5404 5405 Set_From_Conditional_Expression (Case_Stmt); 5406 Acts := New_List; 5407 5408 -- Scalar/Copy case 5409 5410 if Is_Copy_Type (Typ) then 5411 Target_Typ := Typ; 5412 5413 -- ??? Do not perform the optimization when the return statement is 5414 -- within a predicate function, as this causes spurious errors. Could 5415 -- this be a possible mismatch in handling this case somewhere else 5416 -- in semantic analysis? 5417 5418 Optimize_Return_Stmt := 5419 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; 5420 5421 -- Otherwise create an access type to handle the general case using 5422 -- 'Unrestricted_Access. 5423 5424 -- Generate: 5425 -- type Ptr_Typ is access all Typ; 5426 5427 else 5428 if Generate_C_Code then 5429 5430 -- We cannot ensure that correct C code will be generated if any 5431 -- temporary is created down the line (to e.g. handle checks or 5432 -- capture values) since we might end up with dangling references 5433 -- to local variables, so better be safe and reject the construct. 5434 5435 Error_Msg_N 5436 ("case expression too complex, use case statement instead", N); 5437 end if; 5438 5439 Target_Typ := Make_Temporary (Loc, 'P'); 5440 5441 Append_To (Acts, 5442 Make_Full_Type_Declaration (Loc, 5443 Defining_Identifier => Target_Typ, 5444 Type_Definition => 5445 Make_Access_To_Object_Definition (Loc, 5446 All_Present => True, 5447 Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); 5448 end if; 5449 5450 -- Create the declaration of the target which captures the value of the 5451 -- expression. 5452 5453 -- Generate: 5454 -- Target : [Ptr_]Typ; 5455 5456 if not Optimize_Return_Stmt then 5457 Target := Make_Temporary (Loc, 'T'); 5458 5459 Decl := 5460 Make_Object_Declaration (Loc, 5461 Defining_Identifier => Target, 5462 Object_Definition => New_Occurrence_Of (Target_Typ, Loc)); 5463 Set_No_Initialization (Decl); 5464 5465 Append_To (Acts, Decl); 5466 end if; 5467 5468 -- Process the alternatives 5469 5470 Alt := First (Alternatives (N)); 5471 while Present (Alt) loop 5472 declare 5473 Alt_Expr : Node_Id := Expression (Alt); 5474 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); 5475 LHS : Node_Id; 5476 Stmts : List_Id; 5477 5478 begin 5479 -- Take the unrestricted access of the expression value for non- 5480 -- scalar types. This approach avoids big copies and covers the 5481 -- limited and unconstrained cases. 5482 5483 -- Generate: 5484 -- AX'Unrestricted_Access 5485 5486 if not Is_Copy_Type (Typ) then 5487 Alt_Expr := 5488 Make_Attribute_Reference (Alt_Loc, 5489 Prefix => Relocate_Node (Alt_Expr), 5490 Attribute_Name => Name_Unrestricted_Access); 5491 end if; 5492 5493 -- Generate: 5494 -- return AX['Unrestricted_Access]; 5495 5496 if Optimize_Return_Stmt then 5497 Stmts := New_List ( 5498 Make_Simple_Return_Statement (Alt_Loc, 5499 Expression => Alt_Expr)); 5500 5501 -- Generate: 5502 -- Target := AX['Unrestricted_Access]; 5503 5504 else 5505 LHS := New_Occurrence_Of (Target, Loc); 5506 Set_Assignment_OK (LHS); 5507 5508 Stmts := New_List ( 5509 Make_Assignment_Statement (Alt_Loc, 5510 Name => LHS, 5511 Expression => Alt_Expr)); 5512 end if; 5513 5514 -- Propagate declarations inserted in the node by Insert_Actions 5515 -- (for example, temporaries generated to remove side effects). 5516 -- These actions must remain attached to the alternative, given 5517 -- that they are generated by the corresponding expression. 5518 5519 if Present (Actions (Alt)) then 5520 Prepend_List (Actions (Alt), Stmts); 5521 end if; 5522 5523 -- Finalize any transient objects on exit from the alternative. 5524 -- This is done only in the return optimization case because 5525 -- otherwise the case expression is converted into an expression 5526 -- with actions which already contains this form of processing. 5527 5528 if Optimize_Return_Stmt then 5529 Process_If_Case_Statements (N, Stmts); 5530 end if; 5531 5532 Append_To 5533 (Alternatives (Case_Stmt), 5534 Make_Case_Statement_Alternative (Sloc (Alt), 5535 Discrete_Choices => Discrete_Choices (Alt), 5536 Statements => Stmts)); 5537 end; 5538 5539 Next (Alt); 5540 end loop; 5541 5542 -- Rewrite the parent return statement as a case statement 5543 5544 if Optimize_Return_Stmt then 5545 Rewrite (Par, Case_Stmt); 5546 Analyze (Par); 5547 5548 -- Otherwise convert the case expression into an expression with actions 5549 5550 else 5551 Append_To (Acts, Case_Stmt); 5552 5553 if Is_Copy_Type (Typ) then 5554 Expr := New_Occurrence_Of (Target, Loc); 5555 5556 else 5557 Expr := 5558 Make_Explicit_Dereference (Loc, 5559 Prefix => New_Occurrence_Of (Target, Loc)); 5560 end if; 5561 5562 -- Generate: 5563 -- do 5564 -- ... 5565 -- in Target[.all] end; 5566 5567 Rewrite (N, 5568 Make_Expression_With_Actions (Loc, 5569 Expression => Expr, 5570 Actions => Acts)); 5571 5572 Analyze_And_Resolve (N, Typ); 5573 end if; 5574 end Expand_N_Case_Expression; 5575 5576 ----------------------------------- 5577 -- Expand_N_Explicit_Dereference -- 5578 ----------------------------------- 5579 5580 procedure Expand_N_Explicit_Dereference (N : Node_Id) is 5581 begin 5582 -- Insert explicit dereference call for the checked storage pool case 5583 5584 Insert_Dereference_Action (Prefix (N)); 5585 5586 -- If the type is an Atomic type for which Atomic_Sync is enabled, then 5587 -- we set the atomic sync flag. 5588 5589 if Is_Atomic (Etype (N)) 5590 and then not Atomic_Synchronization_Disabled (Etype (N)) 5591 then 5592 Activate_Atomic_Synchronization (N); 5593 end if; 5594 end Expand_N_Explicit_Dereference; 5595 5596 -------------------------------------- 5597 -- Expand_N_Expression_With_Actions -- 5598 -------------------------------------- 5599 5600 procedure Expand_N_Expression_With_Actions (N : Node_Id) is 5601 Acts : constant List_Id := Actions (N); 5602 5603 procedure Force_Boolean_Evaluation (Expr : Node_Id); 5604 -- Force the evaluation of Boolean expression Expr 5605 5606 function Process_Action (Act : Node_Id) return Traverse_Result; 5607 -- Inspect and process a single action of an expression_with_actions for 5608 -- transient objects. If such objects are found, the routine generates 5609 -- code to clean them up when the context of the expression is evaluated 5610 -- or elaborated. 5611 5612 ------------------------------ 5613 -- Force_Boolean_Evaluation -- 5614 ------------------------------ 5615 5616 procedure Force_Boolean_Evaluation (Expr : Node_Id) is 5617 Loc : constant Source_Ptr := Sloc (N); 5618 Flag_Decl : Node_Id; 5619 Flag_Id : Entity_Id; 5620 5621 begin 5622 -- Relocate the expression to the actions list by capturing its value 5623 -- in a Boolean flag. Generate: 5624 -- Flag : constant Boolean := Expr; 5625 5626 Flag_Id := Make_Temporary (Loc, 'F'); 5627 5628 Flag_Decl := 5629 Make_Object_Declaration (Loc, 5630 Defining_Identifier => Flag_Id, 5631 Constant_Present => True, 5632 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 5633 Expression => Relocate_Node (Expr)); 5634 5635 Append (Flag_Decl, Acts); 5636 Analyze (Flag_Decl); 5637 5638 -- Replace the expression with a reference to the flag 5639 5640 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc)); 5641 Analyze (Expression (N)); 5642 end Force_Boolean_Evaluation; 5643 5644 -------------------- 5645 -- Process_Action -- 5646 -------------------- 5647 5648 function Process_Action (Act : Node_Id) return Traverse_Result is 5649 begin 5650 if Nkind (Act) = N_Object_Declaration 5651 and then Is_Finalizable_Transient (Act, N) 5652 then 5653 Process_Transient_In_Expression (Act, N, Acts); 5654 return Skip; 5655 5656 -- Avoid processing temporary function results multiple times when 5657 -- dealing with nested expression_with_actions. 5658 5659 elsif Nkind (Act) = N_Expression_With_Actions then 5660 return Abandon; 5661 5662 -- Do not process temporary function results in loops. This is done 5663 -- by Expand_N_Loop_Statement and Build_Finalizer. 5664 5665 elsif Nkind (Act) = N_Loop_Statement then 5666 return Abandon; 5667 end if; 5668 5669 return OK; 5670 end Process_Action; 5671 5672 procedure Process_Single_Action is new Traverse_Proc (Process_Action); 5673 5674 -- Local variables 5675 5676 Act : Node_Id; 5677 5678 -- Start of processing for Expand_N_Expression_With_Actions 5679 5680 begin 5681 -- Do not evaluate the expression when it denotes an entity because the 5682 -- expression_with_actions node will be replaced by the reference. 5683 5684 if Is_Entity_Name (Expression (N)) then 5685 null; 5686 5687 -- Do not evaluate the expression when there are no actions because the 5688 -- expression_with_actions node will be replaced by the expression. 5689 5690 elsif No (Acts) or else Is_Empty_List (Acts) then 5691 null; 5692 5693 -- Force the evaluation of the expression by capturing its value in a 5694 -- temporary. This ensures that aliases of transient objects do not leak 5695 -- to the expression of the expression_with_actions node: 5696 5697 -- do 5698 -- Trans_Id : Ctrl_Typ := ...; 5699 -- Alias : ... := Trans_Id; 5700 -- in ... Alias ... end; 5701 5702 -- In the example above, Trans_Id cannot be finalized at the end of the 5703 -- actions list because this may affect the alias and the final value of 5704 -- the expression_with_actions. Forcing the evaluation encapsulates the 5705 -- reference to the Alias within the actions list: 5706 5707 -- do 5708 -- Trans_Id : Ctrl_Typ := ...; 5709 -- Alias : ... := Trans_Id; 5710 -- Val : constant Boolean := ... Alias ...; 5711 -- <finalize Trans_Id> 5712 -- in Val end; 5713 5714 -- Once this transformation is performed, it is safe to finalize the 5715 -- transient object at the end of the actions list. 5716 5717 -- Note that Force_Evaluation does not remove side effects in operators 5718 -- because it assumes that all operands are evaluated and side effect 5719 -- free. This is not the case when an operand depends implicitly on the 5720 -- transient object through the use of access types. 5721 5722 elsif Is_Boolean_Type (Etype (Expression (N))) then 5723 Force_Boolean_Evaluation (Expression (N)); 5724 5725 -- The expression of an expression_with_actions node may not necessarily 5726 -- be Boolean when the node appears in an if expression. In this case do 5727 -- the usual forced evaluation to encapsulate potential aliasing. 5728 5729 else 5730 Force_Evaluation (Expression (N)); 5731 end if; 5732 5733 -- Process all transient objects found within the actions of the EWA 5734 -- node. 5735 5736 Act := First (Acts); 5737 while Present (Act) loop 5738 Process_Single_Action (Act); 5739 Next (Act); 5740 end loop; 5741 5742 -- Deal with case where there are no actions. In this case we simply 5743 -- rewrite the node with its expression since we don't need the actions 5744 -- and the specification of this node does not allow a null action list. 5745 5746 -- Note: we use Rewrite instead of Replace, because Codepeer is using 5747 -- the expanded tree and relying on being able to retrieve the original 5748 -- tree in cases like this. This raises a whole lot of issues of whether 5749 -- we have problems elsewhere, which will be addressed in the future??? 5750 5751 if Is_Empty_List (Acts) then 5752 Rewrite (N, Relocate_Node (Expression (N))); 5753 end if; 5754 end Expand_N_Expression_With_Actions; 5755 5756 ---------------------------- 5757 -- Expand_N_If_Expression -- 5758 ---------------------------- 5759 5760 -- Deal with limited types and condition actions 5761 5762 procedure Expand_N_If_Expression (N : Node_Id) is 5763 Cond : constant Node_Id := First (Expressions (N)); 5764 Loc : constant Source_Ptr := Sloc (N); 5765 Thenx : constant Node_Id := Next (Cond); 5766 Elsex : constant Node_Id := Next (Thenx); 5767 Typ : constant Entity_Id := Etype (N); 5768 5769 Actions : List_Id; 5770 Decl : Node_Id; 5771 Expr : Node_Id; 5772 New_If : Node_Id; 5773 New_N : Node_Id; 5774 5775 begin 5776 -- Check for MINIMIZED/ELIMINATED overflow mode 5777 5778 if Minimized_Eliminated_Overflow_Check (N) then 5779 Apply_Arithmetic_Overflow_Check (N); 5780 return; 5781 end if; 5782 5783 -- Fold at compile time if condition known. We have already folded 5784 -- static if expressions, but it is possible to fold any case in which 5785 -- the condition is known at compile time, even though the result is 5786 -- non-static. 5787 5788 -- Note that we don't do the fold of such cases in Sem_Elab because 5789 -- it can cause infinite loops with the expander adding a conditional 5790 -- expression, and Sem_Elab circuitry removing it repeatedly. 5791 5792 if Compile_Time_Known_Value (Cond) then 5793 declare 5794 function Fold_Known_Value (Cond : Node_Id) return Boolean; 5795 -- Fold at compile time. Assumes condition known. Return True if 5796 -- folding occurred, meaning we're done. 5797 5798 ---------------------- 5799 -- Fold_Known_Value -- 5800 ---------------------- 5801 5802 function Fold_Known_Value (Cond : Node_Id) return Boolean is 5803 begin 5804 if Is_True (Expr_Value (Cond)) then 5805 Expr := Thenx; 5806 Actions := Then_Actions (N); 5807 else 5808 Expr := Elsex; 5809 Actions := Else_Actions (N); 5810 end if; 5811 5812 Remove (Expr); 5813 5814 if Present (Actions) then 5815 5816 -- To minimize the use of Expression_With_Actions, just skip 5817 -- the optimization as it is not critical for correctness. 5818 5819 if Minimize_Expression_With_Actions then 5820 return False; 5821 end if; 5822 5823 Rewrite (N, 5824 Make_Expression_With_Actions (Loc, 5825 Expression => Relocate_Node (Expr), 5826 Actions => Actions)); 5827 Analyze_And_Resolve (N, Typ); 5828 5829 else 5830 Rewrite (N, Relocate_Node (Expr)); 5831 end if; 5832 5833 -- Note that the result is never static (legitimate cases of 5834 -- static if expressions were folded in Sem_Eval). 5835 5836 Set_Is_Static_Expression (N, False); 5837 return True; 5838 end Fold_Known_Value; 5839 5840 begin 5841 if Fold_Known_Value (Cond) then 5842 return; 5843 end if; 5844 end; 5845 end if; 5846 5847 -- If the type is limited, and the back end does not handle limited 5848 -- types, then we expand as follows to avoid the possibility of 5849 -- improper copying. 5850 5851 -- type Ptr is access all Typ; 5852 -- Cnn : Ptr; 5853 -- if cond then 5854 -- <<then actions>> 5855 -- Cnn := then-expr'Unrestricted_Access; 5856 -- else 5857 -- <<else actions>> 5858 -- Cnn := else-expr'Unrestricted_Access; 5859 -- end if; 5860 5861 -- and replace the if expression by a reference to Cnn.all. 5862 5863 -- This special case can be skipped if the back end handles limited 5864 -- types properly and ensures that no incorrect copies are made. 5865 5866 if Is_By_Reference_Type (Typ) 5867 and then not Back_End_Handles_Limited_Types 5868 then 5869 -- When the "then" or "else" expressions involve controlled function 5870 -- calls, generated temporaries are chained on the corresponding list 5871 -- of actions. These temporaries need to be finalized after the if 5872 -- expression is evaluated. 5873 5874 Process_If_Case_Statements (N, Then_Actions (N)); 5875 Process_If_Case_Statements (N, Else_Actions (N)); 5876 5877 declare 5878 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N); 5879 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); 5880 5881 begin 5882 -- Generate: 5883 -- type Ann is access all Typ; 5884 5885 Insert_Action (N, 5886 Make_Full_Type_Declaration (Loc, 5887 Defining_Identifier => Ptr_Typ, 5888 Type_Definition => 5889 Make_Access_To_Object_Definition (Loc, 5890 All_Present => True, 5891 Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); 5892 5893 -- Generate: 5894 -- Cnn : Ann; 5895 5896 Decl := 5897 Make_Object_Declaration (Loc, 5898 Defining_Identifier => Cnn, 5899 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); 5900 5901 -- Generate: 5902 -- if Cond then 5903 -- Cnn := <Thenx>'Unrestricted_Access; 5904 -- else 5905 -- Cnn := <Elsex>'Unrestricted_Access; 5906 -- end if; 5907 5908 New_If := 5909 Make_Implicit_If_Statement (N, 5910 Condition => Relocate_Node (Cond), 5911 Then_Statements => New_List ( 5912 Make_Assignment_Statement (Sloc (Thenx), 5913 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 5914 Expression => 5915 Make_Attribute_Reference (Loc, 5916 Prefix => Relocate_Node (Thenx), 5917 Attribute_Name => Name_Unrestricted_Access))), 5918 5919 Else_Statements => New_List ( 5920 Make_Assignment_Statement (Sloc (Elsex), 5921 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 5922 Expression => 5923 Make_Attribute_Reference (Loc, 5924 Prefix => Relocate_Node (Elsex), 5925 Attribute_Name => Name_Unrestricted_Access)))); 5926 5927 -- Preserve the original context for which the if statement is 5928 -- being generated. This is needed by the finalization machinery 5929 -- to prevent the premature finalization of controlled objects 5930 -- found within the if statement. 5931 5932 Set_From_Conditional_Expression (New_If); 5933 5934 New_N := 5935 Make_Explicit_Dereference (Loc, 5936 Prefix => New_Occurrence_Of (Cnn, Loc)); 5937 end; 5938 5939 -- If the result is an unconstrained array and the if expression is in a 5940 -- context other than the initializing expression of the declaration of 5941 -- an object, then we pull out the if expression as follows: 5942 5943 -- Cnn : constant typ := if-expression 5944 5945 -- and then replace the if expression with an occurrence of Cnn. This 5946 -- avoids the need in the back end to create on-the-fly variable length 5947 -- temporaries (which it cannot do!) 5948 5949 -- Note that the test for being in an object declaration avoids doing an 5950 -- unnecessary expansion, and also avoids infinite recursion. 5951 5952 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) 5953 and then (Nkind (Parent (N)) /= N_Object_Declaration 5954 or else Expression (Parent (N)) /= N) 5955 then 5956 declare 5957 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); 5958 5959 begin 5960 Insert_Action (N, 5961 Make_Object_Declaration (Loc, 5962 Defining_Identifier => Cnn, 5963 Constant_Present => True, 5964 Object_Definition => New_Occurrence_Of (Typ, Loc), 5965 Expression => Relocate_Node (N), 5966 Has_Init_Expression => True)); 5967 5968 Rewrite (N, New_Occurrence_Of (Cnn, Loc)); 5969 return; 5970 end; 5971 5972 -- For other types, we only need to expand if there are other actions 5973 -- associated with either branch. 5974 5975 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then 5976 5977 -- We now wrap the actions into the appropriate expression 5978 5979 if Minimize_Expression_With_Actions 5980 and then (Is_Elementary_Type (Underlying_Type (Typ)) 5981 or else Is_Constrained (Underlying_Type (Typ))) 5982 then 5983 -- If we can't use N_Expression_With_Actions nodes, then we insert 5984 -- the following sequence of actions (using Insert_Actions): 5985 5986 -- Cnn : typ; 5987 -- if cond then 5988 -- <<then actions>> 5989 -- Cnn := then-expr; 5990 -- else 5991 -- <<else actions>> 5992 -- Cnn := else-expr 5993 -- end if; 5994 5995 -- and replace the if expression by a reference to Cnn 5996 5997 declare 5998 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); 5999 6000 begin 6001 Decl := 6002 Make_Object_Declaration (Loc, 6003 Defining_Identifier => Cnn, 6004 Object_Definition => New_Occurrence_Of (Typ, Loc)); 6005 6006 New_If := 6007 Make_Implicit_If_Statement (N, 6008 Condition => Relocate_Node (Cond), 6009 6010 Then_Statements => New_List ( 6011 Make_Assignment_Statement (Sloc (Thenx), 6012 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 6013 Expression => Relocate_Node (Thenx))), 6014 6015 Else_Statements => New_List ( 6016 Make_Assignment_Statement (Sloc (Elsex), 6017 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 6018 Expression => Relocate_Node (Elsex)))); 6019 6020 Set_Assignment_OK (Name (First (Then_Statements (New_If)))); 6021 Set_Assignment_OK (Name (First (Else_Statements (New_If)))); 6022 6023 New_N := New_Occurrence_Of (Cnn, Loc); 6024 end; 6025 6026 -- Regular path using Expression_With_Actions 6027 6028 else 6029 if Present (Then_Actions (N)) then 6030 Rewrite (Thenx, 6031 Make_Expression_With_Actions (Sloc (Thenx), 6032 Actions => Then_Actions (N), 6033 Expression => Relocate_Node (Thenx))); 6034 6035 Set_Then_Actions (N, No_List); 6036 Analyze_And_Resolve (Thenx, Typ); 6037 end if; 6038 6039 if Present (Else_Actions (N)) then 6040 Rewrite (Elsex, 6041 Make_Expression_With_Actions (Sloc (Elsex), 6042 Actions => Else_Actions (N), 6043 Expression => Relocate_Node (Elsex))); 6044 6045 Set_Else_Actions (N, No_List); 6046 Analyze_And_Resolve (Elsex, Typ); 6047 end if; 6048 6049 return; 6050 end if; 6051 6052 -- If no actions then no expansion needed, gigi will handle it using the 6053 -- same approach as a C conditional expression. 6054 6055 else 6056 return; 6057 end if; 6058 6059 -- Fall through here for either the limited expansion, or the case of 6060 -- inserting actions for nonlimited types. In both these cases, we must 6061 -- move the SLOC of the parent If statement to the newly created one and 6062 -- change it to the SLOC of the expression which, after expansion, will 6063 -- correspond to what is being evaluated. 6064 6065 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then 6066 Set_Sloc (New_If, Sloc (Parent (N))); 6067 Set_Sloc (Parent (N), Loc); 6068 end if; 6069 6070 -- Make sure Then_Actions and Else_Actions are appropriately moved 6071 -- to the new if statement. 6072 6073 if Present (Then_Actions (N)) then 6074 Insert_List_Before 6075 (First (Then_Statements (New_If)), Then_Actions (N)); 6076 end if; 6077 6078 if Present (Else_Actions (N)) then 6079 Insert_List_Before 6080 (First (Else_Statements (New_If)), Else_Actions (N)); 6081 end if; 6082 6083 Insert_Action (N, Decl); 6084 Insert_Action (N, New_If); 6085 Rewrite (N, New_N); 6086 Analyze_And_Resolve (N, Typ); 6087 end Expand_N_If_Expression; 6088 6089 ----------------- 6090 -- Expand_N_In -- 6091 ----------------- 6092 6093 procedure Expand_N_In (N : Node_Id) is 6094 Loc : constant Source_Ptr := Sloc (N); 6095 Restyp : constant Entity_Id := Etype (N); 6096 Lop : constant Node_Id := Left_Opnd (N); 6097 Rop : constant Node_Id := Right_Opnd (N); 6098 Static : constant Boolean := Is_OK_Static_Expression (N); 6099 6100 procedure Substitute_Valid_Check; 6101 -- Replaces node N by Lop'Valid. This is done when we have an explicit 6102 -- test for the left operand being in range of its subtype. 6103 6104 ---------------------------- 6105 -- Substitute_Valid_Check -- 6106 ---------------------------- 6107 6108 procedure Substitute_Valid_Check is 6109 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean; 6110 -- Determine whether arbitrary node Nod denotes a source object that 6111 -- may safely act as prefix of attribute 'Valid. 6112 6113 ---------------------------- 6114 -- Is_OK_Object_Reference -- 6115 ---------------------------- 6116 6117 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is 6118 Obj_Ref : Node_Id; 6119 6120 begin 6121 -- Inspect the original operand 6122 6123 Obj_Ref := Original_Node (Nod); 6124 6125 -- The object reference must be a source construct, otherwise the 6126 -- codefix suggestion may refer to nonexistent code from a user 6127 -- perspective. 6128 6129 if Comes_From_Source (Obj_Ref) then 6130 6131 -- Recover the actual object reference. There may be more cases 6132 -- to consider??? 6133 6134 loop 6135 if Nkind_In (Obj_Ref, N_Type_Conversion, 6136 N_Unchecked_Type_Conversion) 6137 then 6138 Obj_Ref := Expression (Obj_Ref); 6139 else 6140 exit; 6141 end if; 6142 end loop; 6143 6144 return Is_Object_Reference (Obj_Ref); 6145 end if; 6146 6147 return False; 6148 end Is_OK_Object_Reference; 6149 6150 -- Start of processing for Substitute_Valid_Check 6151 6152 begin 6153 Rewrite (N, 6154 Make_Attribute_Reference (Loc, 6155 Prefix => Relocate_Node (Lop), 6156 Attribute_Name => Name_Valid)); 6157 6158 Analyze_And_Resolve (N, Restyp); 6159 6160 -- Emit a warning when the left-hand operand of the membership test 6161 -- is a source object, otherwise the use of attribute 'Valid would be 6162 -- illegal. The warning is not given when overflow checking is either 6163 -- MINIMIZED or ELIMINATED, as the danger of optimization has been 6164 -- eliminated above. 6165 6166 if Is_OK_Object_Reference (Lop) 6167 and then Overflow_Check_Mode not in Minimized_Or_Eliminated 6168 then 6169 Error_Msg_N 6170 ("??explicit membership test may be optimized away", N); 6171 Error_Msg_N -- CODEFIX 6172 ("\??use ''Valid attribute instead", N); 6173 end if; 6174 end Substitute_Valid_Check; 6175 6176 -- Local variables 6177 6178 Ltyp : Entity_Id; 6179 Rtyp : Entity_Id; 6180 6181 -- Start of processing for Expand_N_In 6182 6183 begin 6184 -- If set membership case, expand with separate procedure 6185 6186 if Present (Alternatives (N)) then 6187 Expand_Set_Membership (N); 6188 return; 6189 end if; 6190 6191 -- Not set membership, proceed with expansion 6192 6193 Ltyp := Etype (Left_Opnd (N)); 6194 Rtyp := Etype (Right_Opnd (N)); 6195 6196 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer 6197 -- type, then expand with a separate procedure. Note the use of the 6198 -- flag No_Minimize_Eliminate to prevent infinite recursion. 6199 6200 if Overflow_Check_Mode in Minimized_Or_Eliminated 6201 and then Is_Signed_Integer_Type (Ltyp) 6202 and then not No_Minimize_Eliminate (N) 6203 then 6204 Expand_Membership_Minimize_Eliminate_Overflow (N); 6205 return; 6206 end if; 6207 6208 -- Check case of explicit test for an expression in range of its 6209 -- subtype. This is suspicious usage and we replace it with a 'Valid 6210 -- test and give a warning for scalar types. 6211 6212 if Is_Scalar_Type (Ltyp) 6213 6214 -- Only relevant for source comparisons 6215 6216 and then Comes_From_Source (N) 6217 6218 -- In floating-point this is a standard way to check for finite values 6219 -- and using 'Valid would typically be a pessimization. 6220 6221 and then not Is_Floating_Point_Type (Ltyp) 6222 6223 -- Don't give the message unless right operand is a type entity and 6224 -- the type of the left operand matches this type. Note that this 6225 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow 6226 -- checks have changed the type of the left operand. 6227 6228 and then Nkind (Rop) in N_Has_Entity 6229 and then Ltyp = Entity (Rop) 6230 6231 -- Skip this for predicated types, where such expressions are a 6232 -- reasonable way of testing if something meets the predicate. 6233 6234 and then not Present (Predicate_Function (Ltyp)) 6235 then 6236 Substitute_Valid_Check; 6237 return; 6238 end if; 6239 6240 -- Do validity check on operands 6241 6242 if Validity_Checks_On and Validity_Check_Operands then 6243 Ensure_Valid (Left_Opnd (N)); 6244 Validity_Check_Range (Right_Opnd (N)); 6245 end if; 6246 6247 -- Case of explicit range 6248 6249 if Nkind (Rop) = N_Range then 6250 declare 6251 Lo : constant Node_Id := Low_Bound (Rop); 6252 Hi : constant Node_Id := High_Bound (Rop); 6253 6254 Lo_Orig : constant Node_Id := Original_Node (Lo); 6255 Hi_Orig : constant Node_Id := Original_Node (Hi); 6256 6257 Lcheck : Compare_Result; 6258 Ucheck : Compare_Result; 6259 6260 Warn1 : constant Boolean := 6261 Constant_Condition_Warnings 6262 and then Comes_From_Source (N) 6263 and then not In_Instance; 6264 -- This must be true for any of the optimization warnings, we 6265 -- clearly want to give them only for source with the flag on. We 6266 -- also skip these warnings in an instance since it may be the 6267 -- case that different instantiations have different ranges. 6268 6269 Warn2 : constant Boolean := 6270 Warn1 6271 and then Nkind (Original_Node (Rop)) = N_Range 6272 and then Is_Integer_Type (Etype (Lo)); 6273 -- For the case where only one bound warning is elided, we also 6274 -- insist on an explicit range and an integer type. The reason is 6275 -- that the use of enumeration ranges including an end point is 6276 -- common, as is the use of a subtype name, one of whose bounds is 6277 -- the same as the type of the expression. 6278 6279 begin 6280 -- If test is explicit x'First .. x'Last, replace by valid check 6281 6282 -- Could use some individual comments for this complex test ??? 6283 6284 if Is_Scalar_Type (Ltyp) 6285 6286 -- And left operand is X'First where X matches left operand 6287 -- type (this eliminates cases of type mismatch, including 6288 -- the cases where ELIMINATED/MINIMIZED mode has changed the 6289 -- type of the left operand. 6290 6291 and then Nkind (Lo_Orig) = N_Attribute_Reference 6292 and then Attribute_Name (Lo_Orig) = Name_First 6293 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity 6294 and then Entity (Prefix (Lo_Orig)) = Ltyp 6295 6296 -- Same tests for right operand 6297 6298 and then Nkind (Hi_Orig) = N_Attribute_Reference 6299 and then Attribute_Name (Hi_Orig) = Name_Last 6300 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity 6301 and then Entity (Prefix (Hi_Orig)) = Ltyp 6302 6303 -- Relevant only for source cases 6304 6305 and then Comes_From_Source (N) 6306 then 6307 Substitute_Valid_Check; 6308 goto Leave; 6309 end if; 6310 6311 -- If bounds of type are known at compile time, and the end points 6312 -- are known at compile time and identical, this is another case 6313 -- for substituting a valid test. We only do this for discrete 6314 -- types, since it won't arise in practice for float types. 6315 6316 if Comes_From_Source (N) 6317 and then Is_Discrete_Type (Ltyp) 6318 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) 6319 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) 6320 and then Compile_Time_Known_Value (Lo) 6321 and then Compile_Time_Known_Value (Hi) 6322 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) 6323 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) 6324 6325 -- Kill warnings in instances, since they may be cases where we 6326 -- have a test in the generic that makes sense with some types 6327 -- and not with other types. 6328 6329 -- Similarly, do not rewrite membership as a validity check if 6330 -- within the predicate function for the type. 6331 6332 -- Finally, if the original bounds are type conversions, even 6333 -- if they have been folded into constants, there are different 6334 -- types involved and 'Valid is not appropriate. 6335 6336 then 6337 if In_Instance 6338 or else (Ekind (Current_Scope) = E_Function 6339 and then Is_Predicate_Function (Current_Scope)) 6340 then 6341 null; 6342 6343 elsif Nkind (Lo_Orig) = N_Type_Conversion 6344 or else Nkind (Hi_Orig) = N_Type_Conversion 6345 then 6346 null; 6347 6348 else 6349 Substitute_Valid_Check; 6350 goto Leave; 6351 end if; 6352 end if; 6353 6354 -- If we have an explicit range, do a bit of optimization based on 6355 -- range analysis (we may be able to kill one or both checks). 6356 6357 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); 6358 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); 6359 6360 -- If either check is known to fail, replace result by False since 6361 -- the other check does not matter. Preserve the static flag for 6362 -- legality checks, because we are constant-folding beyond RM 4.9. 6363 6364 if Lcheck = LT or else Ucheck = GT then 6365 if Warn1 then 6366 Error_Msg_N ("?c?range test optimized away", N); 6367 Error_Msg_N ("\?c?value is known to be out of range", N); 6368 end if; 6369 6370 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6371 Analyze_And_Resolve (N, Restyp); 6372 Set_Is_Static_Expression (N, Static); 6373 goto Leave; 6374 6375 -- If both checks are known to succeed, replace result by True, 6376 -- since we know we are in range. 6377 6378 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 6379 if Warn1 then 6380 Error_Msg_N ("?c?range test optimized away", N); 6381 Error_Msg_N ("\?c?value is known to be in range", N); 6382 end if; 6383 6384 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6385 Analyze_And_Resolve (N, Restyp); 6386 Set_Is_Static_Expression (N, Static); 6387 goto Leave; 6388 6389 -- If lower bound check succeeds and upper bound check is not 6390 -- known to succeed or fail, then replace the range check with 6391 -- a comparison against the upper bound. 6392 6393 elsif Lcheck in Compare_GE then 6394 if Warn2 and then not In_Instance then 6395 Error_Msg_N ("??lower bound test optimized away", Lo); 6396 Error_Msg_N ("\??value is known to be in range", Lo); 6397 end if; 6398 6399 Rewrite (N, 6400 Make_Op_Le (Loc, 6401 Left_Opnd => Lop, 6402 Right_Opnd => High_Bound (Rop))); 6403 Analyze_And_Resolve (N, Restyp); 6404 goto Leave; 6405 6406 -- If upper bound check succeeds and lower bound check is not 6407 -- known to succeed or fail, then replace the range check with 6408 -- a comparison against the lower bound. 6409 6410 elsif Ucheck in Compare_LE then 6411 if Warn2 and then not In_Instance then 6412 Error_Msg_N ("??upper bound test optimized away", Hi); 6413 Error_Msg_N ("\??value is known to be in range", Hi); 6414 end if; 6415 6416 Rewrite (N, 6417 Make_Op_Ge (Loc, 6418 Left_Opnd => Lop, 6419 Right_Opnd => Low_Bound (Rop))); 6420 Analyze_And_Resolve (N, Restyp); 6421 goto Leave; 6422 end if; 6423 6424 -- We couldn't optimize away the range check, but there is one 6425 -- more issue. If we are checking constant conditionals, then we 6426 -- see if we can determine the outcome assuming everything is 6427 -- valid, and if so give an appropriate warning. 6428 6429 if Warn1 and then not Assume_No_Invalid_Values then 6430 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True); 6431 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True); 6432 6433 -- Result is out of range for valid value 6434 6435 if Lcheck = LT or else Ucheck = GT then 6436 Error_Msg_N 6437 ("?c?value can only be in range if it is invalid", N); 6438 6439 -- Result is in range for valid value 6440 6441 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 6442 Error_Msg_N 6443 ("?c?value can only be out of range if it is invalid", N); 6444 6445 -- Lower bound check succeeds if value is valid 6446 6447 elsif Warn2 and then Lcheck in Compare_GE then 6448 Error_Msg_N 6449 ("?c?lower bound check only fails if it is invalid", Lo); 6450 6451 -- Upper bound check succeeds if value is valid 6452 6453 elsif Warn2 and then Ucheck in Compare_LE then 6454 Error_Msg_N 6455 ("?c?upper bound check only fails for invalid values", Hi); 6456 end if; 6457 end if; 6458 end; 6459 6460 -- For all other cases of an explicit range, nothing to be done 6461 6462 goto Leave; 6463 6464 -- Here right operand is a subtype mark 6465 6466 else 6467 declare 6468 Typ : Entity_Id := Etype (Rop); 6469 Is_Acc : constant Boolean := Is_Access_Type (Typ); 6470 Cond : Node_Id := Empty; 6471 New_N : Node_Id; 6472 Obj : Node_Id := Lop; 6473 SCIL_Node : Node_Id; 6474 6475 begin 6476 Remove_Side_Effects (Obj); 6477 6478 -- For tagged type, do tagged membership operation 6479 6480 if Is_Tagged_Type (Typ) then 6481 6482 -- No expansion will be performed for VM targets, as the VM 6483 -- back ends will handle the membership tests directly. 6484 6485 if Tagged_Type_Expansion then 6486 Tagged_Membership (N, SCIL_Node, New_N); 6487 Rewrite (N, New_N); 6488 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks); 6489 6490 -- Update decoration of relocated node referenced by the 6491 -- SCIL node. 6492 6493 if Generate_SCIL and then Present (SCIL_Node) then 6494 Set_SCIL_Node (N, SCIL_Node); 6495 end if; 6496 end if; 6497 6498 goto Leave; 6499 6500 -- If type is scalar type, rewrite as x in t'First .. t'Last. 6501 -- This reason we do this is that the bounds may have the wrong 6502 -- type if they come from the original type definition. Also this 6503 -- way we get all the processing above for an explicit range. 6504 6505 -- Don't do this for predicated types, since in this case we 6506 -- want to check the predicate. 6507 6508 elsif Is_Scalar_Type (Typ) then 6509 if No (Predicate_Function (Typ)) then 6510 Rewrite (Rop, 6511 Make_Range (Loc, 6512 Low_Bound => 6513 Make_Attribute_Reference (Loc, 6514 Attribute_Name => Name_First, 6515 Prefix => New_Occurrence_Of (Typ, Loc)), 6516 6517 High_Bound => 6518 Make_Attribute_Reference (Loc, 6519 Attribute_Name => Name_Last, 6520 Prefix => New_Occurrence_Of (Typ, Loc)))); 6521 Analyze_And_Resolve (N, Restyp); 6522 end if; 6523 6524 goto Leave; 6525 6526 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 6527 -- a membership test if the subtype mark denotes a constrained 6528 -- Unchecked_Union subtype and the expression lacks inferable 6529 -- discriminants. 6530 6531 elsif Is_Unchecked_Union (Base_Type (Typ)) 6532 and then Is_Constrained (Typ) 6533 and then not Has_Inferable_Discriminants (Lop) 6534 then 6535 Insert_Action (N, 6536 Make_Raise_Program_Error (Loc, 6537 Reason => PE_Unchecked_Union_Restriction)); 6538 6539 -- Prevent Gigi from generating incorrect code by rewriting the 6540 -- test as False. What is this undocumented thing about ??? 6541 6542 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6543 goto Leave; 6544 end if; 6545 6546 -- Here we have a non-scalar type 6547 6548 if Is_Acc then 6549 Typ := Designated_Type (Typ); 6550 end if; 6551 6552 if not Is_Constrained (Typ) then 6553 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6554 Analyze_And_Resolve (N, Restyp); 6555 6556 -- For the constrained array case, we have to check the subscripts 6557 -- for an exact match if the lengths are non-zero (the lengths 6558 -- must match in any case). 6559 6560 elsif Is_Array_Type (Typ) then 6561 Check_Subscripts : declare 6562 function Build_Attribute_Reference 6563 (E : Node_Id; 6564 Nam : Name_Id; 6565 Dim : Nat) return Node_Id; 6566 -- Build attribute reference E'Nam (Dim) 6567 6568 ------------------------------- 6569 -- Build_Attribute_Reference -- 6570 ------------------------------- 6571 6572 function Build_Attribute_Reference 6573 (E : Node_Id; 6574 Nam : Name_Id; 6575 Dim : Nat) return Node_Id 6576 is 6577 begin 6578 return 6579 Make_Attribute_Reference (Loc, 6580 Prefix => E, 6581 Attribute_Name => Nam, 6582 Expressions => New_List ( 6583 Make_Integer_Literal (Loc, Dim))); 6584 end Build_Attribute_Reference; 6585 6586 -- Start of processing for Check_Subscripts 6587 6588 begin 6589 for J in 1 .. Number_Dimensions (Typ) loop 6590 Evolve_And_Then (Cond, 6591 Make_Op_Eq (Loc, 6592 Left_Opnd => 6593 Build_Attribute_Reference 6594 (Duplicate_Subexpr_No_Checks (Obj), 6595 Name_First, J), 6596 Right_Opnd => 6597 Build_Attribute_Reference 6598 (New_Occurrence_Of (Typ, Loc), Name_First, J))); 6599 6600 Evolve_And_Then (Cond, 6601 Make_Op_Eq (Loc, 6602 Left_Opnd => 6603 Build_Attribute_Reference 6604 (Duplicate_Subexpr_No_Checks (Obj), 6605 Name_Last, J), 6606 Right_Opnd => 6607 Build_Attribute_Reference 6608 (New_Occurrence_Of (Typ, Loc), Name_Last, J))); 6609 end loop; 6610 6611 if Is_Acc then 6612 Cond := 6613 Make_Or_Else (Loc, 6614 Left_Opnd => 6615 Make_Op_Eq (Loc, 6616 Left_Opnd => Obj, 6617 Right_Opnd => Make_Null (Loc)), 6618 Right_Opnd => Cond); 6619 end if; 6620 6621 Rewrite (N, Cond); 6622 Analyze_And_Resolve (N, Restyp); 6623 end Check_Subscripts; 6624 6625 -- These are the cases where constraint checks may be required, 6626 -- e.g. records with possible discriminants 6627 6628 else 6629 -- Expand the test into a series of discriminant comparisons. 6630 -- The expression that is built is the negation of the one that 6631 -- is used for checking discriminant constraints. 6632 6633 Obj := Relocate_Node (Left_Opnd (N)); 6634 6635 if Has_Discriminants (Typ) then 6636 Cond := Make_Op_Not (Loc, 6637 Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); 6638 6639 if Is_Acc then 6640 Cond := Make_Or_Else (Loc, 6641 Left_Opnd => 6642 Make_Op_Eq (Loc, 6643 Left_Opnd => Obj, 6644 Right_Opnd => Make_Null (Loc)), 6645 Right_Opnd => Cond); 6646 end if; 6647 6648 else 6649 Cond := New_Occurrence_Of (Standard_True, Loc); 6650 end if; 6651 6652 Rewrite (N, Cond); 6653 Analyze_And_Resolve (N, Restyp); 6654 end if; 6655 6656 -- Ada 2012 (AI05-0149): Handle membership tests applied to an 6657 -- expression of an anonymous access type. This can involve an 6658 -- accessibility test and a tagged type membership test in the 6659 -- case of tagged designated types. 6660 6661 if Ada_Version >= Ada_2012 6662 and then Is_Acc 6663 and then Ekind (Ltyp) = E_Anonymous_Access_Type 6664 then 6665 declare 6666 Expr_Entity : Entity_Id := Empty; 6667 New_N : Node_Id; 6668 Param_Level : Node_Id; 6669 Type_Level : Node_Id; 6670 6671 begin 6672 if Is_Entity_Name (Lop) then 6673 Expr_Entity := Param_Entity (Lop); 6674 6675 if not Present (Expr_Entity) then 6676 Expr_Entity := Entity (Lop); 6677 end if; 6678 end if; 6679 6680 -- If a conversion of the anonymous access value to the 6681 -- tested type would be illegal, then the result is False. 6682 6683 if not Valid_Conversion 6684 (Lop, Rtyp, Lop, Report_Errs => False) 6685 then 6686 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6687 Analyze_And_Resolve (N, Restyp); 6688 6689 -- Apply an accessibility check if the access object has an 6690 -- associated access level and when the level of the type is 6691 -- less deep than the level of the access parameter. This 6692 -- only occur for access parameters and stand-alone objects 6693 -- of an anonymous access type. 6694 6695 else 6696 if Present (Expr_Entity) 6697 and then 6698 Present 6699 (Effective_Extra_Accessibility (Expr_Entity)) 6700 and then UI_Gt (Object_Access_Level (Lop), 6701 Type_Access_Level (Rtyp)) 6702 then 6703 Param_Level := 6704 New_Occurrence_Of 6705 (Effective_Extra_Accessibility (Expr_Entity), Loc); 6706 6707 Type_Level := 6708 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); 6709 6710 -- Return True only if the accessibility level of the 6711 -- expression entity is not deeper than the level of 6712 -- the tested access type. 6713 6714 Rewrite (N, 6715 Make_And_Then (Loc, 6716 Left_Opnd => Relocate_Node (N), 6717 Right_Opnd => Make_Op_Le (Loc, 6718 Left_Opnd => Param_Level, 6719 Right_Opnd => Type_Level))); 6720 6721 Analyze_And_Resolve (N); 6722 end if; 6723 6724 -- If the designated type is tagged, do tagged membership 6725 -- operation. 6726 6727 -- *** NOTE: we have to check not null before doing the 6728 -- tagged membership test (but maybe that can be done 6729 -- inside Tagged_Membership?). 6730 6731 if Is_Tagged_Type (Typ) then 6732 Rewrite (N, 6733 Make_And_Then (Loc, 6734 Left_Opnd => Relocate_Node (N), 6735 Right_Opnd => 6736 Make_Op_Ne (Loc, 6737 Left_Opnd => Obj, 6738 Right_Opnd => Make_Null (Loc)))); 6739 6740 -- No expansion will be performed for VM targets, as 6741 -- the VM back ends will handle the membership tests 6742 -- directly. 6743 6744 if Tagged_Type_Expansion then 6745 6746 -- Note that we have to pass Original_Node, because 6747 -- the membership test might already have been 6748 -- rewritten by earlier parts of membership test. 6749 6750 Tagged_Membership 6751 (Original_Node (N), SCIL_Node, New_N); 6752 6753 -- Update decoration of relocated node referenced 6754 -- by the SCIL node. 6755 6756 if Generate_SCIL and then Present (SCIL_Node) then 6757 Set_SCIL_Node (New_N, SCIL_Node); 6758 end if; 6759 6760 Rewrite (N, 6761 Make_And_Then (Loc, 6762 Left_Opnd => Relocate_Node (N), 6763 Right_Opnd => New_N)); 6764 6765 Analyze_And_Resolve (N, Restyp); 6766 end if; 6767 end if; 6768 end if; 6769 end; 6770 end if; 6771 end; 6772 end if; 6773 6774 -- At this point, we have done the processing required for the basic 6775 -- membership test, but not yet dealt with the predicate. 6776 6777 <<Leave>> 6778 6779 -- If a predicate is present, then we do the predicate test, but we 6780 -- most certainly want to omit this if we are within the predicate 6781 -- function itself, since otherwise we have an infinite recursion. 6782 -- The check should also not be emitted when testing against a range 6783 -- (the check is only done when the right operand is a subtype; see 6784 -- RM12-4.5.2 (28.1/3-30/3)). 6785 6786 Predicate_Check : declare 6787 function In_Range_Check return Boolean; 6788 -- Within an expanded range check that may raise Constraint_Error do 6789 -- not generate a predicate check as well. It is redundant because 6790 -- the context will add an explicit predicate check, and it will 6791 -- raise the wrong exception if it fails. 6792 6793 -------------------- 6794 -- In_Range_Check -- 6795 -------------------- 6796 6797 function In_Range_Check return Boolean is 6798 P : Node_Id; 6799 begin 6800 P := Parent (N); 6801 while Present (P) loop 6802 if Nkind (P) = N_Raise_Constraint_Error then 6803 return True; 6804 6805 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call 6806 or else Nkind (P) = N_Procedure_Call_Statement 6807 or else Nkind (P) in N_Declaration 6808 then 6809 return False; 6810 end if; 6811 6812 P := Parent (P); 6813 end loop; 6814 6815 return False; 6816 end In_Range_Check; 6817 6818 -- Local variables 6819 6820 PFunc : constant Entity_Id := Predicate_Function (Rtyp); 6821 R_Op : Node_Id; 6822 6823 -- Start of processing for Predicate_Check 6824 6825 begin 6826 if Present (PFunc) 6827 and then Current_Scope /= PFunc 6828 and then Nkind (Rop) /= N_Range 6829 then 6830 if not In_Range_Check then 6831 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True); 6832 else 6833 R_Op := New_Occurrence_Of (Standard_True, Loc); 6834 end if; 6835 6836 Rewrite (N, 6837 Make_And_Then (Loc, 6838 Left_Opnd => Relocate_Node (N), 6839 Right_Opnd => R_Op)); 6840 6841 -- Analyze new expression, mark left operand as analyzed to 6842 -- avoid infinite recursion adding predicate calls. Similarly, 6843 -- suppress further range checks on the call. 6844 6845 Set_Analyzed (Left_Opnd (N)); 6846 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 6847 6848 -- All done, skip attempt at compile time determination of result 6849 6850 return; 6851 end if; 6852 end Predicate_Check; 6853 end Expand_N_In; 6854 6855 -------------------------------- 6856 -- Expand_N_Indexed_Component -- 6857 -------------------------------- 6858 6859 procedure Expand_N_Indexed_Component (N : Node_Id) is 6860 Loc : constant Source_Ptr := Sloc (N); 6861 Typ : constant Entity_Id := Etype (N); 6862 P : constant Node_Id := Prefix (N); 6863 T : constant Entity_Id := Etype (P); 6864 Atp : Entity_Id; 6865 6866 begin 6867 -- A special optimization, if we have an indexed component that is 6868 -- selecting from a slice, then we can eliminate the slice, since, for 6869 -- example, x (i .. j)(k) is identical to x(k). The only difference is 6870 -- the range check required by the slice. The range check for the slice 6871 -- itself has already been generated. The range check for the 6872 -- subscripting operation is ensured by converting the subject to 6873 -- the subtype of the slice. 6874 6875 -- This optimization not only generates better code, avoiding slice 6876 -- messing especially in the packed case, but more importantly bypasses 6877 -- some problems in handling this peculiar case, for example, the issue 6878 -- of dealing specially with object renamings. 6879 6880 if Nkind (P) = N_Slice 6881 6882 -- This optimization is disabled for CodePeer because it can transform 6883 -- an index-check constraint_error into a range-check constraint_error 6884 -- and CodePeer cares about that distinction. 6885 6886 and then not CodePeer_Mode 6887 then 6888 Rewrite (N, 6889 Make_Indexed_Component (Loc, 6890 Prefix => Prefix (P), 6891 Expressions => New_List ( 6892 Convert_To 6893 (Etype (First_Index (Etype (P))), 6894 First (Expressions (N)))))); 6895 Analyze_And_Resolve (N, Typ); 6896 return; 6897 end if; 6898 6899 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 6900 -- function, then additional actuals must be passed. 6901 6902 if Is_Build_In_Place_Function_Call (P) then 6903 Make_Build_In_Place_Call_In_Anonymous_Context (P); 6904 6905 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 6906 -- containing build-in-place function calls whose returned object covers 6907 -- interface types. 6908 6909 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then 6910 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); 6911 end if; 6912 6913 -- If the prefix is an access type, then we unconditionally rewrite if 6914 -- as an explicit dereference. This simplifies processing for several 6915 -- cases, including packed array cases and certain cases in which checks 6916 -- must be generated. We used to try to do this only when it was 6917 -- necessary, but it cleans up the code to do it all the time. 6918 6919 if Is_Access_Type (T) then 6920 Insert_Explicit_Dereference (P); 6921 Analyze_And_Resolve (P, Designated_Type (T)); 6922 Atp := Designated_Type (T); 6923 else 6924 Atp := T; 6925 end if; 6926 6927 -- Generate index and validity checks 6928 6929 Generate_Index_Checks (N); 6930 6931 if Validity_Checks_On and then Validity_Check_Subscripts then 6932 Apply_Subscript_Validity_Checks (N); 6933 end if; 6934 6935 -- If selecting from an array with atomic components, and atomic sync 6936 -- is not suppressed for this array type, set atomic sync flag. 6937 6938 if (Has_Atomic_Components (Atp) 6939 and then not Atomic_Synchronization_Disabled (Atp)) 6940 or else (Is_Atomic (Typ) 6941 and then not Atomic_Synchronization_Disabled (Typ)) 6942 or else (Is_Entity_Name (P) 6943 and then Has_Atomic_Components (Entity (P)) 6944 and then not Atomic_Synchronization_Disabled (Entity (P))) 6945 then 6946 Activate_Atomic_Synchronization (N); 6947 end if; 6948 6949 -- All done if the prefix is not a packed array implemented specially 6950 6951 if not (Is_Packed (Etype (Prefix (N))) 6952 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N))))) 6953 then 6954 return; 6955 end if; 6956 6957 -- For packed arrays that are not bit-packed (i.e. the case of an array 6958 -- with one or more index types with a non-contiguous enumeration type), 6959 -- we can always use the normal packed element get circuit. 6960 6961 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then 6962 Expand_Packed_Element_Reference (N); 6963 return; 6964 end if; 6965 6966 -- For a reference to a component of a bit packed array, we convert it 6967 -- to a reference to the corresponding Packed_Array_Impl_Type. We only 6968 -- want to do this for simple references, and not for: 6969 6970 -- Left side of assignment, or prefix of left side of assignment, or 6971 -- prefix of the prefix, to handle packed arrays of packed arrays, 6972 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement 6973 6974 -- Renaming objects in renaming associations 6975 -- This case is handled when a use of the renamed variable occurs 6976 6977 -- Actual parameters for a subprogram call 6978 -- This case is handled in Exp_Ch6.Expand_Actuals 6979 6980 -- The second expression in a 'Read attribute reference 6981 6982 -- The prefix of an address or bit or size attribute reference 6983 6984 -- The following circuit detects these exceptions. Note that we need to 6985 -- deal with implicit dereferences when climbing up the parent chain, 6986 -- with the additional difficulty that the type of parents may have yet 6987 -- to be resolved since prefixes are usually resolved first. 6988 6989 declare 6990 Child : Node_Id := N; 6991 Parnt : Node_Id := Parent (N); 6992 6993 begin 6994 loop 6995 if Nkind (Parnt) = N_Unchecked_Expression then 6996 null; 6997 6998 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then 6999 return; 7000 7001 elsif Nkind (Parnt) in N_Subprogram_Call 7002 or else (Nkind (Parnt) = N_Parameter_Association 7003 and then Nkind (Parent (Parnt)) in N_Subprogram_Call) 7004 then 7005 return; 7006 7007 elsif Nkind (Parnt) = N_Attribute_Reference 7008 and then Nam_In (Attribute_Name (Parnt), Name_Address, 7009 Name_Bit, 7010 Name_Size) 7011 and then Prefix (Parnt) = Child 7012 then 7013 return; 7014 7015 elsif Nkind (Parnt) = N_Assignment_Statement 7016 and then Name (Parnt) = Child 7017 then 7018 return; 7019 7020 -- If the expression is an index of an indexed component, it must 7021 -- be expanded regardless of context. 7022 7023 elsif Nkind (Parnt) = N_Indexed_Component 7024 and then Child /= Prefix (Parnt) 7025 then 7026 Expand_Packed_Element_Reference (N); 7027 return; 7028 7029 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement 7030 and then Name (Parent (Parnt)) = Parnt 7031 then 7032 return; 7033 7034 elsif Nkind (Parnt) = N_Attribute_Reference 7035 and then Attribute_Name (Parnt) = Name_Read 7036 and then Next (First (Expressions (Parnt))) = Child 7037 then 7038 return; 7039 7040 elsif Nkind (Parnt) = N_Indexed_Component 7041 and then Prefix (Parnt) = Child 7042 then 7043 null; 7044 7045 elsif Nkind (Parnt) = N_Selected_Component 7046 and then Prefix (Parnt) = Child 7047 and then not (Present (Etype (Selector_Name (Parnt))) 7048 and then 7049 Is_Access_Type (Etype (Selector_Name (Parnt)))) 7050 then 7051 null; 7052 7053 -- If the parent is a dereference, either implicit or explicit, 7054 -- then the packed reference needs to be expanded. 7055 7056 else 7057 Expand_Packed_Element_Reference (N); 7058 return; 7059 end if; 7060 7061 -- Keep looking up tree for unchecked expression, or if we are the 7062 -- prefix of a possible assignment left side. 7063 7064 Child := Parnt; 7065 Parnt := Parent (Child); 7066 end loop; 7067 end; 7068 end Expand_N_Indexed_Component; 7069 7070 --------------------- 7071 -- Expand_N_Not_In -- 7072 --------------------- 7073 7074 -- Replace a not in b by not (a in b) so that the expansions for (a in b) 7075 -- can be done. This avoids needing to duplicate this expansion code. 7076 7077 procedure Expand_N_Not_In (N : Node_Id) is 7078 Loc : constant Source_Ptr := Sloc (N); 7079 Typ : constant Entity_Id := Etype (N); 7080 Cfs : constant Boolean := Comes_From_Source (N); 7081 7082 begin 7083 Rewrite (N, 7084 Make_Op_Not (Loc, 7085 Right_Opnd => 7086 Make_In (Loc, 7087 Left_Opnd => Left_Opnd (N), 7088 Right_Opnd => Right_Opnd (N)))); 7089 7090 -- If this is a set membership, preserve list of alternatives 7091 7092 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); 7093 7094 -- We want this to appear as coming from source if original does (see 7095 -- transformations in Expand_N_In). 7096 7097 Set_Comes_From_Source (N, Cfs); 7098 Set_Comes_From_Source (Right_Opnd (N), Cfs); 7099 7100 -- Now analyze transformed node 7101 7102 Analyze_And_Resolve (N, Typ); 7103 end Expand_N_Not_In; 7104 7105 ------------------- 7106 -- Expand_N_Null -- 7107 ------------------- 7108 7109 -- The only replacement required is for the case of a null of a type that 7110 -- is an access to protected subprogram, or a subtype thereof. We represent 7111 -- such access values as a record, and so we must replace the occurrence of 7112 -- null by the equivalent record (with a null address and a null pointer in 7113 -- it), so that the back end creates the proper value. 7114 7115 procedure Expand_N_Null (N : Node_Id) is 7116 Loc : constant Source_Ptr := Sloc (N); 7117 Typ : constant Entity_Id := Base_Type (Etype (N)); 7118 Agg : Node_Id; 7119 7120 begin 7121 if Is_Access_Protected_Subprogram_Type (Typ) then 7122 Agg := 7123 Make_Aggregate (Loc, 7124 Expressions => New_List ( 7125 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 7126 Make_Null (Loc))); 7127 7128 Rewrite (N, Agg); 7129 Analyze_And_Resolve (N, Equivalent_Type (Typ)); 7130 7131 -- For subsequent semantic analysis, the node must retain its type. 7132 -- Gigi in any case replaces this type by the corresponding record 7133 -- type before processing the node. 7134 7135 Set_Etype (N, Typ); 7136 end if; 7137 7138 exception 7139 when RE_Not_Available => 7140 return; 7141 end Expand_N_Null; 7142 7143 --------------------- 7144 -- Expand_N_Op_Abs -- 7145 --------------------- 7146 7147 procedure Expand_N_Op_Abs (N : Node_Id) is 7148 Loc : constant Source_Ptr := Sloc (N); 7149 Expr : constant Node_Id := Right_Opnd (N); 7150 7151 begin 7152 Unary_Op_Validity_Checks (N); 7153 7154 -- Check for MINIMIZED/ELIMINATED overflow mode 7155 7156 if Minimized_Eliminated_Overflow_Check (N) then 7157 Apply_Arithmetic_Overflow_Check (N); 7158 return; 7159 end if; 7160 7161 -- Deal with software overflow checking 7162 7163 if Is_Signed_Integer_Type (Etype (N)) 7164 and then Do_Overflow_Check (N) 7165 then 7166 -- The only case to worry about is when the argument is equal to the 7167 -- largest negative number, so what we do is to insert the check: 7168 7169 -- [constraint_error when Expr = typ'Base'First] 7170 7171 -- with the usual Duplicate_Subexpr use coding for expr 7172 7173 Insert_Action (N, 7174 Make_Raise_Constraint_Error (Loc, 7175 Condition => 7176 Make_Op_Eq (Loc, 7177 Left_Opnd => Duplicate_Subexpr (Expr), 7178 Right_Opnd => 7179 Make_Attribute_Reference (Loc, 7180 Prefix => 7181 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), 7182 Attribute_Name => Name_First)), 7183 Reason => CE_Overflow_Check_Failed)); 7184 7185 Set_Do_Overflow_Check (N, False); 7186 end if; 7187 end Expand_N_Op_Abs; 7188 7189 --------------------- 7190 -- Expand_N_Op_Add -- 7191 --------------------- 7192 7193 procedure Expand_N_Op_Add (N : Node_Id) is 7194 Typ : constant Entity_Id := Etype (N); 7195 7196 begin 7197 Binary_Op_Validity_Checks (N); 7198 7199 -- Check for MINIMIZED/ELIMINATED overflow mode 7200 7201 if Minimized_Eliminated_Overflow_Check (N) then 7202 Apply_Arithmetic_Overflow_Check (N); 7203 return; 7204 end if; 7205 7206 -- N + 0 = 0 + N = N for integer types 7207 7208 if Is_Integer_Type (Typ) then 7209 if Compile_Time_Known_Value (Right_Opnd (N)) 7210 and then Expr_Value (Right_Opnd (N)) = Uint_0 7211 then 7212 Rewrite (N, Left_Opnd (N)); 7213 return; 7214 7215 elsif Compile_Time_Known_Value (Left_Opnd (N)) 7216 and then Expr_Value (Left_Opnd (N)) = Uint_0 7217 then 7218 Rewrite (N, Right_Opnd (N)); 7219 return; 7220 end if; 7221 end if; 7222 7223 -- Arithmetic overflow checks for signed integer/fixed point types 7224 7225 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then 7226 Apply_Arithmetic_Overflow_Check (N); 7227 return; 7228 end if; 7229 7230 -- Overflow checks for floating-point if -gnateF mode active 7231 7232 Check_Float_Op_Overflow (N); 7233 7234 Expand_Nonbinary_Modular_Op (N); 7235 end Expand_N_Op_Add; 7236 7237 --------------------- 7238 -- Expand_N_Op_And -- 7239 --------------------- 7240 7241 procedure Expand_N_Op_And (N : Node_Id) is 7242 Typ : constant Entity_Id := Etype (N); 7243 7244 begin 7245 Binary_Op_Validity_Checks (N); 7246 7247 if Is_Array_Type (Etype (N)) then 7248 Expand_Boolean_Operator (N); 7249 7250 elsif Is_Boolean_Type (Etype (N)) then 7251 Adjust_Condition (Left_Opnd (N)); 7252 Adjust_Condition (Right_Opnd (N)); 7253 Set_Etype (N, Standard_Boolean); 7254 Adjust_Result_Type (N, Typ); 7255 7256 elsif Is_Intrinsic_Subprogram (Entity (N)) then 7257 Expand_Intrinsic_Call (N, Entity (N)); 7258 end if; 7259 7260 Expand_Nonbinary_Modular_Op (N); 7261 end Expand_N_Op_And; 7262 7263 ------------------------ 7264 -- Expand_N_Op_Concat -- 7265 ------------------------ 7266 7267 procedure Expand_N_Op_Concat (N : Node_Id) is 7268 Opnds : List_Id; 7269 -- List of operands to be concatenated 7270 7271 Cnode : Node_Id; 7272 -- Node which is to be replaced by the result of concatenating the nodes 7273 -- in the list Opnds. 7274 7275 begin 7276 -- Ensure validity of both operands 7277 7278 Binary_Op_Validity_Checks (N); 7279 7280 -- If we are the left operand of a concatenation higher up the tree, 7281 -- then do nothing for now, since we want to deal with a series of 7282 -- concatenations as a unit. 7283 7284 if Nkind (Parent (N)) = N_Op_Concat 7285 and then N = Left_Opnd (Parent (N)) 7286 then 7287 return; 7288 end if; 7289 7290 -- We get here with a concatenation whose left operand may be a 7291 -- concatenation itself with a consistent type. We need to process 7292 -- these concatenation operands from left to right, which means 7293 -- from the deepest node in the tree to the highest node. 7294 7295 Cnode := N; 7296 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop 7297 Cnode := Left_Opnd (Cnode); 7298 end loop; 7299 7300 -- Now Cnode is the deepest concatenation, and its parents are the 7301 -- concatenation nodes above, so now we process bottom up, doing the 7302 -- operands. 7303 7304 -- The outer loop runs more than once if more than one concatenation 7305 -- type is involved. 7306 7307 Outer : loop 7308 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); 7309 Set_Parent (Opnds, N); 7310 7311 -- The inner loop gathers concatenation operands 7312 7313 Inner : while Cnode /= N 7314 and then Base_Type (Etype (Cnode)) = 7315 Base_Type (Etype (Parent (Cnode))) 7316 loop 7317 Cnode := Parent (Cnode); 7318 Append (Right_Opnd (Cnode), Opnds); 7319 end loop Inner; 7320 7321 -- Note: The following code is a temporary workaround for N731-034 7322 -- and N829-028 and will be kept until the general issue of internal 7323 -- symbol serialization is addressed. The workaround is kept under a 7324 -- debug switch to avoid permiating into the general case. 7325 7326 -- Wrap the node to concatenate into an expression actions node to 7327 -- keep it nicely packaged. This is useful in the case of an assert 7328 -- pragma with a concatenation where we want to be able to delete 7329 -- the concatenation and all its expansion stuff. 7330 7331 if Debug_Flag_Dot_H then 7332 declare 7333 Cnod : constant Node_Id := New_Copy_Tree (Cnode); 7334 Typ : constant Entity_Id := Base_Type (Etype (Cnode)); 7335 7336 begin 7337 -- Note: use Rewrite rather than Replace here, so that for 7338 -- example Why_Not_Static can find the original concatenation 7339 -- node OK! 7340 7341 Rewrite (Cnode, 7342 Make_Expression_With_Actions (Sloc (Cnode), 7343 Actions => New_List (Make_Null_Statement (Sloc (Cnode))), 7344 Expression => Cnod)); 7345 7346 Expand_Concatenate (Cnod, Opnds); 7347 Analyze_And_Resolve (Cnode, Typ); 7348 end; 7349 7350 -- Default case 7351 7352 else 7353 Expand_Concatenate (Cnode, Opnds); 7354 end if; 7355 7356 exit Outer when Cnode = N; 7357 Cnode := Parent (Cnode); 7358 end loop Outer; 7359 end Expand_N_Op_Concat; 7360 7361 ------------------------ 7362 -- Expand_N_Op_Divide -- 7363 ------------------------ 7364 7365 procedure Expand_N_Op_Divide (N : Node_Id) is 7366 Loc : constant Source_Ptr := Sloc (N); 7367 Lopnd : constant Node_Id := Left_Opnd (N); 7368 Ropnd : constant Node_Id := Right_Opnd (N); 7369 Ltyp : constant Entity_Id := Etype (Lopnd); 7370 Rtyp : constant Entity_Id := Etype (Ropnd); 7371 Typ : Entity_Id := Etype (N); 7372 Rknow : constant Boolean := Is_Integer_Type (Typ) 7373 and then 7374 Compile_Time_Known_Value (Ropnd); 7375 Rval : Uint; 7376 7377 begin 7378 Binary_Op_Validity_Checks (N); 7379 7380 -- Check for MINIMIZED/ELIMINATED overflow mode 7381 7382 if Minimized_Eliminated_Overflow_Check (N) then 7383 Apply_Arithmetic_Overflow_Check (N); 7384 return; 7385 end if; 7386 7387 -- Otherwise proceed with expansion of division 7388 7389 if Rknow then 7390 Rval := Expr_Value (Ropnd); 7391 end if; 7392 7393 -- N / 1 = N for integer types 7394 7395 if Rknow and then Rval = Uint_1 then 7396 Rewrite (N, Lopnd); 7397 return; 7398 end if; 7399 7400 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that 7401 -- Is_Power_Of_2_For_Shift is set means that we know that our left 7402 -- operand is an unsigned integer, as required for this to work. 7403 7404 if Nkind (Ropnd) = N_Op_Expon 7405 and then Is_Power_Of_2_For_Shift (Ropnd) 7406 7407 -- We cannot do this transformation in configurable run time mode if we 7408 -- have 64-bit integers and long shifts are not available. 7409 7410 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target) 7411 then 7412 Rewrite (N, 7413 Make_Op_Shift_Right (Loc, 7414 Left_Opnd => Lopnd, 7415 Right_Opnd => 7416 Convert_To (Standard_Natural, Right_Opnd (Ropnd)))); 7417 Analyze_And_Resolve (N, Typ); 7418 return; 7419 end if; 7420 7421 -- Do required fixup of universal fixed operation 7422 7423 if Typ = Universal_Fixed then 7424 Fixup_Universal_Fixed_Operation (N); 7425 Typ := Etype (N); 7426 end if; 7427 7428 -- Divisions with fixed-point results 7429 7430 if Is_Fixed_Point_Type (Typ) then 7431 7432 -- No special processing if Treat_Fixed_As_Integer is set, since 7433 -- from a semantic point of view such operations are simply integer 7434 -- operations and will be treated that way. 7435 7436 if not Treat_Fixed_As_Integer (N) then 7437 if Is_Integer_Type (Rtyp) then 7438 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); 7439 else 7440 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); 7441 end if; 7442 end if; 7443 7444 -- Deal with divide-by-zero check if back end cannot handle them 7445 -- and the flag is set indicating that we need such a check. Note 7446 -- that we don't need to bother here with the case of mixed-mode 7447 -- (Right operand an integer type), since these will be rewritten 7448 -- with conversions to a divide with a fixed-point right operand. 7449 7450 if Nkind (N) = N_Op_Divide 7451 and then Do_Division_Check (N) 7452 and then not Backend_Divide_Checks_On_Target 7453 and then not Is_Integer_Type (Rtyp) 7454 then 7455 Set_Do_Division_Check (N, False); 7456 Insert_Action (N, 7457 Make_Raise_Constraint_Error (Loc, 7458 Condition => 7459 Make_Op_Eq (Loc, 7460 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd), 7461 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 7462 Reason => CE_Divide_By_Zero)); 7463 end if; 7464 7465 -- Other cases of division of fixed-point operands. Again we exclude the 7466 -- case where Treat_Fixed_As_Integer is set. 7467 7468 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) 7469 and then not Treat_Fixed_As_Integer (N) 7470 then 7471 if Is_Integer_Type (Typ) then 7472 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); 7473 else 7474 pragma Assert (Is_Floating_Point_Type (Typ)); 7475 Expand_Divide_Fixed_By_Fixed_Giving_Float (N); 7476 end if; 7477 7478 -- Mixed-mode operations can appear in a non-static universal context, 7479 -- in which case the integer argument must be converted explicitly. 7480 7481 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then 7482 Rewrite (Ropnd, 7483 Convert_To (Universal_Real, Relocate_Node (Ropnd))); 7484 7485 Analyze_And_Resolve (Ropnd, Universal_Real); 7486 7487 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then 7488 Rewrite (Lopnd, 7489 Convert_To (Universal_Real, Relocate_Node (Lopnd))); 7490 7491 Analyze_And_Resolve (Lopnd, Universal_Real); 7492 7493 -- Non-fixed point cases, do integer zero divide and overflow checks 7494 7495 elsif Is_Integer_Type (Typ) then 7496 Apply_Divide_Checks (N); 7497 end if; 7498 7499 -- Overflow checks for floating-point if -gnateF mode active 7500 7501 Check_Float_Op_Overflow (N); 7502 7503 Expand_Nonbinary_Modular_Op (N); 7504 end Expand_N_Op_Divide; 7505 7506 -------------------- 7507 -- Expand_N_Op_Eq -- 7508 -------------------- 7509 7510 procedure Expand_N_Op_Eq (N : Node_Id) is 7511 Loc : constant Source_Ptr := Sloc (N); 7512 Typ : constant Entity_Id := Etype (N); 7513 Lhs : constant Node_Id := Left_Opnd (N); 7514 Rhs : constant Node_Id := Right_Opnd (N); 7515 Bodies : constant List_Id := New_List; 7516 A_Typ : constant Entity_Id := Etype (Lhs); 7517 7518 procedure Build_Equality_Call (Eq : Entity_Id); 7519 -- If a constructed equality exists for the type or for its parent, 7520 -- build and analyze call, adding conversions if the operation is 7521 -- inherited. 7522 7523 function Is_Equality (Subp : Entity_Id; 7524 Typ : Entity_Id := Empty) return Boolean; 7525 -- Determine whether arbitrary Entity_Id denotes a function with the 7526 -- right name and profile for an equality op, specifically for the 7527 -- base type Typ if Typ is nonempty. 7528 7529 function Find_Equality (Prims : Elist_Id) return Entity_Id; 7530 -- Find a primitive equality function within primitive operation list 7531 -- Prims. 7532 7533 function User_Defined_Primitive_Equality_Op 7534 (Typ : Entity_Id) return Entity_Id; 7535 -- Find a user-defined primitive equality function for a given untagged 7536 -- record type, ignoring visibility. Return Empty if no such op found. 7537 7538 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; 7539 -- Determines whether a type has a subcomponent of an unconstrained 7540 -- Unchecked_Union subtype. Typ is a record type. 7541 7542 ------------------------- 7543 -- Build_Equality_Call -- 7544 ------------------------- 7545 7546 procedure Build_Equality_Call (Eq : Entity_Id) is 7547 Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); 7548 L_Exp : Node_Id := Relocate_Node (Lhs); 7549 R_Exp : Node_Id := Relocate_Node (Rhs); 7550 7551 begin 7552 -- Adjust operands if necessary to comparison type 7553 7554 if Base_Type (Op_Type) /= Base_Type (A_Typ) 7555 and then not Is_Class_Wide_Type (A_Typ) 7556 then 7557 L_Exp := OK_Convert_To (Op_Type, L_Exp); 7558 R_Exp := OK_Convert_To (Op_Type, R_Exp); 7559 end if; 7560 7561 -- If we have an Unchecked_Union, we need to add the inferred 7562 -- discriminant values as actuals in the function call. At this 7563 -- point, the expansion has determined that both operands have 7564 -- inferable discriminants. 7565 7566 if Is_Unchecked_Union (Op_Type) then 7567 declare 7568 Lhs_Type : constant Node_Id := Etype (L_Exp); 7569 Rhs_Type : constant Node_Id := Etype (R_Exp); 7570 7571 Lhs_Discr_Vals : Elist_Id; 7572 -- List of inferred discriminant values for left operand. 7573 7574 Rhs_Discr_Vals : Elist_Id; 7575 -- List of inferred discriminant values for right operand. 7576 7577 Discr : Entity_Id; 7578 7579 begin 7580 Lhs_Discr_Vals := New_Elmt_List; 7581 Rhs_Discr_Vals := New_Elmt_List; 7582 7583 -- Per-object constrained selected components require special 7584 -- attention. If the enclosing scope of the component is an 7585 -- Unchecked_Union, we cannot reference its discriminants 7586 -- directly. This is why we use the extra parameters of the 7587 -- equality function of the enclosing Unchecked_Union. 7588 7589 -- type UU_Type (Discr : Integer := 0) is 7590 -- . . . 7591 -- end record; 7592 -- pragma Unchecked_Union (UU_Type); 7593 7594 -- 1. Unchecked_Union enclosing record: 7595 7596 -- type Enclosing_UU_Type (Discr : Integer := 0) is record 7597 -- . . . 7598 -- Comp : UU_Type (Discr); 7599 -- . . . 7600 -- end Enclosing_UU_Type; 7601 -- pragma Unchecked_Union (Enclosing_UU_Type); 7602 7603 -- Obj1 : Enclosing_UU_Type; 7604 -- Obj2 : Enclosing_UU_Type (1); 7605 7606 -- [. . .] Obj1 = Obj2 [. . .] 7607 7608 -- Generated code: 7609 7610 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then 7611 7612 -- A and B are the formal parameters of the equality function 7613 -- of Enclosing_UU_Type. The function always has two extra 7614 -- formals to capture the inferred discriminant values for 7615 -- each discriminant of the type. 7616 7617 -- 2. Non-Unchecked_Union enclosing record: 7618 7619 -- type 7620 -- Enclosing_Non_UU_Type (Discr : Integer := 0) 7621 -- is record 7622 -- . . . 7623 -- Comp : UU_Type (Discr); 7624 -- . . . 7625 -- end Enclosing_Non_UU_Type; 7626 7627 -- Obj1 : Enclosing_Non_UU_Type; 7628 -- Obj2 : Enclosing_Non_UU_Type (1); 7629 7630 -- ... Obj1 = Obj2 ... 7631 7632 -- Generated code: 7633 7634 -- if not (uu_typeEQ (obj1.comp, obj2.comp, 7635 -- obj1.discr, obj2.discr)) then 7636 7637 -- In this case we can directly reference the discriminants of 7638 -- the enclosing record. 7639 7640 -- Process left operand of equality 7641 7642 if Nkind (Lhs) = N_Selected_Component 7643 and then 7644 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs))) 7645 then 7646 -- If enclosing record is an Unchecked_Union, use formals 7647 -- corresponding to each discriminant. The name of the 7648 -- formal is that of the discriminant, with added suffix, 7649 -- see Exp_Ch3.Build_Record_Equality for details. 7650 7651 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs)))) 7652 then 7653 Discr := 7654 First_Discriminant 7655 (Scope (Entity (Selector_Name (Lhs)))); 7656 while Present (Discr) loop 7657 Append_Elmt 7658 (Make_Identifier (Loc, 7659 Chars => New_External_Name (Chars (Discr), 'A')), 7660 To => Lhs_Discr_Vals); 7661 Next_Discriminant (Discr); 7662 end loop; 7663 7664 -- If enclosing record is of a non-Unchecked_Union type, it 7665 -- is possible to reference its discriminants directly. 7666 7667 else 7668 Discr := First_Discriminant (Lhs_Type); 7669 while Present (Discr) loop 7670 Append_Elmt 7671 (Make_Selected_Component (Loc, 7672 Prefix => Prefix (Lhs), 7673 Selector_Name => 7674 New_Copy 7675 (Get_Discriminant_Value (Discr, 7676 Lhs_Type, 7677 Stored_Constraint (Lhs_Type)))), 7678 To => Lhs_Discr_Vals); 7679 Next_Discriminant (Discr); 7680 end loop; 7681 end if; 7682 7683 -- Otherwise operand is on object with a constrained type. 7684 -- Infer the discriminant values from the constraint. 7685 7686 else 7687 Discr := First_Discriminant (Lhs_Type); 7688 while Present (Discr) loop 7689 Append_Elmt 7690 (New_Copy 7691 (Get_Discriminant_Value (Discr, 7692 Lhs_Type, 7693 Stored_Constraint (Lhs_Type))), 7694 To => Lhs_Discr_Vals); 7695 Next_Discriminant (Discr); 7696 end loop; 7697 end if; 7698 7699 -- Similar processing for right operand of equality 7700 7701 if Nkind (Rhs) = N_Selected_Component 7702 and then 7703 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs))) 7704 then 7705 if Is_Unchecked_Union 7706 (Scope (Entity (Selector_Name (Rhs)))) 7707 then 7708 Discr := 7709 First_Discriminant 7710 (Scope (Entity (Selector_Name (Rhs)))); 7711 while Present (Discr) loop 7712 Append_Elmt 7713 (Make_Identifier (Loc, 7714 Chars => New_External_Name (Chars (Discr), 'B')), 7715 To => Rhs_Discr_Vals); 7716 Next_Discriminant (Discr); 7717 end loop; 7718 7719 else 7720 Discr := First_Discriminant (Rhs_Type); 7721 while Present (Discr) loop 7722 Append_Elmt 7723 (Make_Selected_Component (Loc, 7724 Prefix => Prefix (Rhs), 7725 Selector_Name => 7726 New_Copy (Get_Discriminant_Value 7727 (Discr, 7728 Rhs_Type, 7729 Stored_Constraint (Rhs_Type)))), 7730 To => Rhs_Discr_Vals); 7731 Next_Discriminant (Discr); 7732 end loop; 7733 end if; 7734 7735 else 7736 Discr := First_Discriminant (Rhs_Type); 7737 while Present (Discr) loop 7738 Append_Elmt 7739 (New_Copy (Get_Discriminant_Value 7740 (Discr, 7741 Rhs_Type, 7742 Stored_Constraint (Rhs_Type))), 7743 To => Rhs_Discr_Vals); 7744 Next_Discriminant (Discr); 7745 end loop; 7746 end if; 7747 7748 -- Now merge the list of discriminant values so that values 7749 -- of corresponding discriminants are adjacent. 7750 7751 declare 7752 Params : List_Id; 7753 L_Elmt : Elmt_Id; 7754 R_Elmt : Elmt_Id; 7755 7756 begin 7757 Params := New_List (L_Exp, R_Exp); 7758 L_Elmt := First_Elmt (Lhs_Discr_Vals); 7759 R_Elmt := First_Elmt (Rhs_Discr_Vals); 7760 while Present (L_Elmt) loop 7761 Append_To (Params, Node (L_Elmt)); 7762 Append_To (Params, Node (R_Elmt)); 7763 Next_Elmt (L_Elmt); 7764 Next_Elmt (R_Elmt); 7765 end loop; 7766 7767 Rewrite (N, 7768 Make_Function_Call (Loc, 7769 Name => New_Occurrence_Of (Eq, Loc), 7770 Parameter_Associations => Params)); 7771 end; 7772 end; 7773 7774 -- Normal case, not an unchecked union 7775 7776 else 7777 Rewrite (N, 7778 Make_Function_Call (Loc, 7779 Name => New_Occurrence_Of (Eq, Loc), 7780 Parameter_Associations => New_List (L_Exp, R_Exp))); 7781 end if; 7782 7783 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7784 end Build_Equality_Call; 7785 7786 ----------------- 7787 -- Is_Equality -- 7788 ----------------- 7789 7790 function Is_Equality (Subp : Entity_Id; 7791 Typ : Entity_Id := Empty) return Boolean is 7792 Formal_1 : Entity_Id; 7793 Formal_2 : Entity_Id; 7794 begin 7795 -- The equality function carries name "=", returns Boolean, and has 7796 -- exactly two formal parameters of an identical type. 7797 7798 if Ekind (Subp) = E_Function 7799 and then Chars (Subp) = Name_Op_Eq 7800 and then Base_Type (Etype (Subp)) = Standard_Boolean 7801 then 7802 Formal_1 := First_Formal (Subp); 7803 Formal_2 := Empty; 7804 7805 if Present (Formal_1) then 7806 Formal_2 := Next_Formal (Formal_1); 7807 end if; 7808 7809 return 7810 Present (Formal_1) 7811 and then Present (Formal_2) 7812 and then No (Next_Formal (Formal_2)) 7813 and then Base_Type (Etype (Formal_1)) = 7814 Base_Type (Etype (Formal_2)) 7815 and then 7816 (not Present (Typ) 7817 or else Implementation_Base_Type (Etype (Formal_1)) = Typ); 7818 end if; 7819 7820 return False; 7821 end Is_Equality; 7822 7823 ------------------- 7824 -- Find_Equality -- 7825 ------------------- 7826 7827 function Find_Equality (Prims : Elist_Id) return Entity_Id is 7828 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id; 7829 -- Find an equality in a possible alias chain starting from primitive 7830 -- operation Prim. 7831 7832 --------------------------- 7833 -- Find_Aliased_Equality -- 7834 --------------------------- 7835 7836 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is 7837 Candid : Entity_Id; 7838 7839 begin 7840 -- Inspect each candidate in the alias chain, checking whether it 7841 -- denotes an equality. 7842 7843 Candid := Prim; 7844 while Present (Candid) loop 7845 if Is_Equality (Candid) then 7846 return Candid; 7847 end if; 7848 7849 Candid := Alias (Candid); 7850 end loop; 7851 7852 return Empty; 7853 end Find_Aliased_Equality; 7854 7855 -- Local variables 7856 7857 Eq_Prim : Entity_Id; 7858 Prim_Elmt : Elmt_Id; 7859 7860 -- Start of processing for Find_Equality 7861 7862 begin 7863 -- Assume that the tagged type lacks an equality 7864 7865 Eq_Prim := Empty; 7866 7867 -- Inspect the list of primitives looking for a suitable equality 7868 -- within a possible chain of aliases. 7869 7870 Prim_Elmt := First_Elmt (Prims); 7871 while Present (Prim_Elmt) and then No (Eq_Prim) loop 7872 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt)); 7873 7874 Next_Elmt (Prim_Elmt); 7875 end loop; 7876 7877 -- A tagged type should always have an equality 7878 7879 pragma Assert (Present (Eq_Prim)); 7880 7881 return Eq_Prim; 7882 end Find_Equality; 7883 7884 ---------------------------------------- 7885 -- User_Defined_Primitive_Equality_Op -- 7886 ---------------------------------------- 7887 7888 function User_Defined_Primitive_Equality_Op 7889 (Typ : Entity_Id) return Entity_Id 7890 is 7891 Enclosing_Scope : constant Node_Id := Scope (Typ); 7892 E : Entity_Id; 7893 begin 7894 -- Prune this search by somehow not looking at decls that precede 7895 -- the declaration of the first view of Typ (which might be a partial 7896 -- view)??? 7897 7898 for Private_Entities in Boolean loop 7899 if Private_Entities then 7900 if Ekind (Enclosing_Scope) /= E_Package then 7901 exit; 7902 end if; 7903 E := First_Private_Entity (Enclosing_Scope); 7904 7905 else 7906 E := First_Entity (Enclosing_Scope); 7907 end if; 7908 7909 while Present (E) loop 7910 if Is_Equality (E, Typ) then 7911 return E; 7912 end if; 7913 E := Next_Entity (E); 7914 end loop; 7915 end loop; 7916 7917 if Is_Derived_Type (Typ) then 7918 return User_Defined_Primitive_Equality_Op 7919 (Implementation_Base_Type (Etype (Typ))); 7920 end if; 7921 7922 return Empty; 7923 end User_Defined_Primitive_Equality_Op; 7924 7925 ------------------------------------ 7926 -- Has_Unconstrained_UU_Component -- 7927 ------------------------------------ 7928 7929 function Has_Unconstrained_UU_Component 7930 (Typ : Entity_Id) return Boolean 7931 is 7932 Tdef : constant Node_Id := 7933 Type_Definition (Declaration_Node (Base_Type (Typ))); 7934 Clist : Node_Id; 7935 Vpart : Node_Id; 7936 7937 function Component_Is_Unconstrained_UU 7938 (Comp : Node_Id) return Boolean; 7939 -- Determines whether the subtype of the component is an 7940 -- unconstrained Unchecked_Union. 7941 7942 function Variant_Is_Unconstrained_UU 7943 (Variant : Node_Id) return Boolean; 7944 -- Determines whether a component of the variant has an unconstrained 7945 -- Unchecked_Union subtype. 7946 7947 ----------------------------------- 7948 -- Component_Is_Unconstrained_UU -- 7949 ----------------------------------- 7950 7951 function Component_Is_Unconstrained_UU 7952 (Comp : Node_Id) return Boolean 7953 is 7954 begin 7955 if Nkind (Comp) /= N_Component_Declaration then 7956 return False; 7957 end if; 7958 7959 declare 7960 Sindic : constant Node_Id := 7961 Subtype_Indication (Component_Definition (Comp)); 7962 7963 begin 7964 -- Unconstrained nominal type. In the case of a constraint 7965 -- present, the node kind would have been N_Subtype_Indication. 7966 7967 if Nkind (Sindic) = N_Identifier then 7968 return Is_Unchecked_Union (Base_Type (Etype (Sindic))); 7969 end if; 7970 7971 return False; 7972 end; 7973 end Component_Is_Unconstrained_UU; 7974 7975 --------------------------------- 7976 -- Variant_Is_Unconstrained_UU -- 7977 --------------------------------- 7978 7979 function Variant_Is_Unconstrained_UU 7980 (Variant : Node_Id) return Boolean 7981 is 7982 Clist : constant Node_Id := Component_List (Variant); 7983 7984 begin 7985 if Is_Empty_List (Component_Items (Clist)) then 7986 return False; 7987 end if; 7988 7989 -- We only need to test one component 7990 7991 declare 7992 Comp : Node_Id := First (Component_Items (Clist)); 7993 7994 begin 7995 while Present (Comp) loop 7996 if Component_Is_Unconstrained_UU (Comp) then 7997 return True; 7998 end if; 7999 8000 Next (Comp); 8001 end loop; 8002 end; 8003 8004 -- None of the components withing the variant were of 8005 -- unconstrained Unchecked_Union type. 8006 8007 return False; 8008 end Variant_Is_Unconstrained_UU; 8009 8010 -- Start of processing for Has_Unconstrained_UU_Component 8011 8012 begin 8013 if Null_Present (Tdef) then 8014 return False; 8015 end if; 8016 8017 Clist := Component_List (Tdef); 8018 Vpart := Variant_Part (Clist); 8019 8020 -- Inspect available components 8021 8022 if Present (Component_Items (Clist)) then 8023 declare 8024 Comp : Node_Id := First (Component_Items (Clist)); 8025 8026 begin 8027 while Present (Comp) loop 8028 8029 -- One component is sufficient 8030 8031 if Component_Is_Unconstrained_UU (Comp) then 8032 return True; 8033 end if; 8034 8035 Next (Comp); 8036 end loop; 8037 end; 8038 end if; 8039 8040 -- Inspect available components withing variants 8041 8042 if Present (Vpart) then 8043 declare 8044 Variant : Node_Id := First (Variants (Vpart)); 8045 8046 begin 8047 while Present (Variant) loop 8048 8049 -- One component within a variant is sufficient 8050 8051 if Variant_Is_Unconstrained_UU (Variant) then 8052 return True; 8053 end if; 8054 8055 Next (Variant); 8056 end loop; 8057 end; 8058 end if; 8059 8060 -- Neither the available components, nor the components inside the 8061 -- variant parts were of an unconstrained Unchecked_Union subtype. 8062 8063 return False; 8064 end Has_Unconstrained_UU_Component; 8065 8066 -- Local variables 8067 8068 Typl : Entity_Id; 8069 8070 -- Start of processing for Expand_N_Op_Eq 8071 8072 begin 8073 Binary_Op_Validity_Checks (N); 8074 8075 -- Deal with private types 8076 8077 Typl := A_Typ; 8078 8079 if Ekind (Typl) = E_Private_Type then 8080 Typl := Underlying_Type (Typl); 8081 8082 elsif Ekind (Typl) = E_Private_Subtype then 8083 Typl := Underlying_Type (Base_Type (Typl)); 8084 end if; 8085 8086 -- It may happen in error situations that the underlying type is not 8087 -- set. The error will be detected later, here we just defend the 8088 -- expander code. 8089 8090 if No (Typl) then 8091 return; 8092 end if; 8093 8094 -- Now get the implementation base type (note that plain Base_Type here 8095 -- might lead us back to the private type, which is not what we want!) 8096 8097 Typl := Implementation_Base_Type (Typl); 8098 8099 -- Equality between variant records results in a call to a routine 8100 -- that has conditional tests of the discriminant value(s), and hence 8101 -- violates the No_Implicit_Conditionals restriction. 8102 8103 if Has_Variant_Part (Typl) then 8104 declare 8105 Msg : Boolean; 8106 8107 begin 8108 Check_Restriction (Msg, No_Implicit_Conditionals, N); 8109 8110 if Msg then 8111 Error_Msg_N 8112 ("\comparison of variant records tests discriminants", N); 8113 return; 8114 end if; 8115 end; 8116 end if; 8117 8118 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8119 -- means we no longer have a comparison operation, we are all done. 8120 8121 Expand_Compare_Minimize_Eliminate_Overflow (N); 8122 8123 if Nkind (N) /= N_Op_Eq then 8124 return; 8125 end if; 8126 8127 -- Boolean types (requiring handling of non-standard case) 8128 8129 if Is_Boolean_Type (Typl) then 8130 Adjust_Condition (Left_Opnd (N)); 8131 Adjust_Condition (Right_Opnd (N)); 8132 Set_Etype (N, Standard_Boolean); 8133 Adjust_Result_Type (N, Typ); 8134 8135 -- Array types 8136 8137 elsif Is_Array_Type (Typl) then 8138 8139 -- If we are doing full validity checking, and it is possible for the 8140 -- array elements to be invalid then expand out array comparisons to 8141 -- make sure that we check the array elements. 8142 8143 if Validity_Check_Operands 8144 and then not Is_Known_Valid (Component_Type (Typl)) 8145 then 8146 declare 8147 Save_Force_Validity_Checks : constant Boolean := 8148 Force_Validity_Checks; 8149 begin 8150 Force_Validity_Checks := True; 8151 Rewrite (N, 8152 Expand_Array_Equality 8153 (N, 8154 Relocate_Node (Lhs), 8155 Relocate_Node (Rhs), 8156 Bodies, 8157 Typl)); 8158 Insert_Actions (N, Bodies); 8159 Analyze_And_Resolve (N, Standard_Boolean); 8160 Force_Validity_Checks := Save_Force_Validity_Checks; 8161 end; 8162 8163 -- Packed case where both operands are known aligned 8164 8165 elsif Is_Bit_Packed_Array (Typl) 8166 and then not Is_Possibly_Unaligned_Object (Lhs) 8167 and then not Is_Possibly_Unaligned_Object (Rhs) 8168 then 8169 Expand_Packed_Eq (N); 8170 8171 -- Where the component type is elementary we can use a block bit 8172 -- comparison (if supported on the target) exception in the case 8173 -- of floating-point (negative zero issues require element by 8174 -- element comparison), and atomic/VFA types (where we must be sure 8175 -- to load elements independently) and possibly unaligned arrays. 8176 8177 elsif Is_Elementary_Type (Component_Type (Typl)) 8178 and then not Is_Floating_Point_Type (Component_Type (Typl)) 8179 and then not Is_Atomic_Or_VFA (Component_Type (Typl)) 8180 and then not Is_Possibly_Unaligned_Object (Lhs) 8181 and then not Is_Possibly_Unaligned_Slice (Lhs) 8182 and then not Is_Possibly_Unaligned_Object (Rhs) 8183 and then not Is_Possibly_Unaligned_Slice (Rhs) 8184 and then Support_Composite_Compare_On_Target 8185 then 8186 null; 8187 8188 -- For composite and floating-point cases, expand equality loop to 8189 -- make sure of using proper comparisons for tagged types, and 8190 -- correctly handling the floating-point case. 8191 8192 else 8193 Rewrite (N, 8194 Expand_Array_Equality 8195 (N, 8196 Relocate_Node (Lhs), 8197 Relocate_Node (Rhs), 8198 Bodies, 8199 Typl)); 8200 Insert_Actions (N, Bodies, Suppress => All_Checks); 8201 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8202 end if; 8203 8204 -- Record Types 8205 8206 elsif Is_Record_Type (Typl) then 8207 8208 -- For tagged types, use the primitive "=" 8209 8210 if Is_Tagged_Type (Typl) then 8211 8212 -- No need to do anything else compiling under restriction 8213 -- No_Dispatching_Calls. During the semantic analysis we 8214 -- already notified such violation. 8215 8216 if Restriction_Active (No_Dispatching_Calls) then 8217 return; 8218 end if; 8219 8220 -- If this is an untagged private type completed with a derivation 8221 -- of an untagged private type whose full view is a tagged type, 8222 -- we use the primitive operations of the private type (since it 8223 -- does not have a full view, and also because its equality 8224 -- primitive may have been overridden in its untagged full view). 8225 8226 if Inherits_From_Tagged_Full_View (A_Typ) then 8227 Build_Equality_Call 8228 (Find_Equality (Collect_Primitive_Operations (A_Typ))); 8229 8230 -- Find the type's predefined equality or an overriding 8231 -- user-defined equality. The reason for not simply calling 8232 -- Find_Prim_Op here is that there may be a user-defined 8233 -- overloaded equality op that precedes the equality that we 8234 -- want, so we have to explicitly search (e.g., there could be 8235 -- an equality with two different parameter types). 8236 8237 else 8238 if Is_Class_Wide_Type (Typl) then 8239 Typl := Find_Specific_Type (Typl); 8240 end if; 8241 8242 Build_Equality_Call 8243 (Find_Equality (Primitive_Operations (Typl))); 8244 end if; 8245 8246 -- See AI12-0101 (which only removes a legality rule) and then 8247 -- AI05-0123 (which then applies in the previously illegal case). 8248 -- AI12-0101 is a binding interpretation. 8249 8250 elsif Ada_Version >= Ada_2012 8251 and then Present (User_Defined_Primitive_Equality_Op (Typl)) 8252 then 8253 Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl)); 8254 8255 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the 8256 -- predefined equality operator for a type which has a subcomponent 8257 -- of an Unchecked_Union type whose nominal subtype is unconstrained. 8258 8259 elsif Has_Unconstrained_UU_Component (Typl) then 8260 Insert_Action (N, 8261 Make_Raise_Program_Error (Loc, 8262 Reason => PE_Unchecked_Union_Restriction)); 8263 8264 -- Prevent Gigi from generating incorrect code by rewriting the 8265 -- equality as a standard False. (is this documented somewhere???) 8266 8267 Rewrite (N, 8268 New_Occurrence_Of (Standard_False, Loc)); 8269 8270 elsif Is_Unchecked_Union (Typl) then 8271 8272 -- If we can infer the discriminants of the operands, we make a 8273 -- call to the TSS equality function. 8274 8275 if Has_Inferable_Discriminants (Lhs) 8276 and then 8277 Has_Inferable_Discriminants (Rhs) 8278 then 8279 Build_Equality_Call 8280 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 8281 8282 else 8283 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 8284 -- the predefined equality operator for an Unchecked_Union type 8285 -- if either of the operands lack inferable discriminants. 8286 8287 Insert_Action (N, 8288 Make_Raise_Program_Error (Loc, 8289 Reason => PE_Unchecked_Union_Restriction)); 8290 8291 -- Emit a warning on source equalities only, otherwise the 8292 -- message may appear out of place due to internal use. The 8293 -- warning is unconditional because it is required by the 8294 -- language. 8295 8296 if Comes_From_Source (N) then 8297 Error_Msg_N 8298 ("Unchecked_Union discriminants cannot be determined??", 8299 N); 8300 Error_Msg_N 8301 ("\Program_Error will be raised for equality operation??", 8302 N); 8303 end if; 8304 8305 -- Prevent Gigi from generating incorrect code by rewriting 8306 -- the equality as a standard False (documented where???). 8307 8308 Rewrite (N, 8309 New_Occurrence_Of (Standard_False, Loc)); 8310 end if; 8311 8312 -- If a type support function is present (for complex cases), use it 8313 8314 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then 8315 Build_Equality_Call 8316 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 8317 8318 -- When comparing two Bounded_Strings, use the primitive equality of 8319 -- the root Super_String type. 8320 8321 elsif Is_Bounded_String (Typl) then 8322 Build_Equality_Call 8323 (Find_Equality 8324 (Collect_Primitive_Operations (Root_Type (Typl)))); 8325 8326 -- Otherwise expand the component by component equality. Note that 8327 -- we never use block-bit comparisons for records, because of the 8328 -- problems with gaps. The back end will often be able to recombine 8329 -- the separate comparisons that we generate here. 8330 8331 else 8332 Remove_Side_Effects (Lhs); 8333 Remove_Side_Effects (Rhs); 8334 Rewrite (N, 8335 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); 8336 8337 Insert_Actions (N, Bodies, Suppress => All_Checks); 8338 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8339 end if; 8340 8341 -- If unnesting, handle elementary types whose Equivalent_Types are 8342 -- records because there may be padding or undefined fields. 8343 8344 elsif Unnest_Subprogram_Mode 8345 and then Ekind_In (Typl, E_Class_Wide_Type, 8346 E_Class_Wide_Subtype, 8347 E_Access_Subprogram_Type, 8348 E_Access_Protected_Subprogram_Type, 8349 E_Anonymous_Access_Protected_Subprogram_Type, 8350 E_Access_Subprogram_Type, 8351 E_Exception_Type) 8352 and then Present (Equivalent_Type (Typl)) 8353 and then Is_Record_Type (Equivalent_Type (Typl)) 8354 then 8355 Typl := Equivalent_Type (Typl); 8356 Remove_Side_Effects (Lhs); 8357 Remove_Side_Effects (Rhs); 8358 Rewrite (N, 8359 Expand_Record_Equality (N, Typl, 8360 Unchecked_Convert_To (Typl, Lhs), 8361 Unchecked_Convert_To (Typl, Rhs), 8362 Bodies)); 8363 8364 Insert_Actions (N, Bodies, Suppress => All_Checks); 8365 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8366 end if; 8367 8368 -- Test if result is known at compile time 8369 8370 Rewrite_Comparison (N); 8371 8372 -- Special optimization of length comparison 8373 8374 Optimize_Length_Comparison (N); 8375 8376 -- One more special case: if we have a comparison of X'Result = expr 8377 -- in floating-point, then if not already there, change expr to be 8378 -- f'Machine (expr) to eliminate surprise from extra precision. 8379 8380 if Is_Floating_Point_Type (Typl) 8381 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference 8382 and then Attribute_Name (Original_Node (Lhs)) = Name_Result 8383 then 8384 -- Stick in the Typ'Machine call if not already there 8385 8386 if Nkind (Rhs) /= N_Attribute_Reference 8387 or else Attribute_Name (Rhs) /= Name_Machine 8388 then 8389 Rewrite (Rhs, 8390 Make_Attribute_Reference (Loc, 8391 Prefix => New_Occurrence_Of (Typl, Loc), 8392 Attribute_Name => Name_Machine, 8393 Expressions => New_List (Relocate_Node (Rhs)))); 8394 Analyze_And_Resolve (Rhs, Typl); 8395 end if; 8396 end if; 8397 end Expand_N_Op_Eq; 8398 8399 ----------------------- 8400 -- Expand_N_Op_Expon -- 8401 ----------------------- 8402 8403 procedure Expand_N_Op_Expon (N : Node_Id) is 8404 Loc : constant Source_Ptr := Sloc (N); 8405 Ovflo : constant Boolean := Do_Overflow_Check (N); 8406 Typ : constant Entity_Id := Etype (N); 8407 Rtyp : constant Entity_Id := Root_Type (Typ); 8408 8409 Bastyp : Entity_Id; 8410 8411 function Wrap_MA (Exp : Node_Id) return Node_Id; 8412 -- Given an expression Exp, if the root type is Float or Long_Float, 8413 -- then wrap the expression in a call of Bastyp'Machine, to stop any 8414 -- extra precision. This is done to ensure that X**A = X**B when A is 8415 -- a static constant and B is a variable with the same value. For any 8416 -- other type, the node Exp is returned unchanged. 8417 8418 ------------- 8419 -- Wrap_MA -- 8420 ------------- 8421 8422 function Wrap_MA (Exp : Node_Id) return Node_Id is 8423 Loc : constant Source_Ptr := Sloc (Exp); 8424 8425 begin 8426 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then 8427 return 8428 Make_Attribute_Reference (Loc, 8429 Attribute_Name => Name_Machine, 8430 Prefix => New_Occurrence_Of (Bastyp, Loc), 8431 Expressions => New_List (Relocate_Node (Exp))); 8432 else 8433 return Exp; 8434 end if; 8435 end Wrap_MA; 8436 8437 -- Local variables 8438 8439 Base : Node_Id; 8440 Ent : Entity_Id; 8441 Etyp : Entity_Id; 8442 Exp : Node_Id; 8443 Exptyp : Entity_Id; 8444 Expv : Uint; 8445 Rent : RE_Id; 8446 Temp : Node_Id; 8447 Xnode : Node_Id; 8448 8449 -- Start of processing for Expand_N_Op_Expon 8450 8451 begin 8452 Binary_Op_Validity_Checks (N); 8453 8454 -- CodePeer wants to see the unexpanded N_Op_Expon node 8455 8456 if CodePeer_Mode then 8457 return; 8458 end if; 8459 8460 -- Relocation of left and right operands must be done after performing 8461 -- the validity checks since the generation of validation checks may 8462 -- remove side effects. 8463 8464 Base := Relocate_Node (Left_Opnd (N)); 8465 Bastyp := Etype (Base); 8466 Exp := Relocate_Node (Right_Opnd (N)); 8467 Exptyp := Etype (Exp); 8468 8469 -- If either operand is of a private type, then we have the use of an 8470 -- intrinsic operator, and we get rid of the privateness, by using root 8471 -- types of underlying types for the actual operation. Otherwise the 8472 -- private types will cause trouble if we expand multiplications or 8473 -- shifts etc. We also do this transformation if the result type is 8474 -- different from the base type. 8475 8476 if Is_Private_Type (Etype (Base)) 8477 or else Is_Private_Type (Typ) 8478 or else Is_Private_Type (Exptyp) 8479 or else Rtyp /= Root_Type (Bastyp) 8480 then 8481 declare 8482 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); 8483 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); 8484 begin 8485 Rewrite (N, 8486 Unchecked_Convert_To (Typ, 8487 Make_Op_Expon (Loc, 8488 Left_Opnd => Unchecked_Convert_To (Bt, Base), 8489 Right_Opnd => Unchecked_Convert_To (Et, Exp)))); 8490 Analyze_And_Resolve (N, Typ); 8491 return; 8492 end; 8493 end if; 8494 8495 -- Check for MINIMIZED/ELIMINATED overflow mode 8496 8497 if Minimized_Eliminated_Overflow_Check (N) then 8498 Apply_Arithmetic_Overflow_Check (N); 8499 return; 8500 end if; 8501 8502 -- Test for case of known right argument where we can replace the 8503 -- exponentiation by an equivalent expression using multiplication. 8504 8505 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in 8506 -- configurable run-time mode, we may not have the exponentiation 8507 -- routine available, and we don't want the legality of the program 8508 -- to depend on how clever the compiler is in knowing values. 8509 8510 if CRT_Safe_Compile_Time_Known_Value (Exp) then 8511 Expv := Expr_Value (Exp); 8512 8513 -- We only fold small non-negative exponents. You might think we 8514 -- could fold small negative exponents for the real case, but we 8515 -- can't because we are required to raise Constraint_Error for 8516 -- the case of 0.0 ** (negative) even if Machine_Overflows = False. 8517 -- See ACVC test C4A012B, and it is not worth generating the test. 8518 8519 -- For small negative exponents, we return the reciprocal of 8520 -- the folding of the exponentiation for the opposite (positive) 8521 -- exponent, as required by Ada RM 4.5.6(11/3). 8522 8523 if abs Expv <= 4 then 8524 8525 -- X ** 0 = 1 (or 1.0) 8526 8527 if Expv = 0 then 8528 8529 -- Call Remove_Side_Effects to ensure that any side effects 8530 -- in the ignored left operand (in particular function calls 8531 -- to user defined functions) are properly executed. 8532 8533 Remove_Side_Effects (Base); 8534 8535 if Ekind (Typ) in Integer_Kind then 8536 Xnode := Make_Integer_Literal (Loc, Intval => 1); 8537 else 8538 Xnode := Make_Real_Literal (Loc, Ureal_1); 8539 end if; 8540 8541 -- X ** 1 = X 8542 8543 elsif Expv = 1 then 8544 Xnode := Base; 8545 8546 -- X ** 2 = X * X 8547 8548 elsif Expv = 2 then 8549 Xnode := 8550 Wrap_MA ( 8551 Make_Op_Multiply (Loc, 8552 Left_Opnd => Duplicate_Subexpr (Base), 8553 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))); 8554 8555 -- X ** 3 = X * X * X 8556 8557 elsif Expv = 3 then 8558 Xnode := 8559 Wrap_MA ( 8560 Make_Op_Multiply (Loc, 8561 Left_Opnd => 8562 Make_Op_Multiply (Loc, 8563 Left_Opnd => Duplicate_Subexpr (Base), 8564 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)), 8565 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))); 8566 8567 -- X ** 4 -> 8568 8569 -- do 8570 -- En : constant base'type := base * base; 8571 -- in 8572 -- En * En 8573 8574 elsif Expv = 4 then 8575 Temp := Make_Temporary (Loc, 'E', Base); 8576 8577 Xnode := 8578 Make_Expression_With_Actions (Loc, 8579 Actions => New_List ( 8580 Make_Object_Declaration (Loc, 8581 Defining_Identifier => Temp, 8582 Constant_Present => True, 8583 Object_Definition => New_Occurrence_Of (Typ, Loc), 8584 Expression => 8585 Wrap_MA ( 8586 Make_Op_Multiply (Loc, 8587 Left_Opnd => 8588 Duplicate_Subexpr (Base), 8589 Right_Opnd => 8590 Duplicate_Subexpr_No_Checks (Base))))), 8591 8592 Expression => 8593 Wrap_MA ( 8594 Make_Op_Multiply (Loc, 8595 Left_Opnd => New_Occurrence_Of (Temp, Loc), 8596 Right_Opnd => New_Occurrence_Of (Temp, Loc)))); 8597 8598 -- X ** N = 1.0 / X ** (-N) 8599 -- N in -4 .. -1 8600 8601 else 8602 pragma Assert 8603 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4); 8604 8605 Xnode := 8606 Make_Op_Divide (Loc, 8607 Left_Opnd => 8608 Make_Float_Literal (Loc, 8609 Radix => Uint_1, 8610 Significand => Uint_1, 8611 Exponent => Uint_0), 8612 Right_Opnd => 8613 Make_Op_Expon (Loc, 8614 Left_Opnd => Duplicate_Subexpr (Base), 8615 Right_Opnd => 8616 Make_Integer_Literal (Loc, 8617 Intval => -Expv))); 8618 end if; 8619 8620 Rewrite (N, Xnode); 8621 Analyze_And_Resolve (N, Typ); 8622 return; 8623 end if; 8624 end if; 8625 8626 -- Deal with optimizing 2 ** expression to shift where possible 8627 8628 -- Note: we used to check that Exptyp was an unsigned type. But that is 8629 -- an unnecessary check, since if Exp is negative, we have a run-time 8630 -- error that is either caught (so we get the right result) or we have 8631 -- suppressed the check, in which case the code is erroneous anyway. 8632 8633 if Is_Integer_Type (Rtyp) 8634 8635 -- The base value must be "safe compile-time known", and exactly 2 8636 8637 and then Nkind (Base) = N_Integer_Literal 8638 and then CRT_Safe_Compile_Time_Known_Value (Base) 8639 and then Expr_Value (Base) = Uint_2 8640 8641 -- We only handle cases where the right type is a integer 8642 8643 and then Is_Integer_Type (Root_Type (Exptyp)) 8644 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) 8645 8646 -- This transformation is not applicable for a modular type with a 8647 -- nonbinary modulus because we do not handle modular reduction in 8648 -- a correct manner if we attempt this transformation in this case. 8649 8650 and then not Non_Binary_Modulus (Typ) 8651 then 8652 -- Handle the cases where our parent is a division or multiplication 8653 -- specially. In these cases we can convert to using a shift at the 8654 -- parent level if we are not doing overflow checking, since it is 8655 -- too tricky to combine the overflow check at the parent level. 8656 8657 if not Ovflo 8658 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) 8659 then 8660 declare 8661 P : constant Node_Id := Parent (N); 8662 L : constant Node_Id := Left_Opnd (P); 8663 R : constant Node_Id := Right_Opnd (P); 8664 8665 begin 8666 if (Nkind (P) = N_Op_Multiply 8667 and then 8668 ((Is_Integer_Type (Etype (L)) and then R = N) 8669 or else 8670 (Is_Integer_Type (Etype (R)) and then L = N)) 8671 and then not Do_Overflow_Check (P)) 8672 8673 or else 8674 (Nkind (P) = N_Op_Divide 8675 and then Is_Integer_Type (Etype (L)) 8676 and then Is_Unsigned_Type (Etype (L)) 8677 and then R = N 8678 and then not Do_Overflow_Check (P)) 8679 then 8680 Set_Is_Power_Of_2_For_Shift (N); 8681 return; 8682 end if; 8683 end; 8684 8685 -- Here we just have 2 ** N on its own, so we can convert this to a 8686 -- shift node. We are prepared to deal with overflow here, and we 8687 -- also have to handle proper modular reduction for binary modular. 8688 8689 else 8690 declare 8691 OK : Boolean; 8692 Lo : Uint; 8693 Hi : Uint; 8694 8695 MaxS : Uint; 8696 -- Maximum shift count with no overflow 8697 8698 TestS : Boolean; 8699 -- Set True if we must test the shift count 8700 8701 Test_Gt : Node_Id; 8702 -- Node for test against TestS 8703 8704 begin 8705 -- Compute maximum shift based on the underlying size. For a 8706 -- modular type this is one less than the size. 8707 8708 if Is_Modular_Integer_Type (Typ) then 8709 8710 -- For modular integer types, this is the size of the value 8711 -- being shifted minus one. Any larger values will cause 8712 -- modular reduction to a result of zero. Note that we do 8713 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result 8714 -- of 6, since 2**7 should be reduced to zero). 8715 8716 MaxS := RM_Size (Rtyp) - 1; 8717 8718 -- For signed integer types, we use the size of the value 8719 -- being shifted minus 2. Larger values cause overflow. 8720 8721 else 8722 MaxS := Esize (Rtyp) - 2; 8723 end if; 8724 8725 -- Determine range to see if it can be larger than MaxS 8726 8727 Determine_Range 8728 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 8729 TestS := (not OK) or else Hi > MaxS; 8730 8731 -- Signed integer case 8732 8733 if Is_Signed_Integer_Type (Typ) then 8734 8735 -- Generate overflow check if overflow is active. Note that 8736 -- we can simply ignore the possibility of overflow if the 8737 -- flag is not set (means that overflow cannot happen or 8738 -- that overflow checks are suppressed). 8739 8740 if Ovflo and TestS then 8741 Insert_Action (N, 8742 Make_Raise_Constraint_Error (Loc, 8743 Condition => 8744 Make_Op_Gt (Loc, 8745 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)), 8746 Right_Opnd => Make_Integer_Literal (Loc, MaxS)), 8747 Reason => CE_Overflow_Check_Failed)); 8748 end if; 8749 8750 -- Now rewrite node as Shift_Left (1, right-operand) 8751 8752 Rewrite (N, 8753 Make_Op_Shift_Left (Loc, 8754 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8755 Right_Opnd => Right_Opnd (N))); 8756 8757 -- Modular integer case 8758 8759 else pragma Assert (Is_Modular_Integer_Type (Typ)); 8760 8761 -- If shift count can be greater than MaxS, we need to wrap 8762 -- the shift in a test that will reduce the result value to 8763 -- zero if this shift count is exceeded. 8764 8765 if TestS then 8766 8767 -- Note: build node for the comparison first, before we 8768 -- reuse the Right_Opnd, so that we have proper parents 8769 -- in place for the Duplicate_Subexpr call. 8770 8771 Test_Gt := 8772 Make_Op_Gt (Loc, 8773 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)), 8774 Right_Opnd => Make_Integer_Literal (Loc, MaxS)); 8775 8776 Rewrite (N, 8777 Make_If_Expression (Loc, 8778 Expressions => New_List ( 8779 Test_Gt, 8780 Make_Integer_Literal (Loc, Uint_0), 8781 Make_Op_Shift_Left (Loc, 8782 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8783 Right_Opnd => Right_Opnd (N))))); 8784 8785 -- If we know shift count cannot be greater than MaxS, then 8786 -- it is safe to just rewrite as a shift with no test. 8787 8788 else 8789 Rewrite (N, 8790 Make_Op_Shift_Left (Loc, 8791 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8792 Right_Opnd => Right_Opnd (N))); 8793 end if; 8794 end if; 8795 8796 Analyze_And_Resolve (N, Typ); 8797 return; 8798 end; 8799 end if; 8800 end if; 8801 8802 -- Fall through if exponentiation must be done using a runtime routine 8803 8804 -- First deal with modular case 8805 8806 if Is_Modular_Integer_Type (Rtyp) then 8807 8808 -- Nonbinary modular case, we call the special exponentiation 8809 -- routine for the nonbinary case, converting the argument to 8810 -- Long_Long_Integer and passing the modulus value. Then the 8811 -- result is converted back to the base type. 8812 8813 if Non_Binary_Modulus (Rtyp) then 8814 Rewrite (N, 8815 Convert_To (Typ, 8816 Make_Function_Call (Loc, 8817 Name => 8818 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc), 8819 Parameter_Associations => New_List ( 8820 Convert_To (RTE (RE_Unsigned), Base), 8821 Make_Integer_Literal (Loc, Modulus (Rtyp)), 8822 Exp)))); 8823 8824 -- Binary modular case, in this case, we call one of two routines, 8825 -- either the unsigned integer case, or the unsigned long long 8826 -- integer case, with a final "and" operation to do the required mod. 8827 8828 else 8829 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then 8830 Ent := RTE (RE_Exp_Unsigned); 8831 else 8832 Ent := RTE (RE_Exp_Long_Long_Unsigned); 8833 end if; 8834 8835 Rewrite (N, 8836 Convert_To (Typ, 8837 Make_Op_And (Loc, 8838 Left_Opnd => 8839 Make_Function_Call (Loc, 8840 Name => New_Occurrence_Of (Ent, Loc), 8841 Parameter_Associations => New_List ( 8842 Convert_To (Etype (First_Formal (Ent)), Base), 8843 Exp)), 8844 Right_Opnd => 8845 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); 8846 8847 end if; 8848 8849 -- Common exit point for modular type case 8850 8851 Analyze_And_Resolve (N, Typ); 8852 return; 8853 8854 -- Signed integer cases, done using either Integer or Long_Long_Integer. 8855 -- It is not worth having routines for Short_[Short_]Integer, since for 8856 -- most machines it would not help, and it would generate more code that 8857 -- might need certification when a certified run time is required. 8858 8859 -- In the integer cases, we have two routines, one for when overflow 8860 -- checks are required, and one when they are not required, since there 8861 -- is a real gain in omitting checks on many machines. 8862 8863 elsif Rtyp = Base_Type (Standard_Long_Long_Integer) 8864 or else (Rtyp = Base_Type (Standard_Long_Integer) 8865 and then 8866 Esize (Standard_Long_Integer) > Esize (Standard_Integer)) 8867 or else Rtyp = Universal_Integer 8868 then 8869 Etyp := Standard_Long_Long_Integer; 8870 8871 if Ovflo then 8872 Rent := RE_Exp_Long_Long_Integer; 8873 else 8874 Rent := RE_Exn_Long_Long_Integer; 8875 end if; 8876 8877 elsif Is_Signed_Integer_Type (Rtyp) then 8878 Etyp := Standard_Integer; 8879 8880 if Ovflo then 8881 Rent := RE_Exp_Integer; 8882 else 8883 Rent := RE_Exn_Integer; 8884 end if; 8885 8886 -- Floating-point cases. We do not need separate routines for the 8887 -- overflow case here, since in the case of floating-point, we generate 8888 -- infinities anyway as a rule (either that or we automatically trap 8889 -- overflow), and if there is an infinity generated and a range check 8890 -- is required, the check will fail anyway. 8891 8892 -- Historical note: we used to convert everything to Long_Long_Float 8893 -- and call a single common routine, but this had the undesirable effect 8894 -- of giving different results for small static exponent values and the 8895 -- same dynamic values. 8896 8897 else 8898 pragma Assert (Is_Floating_Point_Type (Rtyp)); 8899 8900 if Rtyp = Standard_Float then 8901 Etyp := Standard_Float; 8902 Rent := RE_Exn_Float; 8903 8904 elsif Rtyp = Standard_Long_Float then 8905 Etyp := Standard_Long_Float; 8906 Rent := RE_Exn_Long_Float; 8907 8908 else 8909 Etyp := Standard_Long_Long_Float; 8910 Rent := RE_Exn_Long_Long_Float; 8911 end if; 8912 end if; 8913 8914 -- Common processing for integer cases and floating-point cases. 8915 -- If we are in the right type, we can call runtime routine directly 8916 8917 if Typ = Etyp 8918 and then Rtyp /= Universal_Integer 8919 and then Rtyp /= Universal_Real 8920 then 8921 Rewrite (N, 8922 Wrap_MA ( 8923 Make_Function_Call (Loc, 8924 Name => New_Occurrence_Of (RTE (Rent), Loc), 8925 Parameter_Associations => New_List (Base, Exp)))); 8926 8927 -- Otherwise we have to introduce conversions (conversions are also 8928 -- required in the universal cases, since the runtime routine is 8929 -- typed using one of the standard types). 8930 8931 else 8932 Rewrite (N, 8933 Convert_To (Typ, 8934 Make_Function_Call (Loc, 8935 Name => New_Occurrence_Of (RTE (Rent), Loc), 8936 Parameter_Associations => New_List ( 8937 Convert_To (Etyp, Base), 8938 Exp)))); 8939 end if; 8940 8941 Analyze_And_Resolve (N, Typ); 8942 return; 8943 8944 exception 8945 when RE_Not_Available => 8946 return; 8947 end Expand_N_Op_Expon; 8948 8949 -------------------- 8950 -- Expand_N_Op_Ge -- 8951 -------------------- 8952 8953 procedure Expand_N_Op_Ge (N : Node_Id) is 8954 Typ : constant Entity_Id := Etype (N); 8955 Op1 : constant Node_Id := Left_Opnd (N); 8956 Op2 : constant Node_Id := Right_Opnd (N); 8957 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 8958 8959 begin 8960 Binary_Op_Validity_Checks (N); 8961 8962 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8963 -- means we no longer have a comparison operation, we are all done. 8964 8965 Expand_Compare_Minimize_Eliminate_Overflow (N); 8966 8967 if Nkind (N) /= N_Op_Ge then 8968 return; 8969 end if; 8970 8971 -- Array type case 8972 8973 if Is_Array_Type (Typ1) then 8974 Expand_Array_Comparison (N); 8975 return; 8976 end if; 8977 8978 -- Deal with boolean operands 8979 8980 if Is_Boolean_Type (Typ1) then 8981 Adjust_Condition (Op1); 8982 Adjust_Condition (Op2); 8983 Set_Etype (N, Standard_Boolean); 8984 Adjust_Result_Type (N, Typ); 8985 end if; 8986 8987 Rewrite_Comparison (N); 8988 8989 Optimize_Length_Comparison (N); 8990 end Expand_N_Op_Ge; 8991 8992 -------------------- 8993 -- Expand_N_Op_Gt -- 8994 -------------------- 8995 8996 procedure Expand_N_Op_Gt (N : Node_Id) is 8997 Typ : constant Entity_Id := Etype (N); 8998 Op1 : constant Node_Id := Left_Opnd (N); 8999 Op2 : constant Node_Id := Right_Opnd (N); 9000 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9001 9002 begin 9003 Binary_Op_Validity_Checks (N); 9004 9005 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9006 -- means we no longer have a comparison operation, we are all done. 9007 9008 Expand_Compare_Minimize_Eliminate_Overflow (N); 9009 9010 if Nkind (N) /= N_Op_Gt then 9011 return; 9012 end if; 9013 9014 -- Deal with array type operands 9015 9016 if Is_Array_Type (Typ1) then 9017 Expand_Array_Comparison (N); 9018 return; 9019 end if; 9020 9021 -- Deal with boolean type operands 9022 9023 if Is_Boolean_Type (Typ1) then 9024 Adjust_Condition (Op1); 9025 Adjust_Condition (Op2); 9026 Set_Etype (N, Standard_Boolean); 9027 Adjust_Result_Type (N, Typ); 9028 end if; 9029 9030 Rewrite_Comparison (N); 9031 9032 Optimize_Length_Comparison (N); 9033 end Expand_N_Op_Gt; 9034 9035 -------------------- 9036 -- Expand_N_Op_Le -- 9037 -------------------- 9038 9039 procedure Expand_N_Op_Le (N : Node_Id) is 9040 Typ : constant Entity_Id := Etype (N); 9041 Op1 : constant Node_Id := Left_Opnd (N); 9042 Op2 : constant Node_Id := Right_Opnd (N); 9043 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9044 9045 begin 9046 Binary_Op_Validity_Checks (N); 9047 9048 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9049 -- means we no longer have a comparison operation, we are all done. 9050 9051 Expand_Compare_Minimize_Eliminate_Overflow (N); 9052 9053 if Nkind (N) /= N_Op_Le then 9054 return; 9055 end if; 9056 9057 -- Deal with array type operands 9058 9059 if Is_Array_Type (Typ1) then 9060 Expand_Array_Comparison (N); 9061 return; 9062 end if; 9063 9064 -- Deal with Boolean type operands 9065 9066 if Is_Boolean_Type (Typ1) then 9067 Adjust_Condition (Op1); 9068 Adjust_Condition (Op2); 9069 Set_Etype (N, Standard_Boolean); 9070 Adjust_Result_Type (N, Typ); 9071 end if; 9072 9073 Rewrite_Comparison (N); 9074 9075 Optimize_Length_Comparison (N); 9076 end Expand_N_Op_Le; 9077 9078 -------------------- 9079 -- Expand_N_Op_Lt -- 9080 -------------------- 9081 9082 procedure Expand_N_Op_Lt (N : Node_Id) is 9083 Typ : constant Entity_Id := Etype (N); 9084 Op1 : constant Node_Id := Left_Opnd (N); 9085 Op2 : constant Node_Id := Right_Opnd (N); 9086 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9087 9088 begin 9089 Binary_Op_Validity_Checks (N); 9090 9091 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9092 -- means we no longer have a comparison operation, we are all done. 9093 9094 Expand_Compare_Minimize_Eliminate_Overflow (N); 9095 9096 if Nkind (N) /= N_Op_Lt then 9097 return; 9098 end if; 9099 9100 -- Deal with array type operands 9101 9102 if Is_Array_Type (Typ1) then 9103 Expand_Array_Comparison (N); 9104 return; 9105 end if; 9106 9107 -- Deal with Boolean type operands 9108 9109 if Is_Boolean_Type (Typ1) then 9110 Adjust_Condition (Op1); 9111 Adjust_Condition (Op2); 9112 Set_Etype (N, Standard_Boolean); 9113 Adjust_Result_Type (N, Typ); 9114 end if; 9115 9116 Rewrite_Comparison (N); 9117 9118 Optimize_Length_Comparison (N); 9119 end Expand_N_Op_Lt; 9120 9121 ----------------------- 9122 -- Expand_N_Op_Minus -- 9123 ----------------------- 9124 9125 procedure Expand_N_Op_Minus (N : Node_Id) is 9126 Loc : constant Source_Ptr := Sloc (N); 9127 Typ : constant Entity_Id := Etype (N); 9128 9129 begin 9130 Unary_Op_Validity_Checks (N); 9131 9132 -- Check for MINIMIZED/ELIMINATED overflow mode 9133 9134 if Minimized_Eliminated_Overflow_Check (N) then 9135 Apply_Arithmetic_Overflow_Check (N); 9136 return; 9137 end if; 9138 9139 if not Backend_Overflow_Checks_On_Target 9140 and then Is_Signed_Integer_Type (Etype (N)) 9141 and then Do_Overflow_Check (N) 9142 then 9143 -- Software overflow checking expands -expr into (0 - expr) 9144 9145 Rewrite (N, 9146 Make_Op_Subtract (Loc, 9147 Left_Opnd => Make_Integer_Literal (Loc, 0), 9148 Right_Opnd => Right_Opnd (N))); 9149 9150 Analyze_And_Resolve (N, Typ); 9151 end if; 9152 9153 Expand_Nonbinary_Modular_Op (N); 9154 end Expand_N_Op_Minus; 9155 9156 --------------------- 9157 -- Expand_N_Op_Mod -- 9158 --------------------- 9159 9160 procedure Expand_N_Op_Mod (N : Node_Id) is 9161 Loc : constant Source_Ptr := Sloc (N); 9162 Typ : constant Entity_Id := Etype (N); 9163 DDC : constant Boolean := Do_Division_Check (N); 9164 9165 Left : Node_Id; 9166 Right : Node_Id; 9167 9168 LLB : Uint; 9169 Llo : Uint; 9170 Lhi : Uint; 9171 LOK : Boolean; 9172 Rlo : Uint; 9173 Rhi : Uint; 9174 ROK : Boolean; 9175 9176 pragma Warnings (Off, Lhi); 9177 9178 begin 9179 Binary_Op_Validity_Checks (N); 9180 9181 -- Check for MINIMIZED/ELIMINATED overflow mode 9182 9183 if Minimized_Eliminated_Overflow_Check (N) then 9184 Apply_Arithmetic_Overflow_Check (N); 9185 return; 9186 end if; 9187 9188 if Is_Integer_Type (Etype (N)) then 9189 Apply_Divide_Checks (N); 9190 9191 -- All done if we don't have a MOD any more, which can happen as a 9192 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 9193 9194 if Nkind (N) /= N_Op_Mod then 9195 return; 9196 end if; 9197 end if; 9198 9199 -- Proceed with expansion of mod operator 9200 9201 Left := Left_Opnd (N); 9202 Right := Right_Opnd (N); 9203 9204 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); 9205 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); 9206 9207 -- Convert mod to rem if operands are both known to be non-negative, or 9208 -- both known to be non-positive (these are the cases in which rem and 9209 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite 9210 -- likely that this will improve the quality of code, (the operation now 9211 -- corresponds to the hardware remainder), and it does not seem likely 9212 -- that it could be harmful. It also avoids some cases of the elaborate 9213 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %). 9214 9215 if (LOK and ROK) 9216 and then ((Llo >= 0 and then Rlo >= 0) 9217 or else 9218 (Lhi <= 0 and then Rhi <= 0)) 9219 then 9220 Rewrite (N, 9221 Make_Op_Rem (Sloc (N), 9222 Left_Opnd => Left_Opnd (N), 9223 Right_Opnd => Right_Opnd (N))); 9224 9225 -- Instead of reanalyzing the node we do the analysis manually. This 9226 -- avoids anomalies when the replacement is done in an instance and 9227 -- is epsilon more efficient. 9228 9229 Set_Entity (N, Standard_Entity (S_Op_Rem)); 9230 Set_Etype (N, Typ); 9231 Set_Do_Division_Check (N, DDC); 9232 Expand_N_Op_Rem (N); 9233 Set_Analyzed (N); 9234 return; 9235 9236 -- Otherwise, normal mod processing 9237 9238 else 9239 -- Apply optimization x mod 1 = 0. We don't really need that with 9240 -- gcc, but it is useful with other back ends and is certainly 9241 -- harmless. 9242 9243 if Is_Integer_Type (Etype (N)) 9244 and then Compile_Time_Known_Value (Right) 9245 and then Expr_Value (Right) = Uint_1 9246 then 9247 -- Call Remove_Side_Effects to ensure that any side effects in 9248 -- the ignored left operand (in particular function calls to 9249 -- user defined functions) are properly executed. 9250 9251 Remove_Side_Effects (Left); 9252 9253 Rewrite (N, Make_Integer_Literal (Loc, 0)); 9254 Analyze_And_Resolve (N, Typ); 9255 return; 9256 end if; 9257 9258 -- If we still have a mod operator and we are in Modify_Tree_For_C 9259 -- mode, and we have a signed integer type, then here is where we do 9260 -- the rewrite in terms of Rem. Note this rewrite bypasses the need 9261 -- for the special handling of the annoying case of largest negative 9262 -- number mod minus one. 9263 9264 if Nkind (N) = N_Op_Mod 9265 and then Is_Signed_Integer_Type (Typ) 9266 and then Modify_Tree_For_C 9267 then 9268 -- In the general case, we expand A mod B as 9269 9270 -- Tnn : constant typ := A rem B; 9271 -- .. 9272 -- (if (A >= 0) = (B >= 0) then Tnn 9273 -- elsif Tnn = 0 then 0 9274 -- else Tnn + B) 9275 9276 -- The comparison can be written simply as A >= 0 if we know that 9277 -- B >= 0 which is a very common case. 9278 9279 -- An important optimization is when B is known at compile time 9280 -- to be 2**K for some constant. In this case we can simply AND 9281 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits) 9282 -- and that works for both the positive and negative cases. 9283 9284 declare 9285 P2 : constant Nat := Power_Of_Two (Right); 9286 9287 begin 9288 if P2 /= 0 then 9289 Rewrite (N, 9290 Unchecked_Convert_To (Typ, 9291 Make_Op_And (Loc, 9292 Left_Opnd => 9293 Unchecked_Convert_To 9294 (Corresponding_Unsigned_Type (Typ), Left), 9295 Right_Opnd => 9296 Make_Integer_Literal (Loc, 2 ** P2 - 1)))); 9297 Analyze_And_Resolve (N, Typ); 9298 return; 9299 end if; 9300 end; 9301 9302 -- Here for the full rewrite 9303 9304 declare 9305 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N); 9306 Cmp : Node_Id; 9307 9308 begin 9309 Cmp := 9310 Make_Op_Ge (Loc, 9311 Left_Opnd => Duplicate_Subexpr_No_Checks (Left), 9312 Right_Opnd => Make_Integer_Literal (Loc, 0)); 9313 9314 if not LOK or else Rlo < 0 then 9315 Cmp := 9316 Make_Op_Eq (Loc, 9317 Left_Opnd => Cmp, 9318 Right_Opnd => 9319 Make_Op_Ge (Loc, 9320 Left_Opnd => Duplicate_Subexpr_No_Checks (Right), 9321 Right_Opnd => Make_Integer_Literal (Loc, 0))); 9322 end if; 9323 9324 Insert_Action (N, 9325 Make_Object_Declaration (Loc, 9326 Defining_Identifier => Tnn, 9327 Constant_Present => True, 9328 Object_Definition => New_Occurrence_Of (Typ, Loc), 9329 Expression => 9330 Make_Op_Rem (Loc, 9331 Left_Opnd => Left, 9332 Right_Opnd => Right))); 9333 9334 Rewrite (N, 9335 Make_If_Expression (Loc, 9336 Expressions => New_List ( 9337 Cmp, 9338 New_Occurrence_Of (Tnn, Loc), 9339 Make_If_Expression (Loc, 9340 Is_Elsif => True, 9341 Expressions => New_List ( 9342 Make_Op_Eq (Loc, 9343 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 9344 Right_Opnd => Make_Integer_Literal (Loc, 0)), 9345 Make_Integer_Literal (Loc, 0), 9346 Make_Op_Add (Loc, 9347 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 9348 Right_Opnd => 9349 Duplicate_Subexpr_No_Checks (Right))))))); 9350 9351 Analyze_And_Resolve (N, Typ); 9352 return; 9353 end; 9354 end if; 9355 9356 -- Deal with annoying case of largest negative number mod minus one. 9357 -- Gigi may not handle this case correctly, because on some targets, 9358 -- the mod value is computed using a divide instruction which gives 9359 -- an overflow trap for this case. 9360 9361 -- It would be a bit more efficient to figure out which targets 9362 -- this is really needed for, but in practice it is reasonable 9363 -- to do the following special check in all cases, since it means 9364 -- we get a clearer message, and also the overhead is minimal given 9365 -- that division is expensive in any case. 9366 9367 -- In fact the check is quite easy, if the right operand is -1, then 9368 -- the mod value is always 0, and we can just ignore the left operand 9369 -- completely in this case. 9370 9371 -- This only applies if we still have a mod operator. Skip if we 9372 -- have already rewritten this (e.g. in the case of eliminated 9373 -- overflow checks which have driven us into bignum mode). 9374 9375 if Nkind (N) = N_Op_Mod then 9376 9377 -- The operand type may be private (e.g. in the expansion of an 9378 -- intrinsic operation) so we must use the underlying type to get 9379 -- the bounds, and convert the literals explicitly. 9380 9381 LLB := 9382 Expr_Value 9383 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); 9384 9385 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 9386 and then ((not LOK) or else (Llo = LLB)) 9387 then 9388 Rewrite (N, 9389 Make_If_Expression (Loc, 9390 Expressions => New_List ( 9391 Make_Op_Eq (Loc, 9392 Left_Opnd => Duplicate_Subexpr (Right), 9393 Right_Opnd => 9394 Unchecked_Convert_To (Typ, 9395 Make_Integer_Literal (Loc, -1))), 9396 Unchecked_Convert_To (Typ, 9397 Make_Integer_Literal (Loc, Uint_0)), 9398 Relocate_Node (N)))); 9399 9400 Set_Analyzed (Next (Next (First (Expressions (N))))); 9401 Analyze_And_Resolve (N, Typ); 9402 end if; 9403 end if; 9404 end if; 9405 end Expand_N_Op_Mod; 9406 9407 -------------------------- 9408 -- Expand_N_Op_Multiply -- 9409 -------------------------- 9410 9411 procedure Expand_N_Op_Multiply (N : Node_Id) is 9412 Loc : constant Source_Ptr := Sloc (N); 9413 Lop : constant Node_Id := Left_Opnd (N); 9414 Rop : constant Node_Id := Right_Opnd (N); 9415 9416 Lp2 : constant Boolean := 9417 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop); 9418 Rp2 : constant Boolean := 9419 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop); 9420 9421 Ltyp : constant Entity_Id := Etype (Lop); 9422 Rtyp : constant Entity_Id := Etype (Rop); 9423 Typ : Entity_Id := Etype (N); 9424 9425 begin 9426 Binary_Op_Validity_Checks (N); 9427 9428 -- Check for MINIMIZED/ELIMINATED overflow mode 9429 9430 if Minimized_Eliminated_Overflow_Check (N) then 9431 Apply_Arithmetic_Overflow_Check (N); 9432 return; 9433 end if; 9434 9435 -- Special optimizations for integer types 9436 9437 if Is_Integer_Type (Typ) then 9438 9439 -- N * 0 = 0 for integer types 9440 9441 if Compile_Time_Known_Value (Rop) 9442 and then Expr_Value (Rop) = Uint_0 9443 then 9444 -- Call Remove_Side_Effects to ensure that any side effects in 9445 -- the ignored left operand (in particular function calls to 9446 -- user defined functions) are properly executed. 9447 9448 Remove_Side_Effects (Lop); 9449 9450 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 9451 Analyze_And_Resolve (N, Typ); 9452 return; 9453 end if; 9454 9455 -- Similar handling for 0 * N = 0 9456 9457 if Compile_Time_Known_Value (Lop) 9458 and then Expr_Value (Lop) = Uint_0 9459 then 9460 Remove_Side_Effects (Rop); 9461 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 9462 Analyze_And_Resolve (N, Typ); 9463 return; 9464 end if; 9465 9466 -- N * 1 = 1 * N = N for integer types 9467 9468 -- This optimisation is not done if we are going to 9469 -- rewrite the product 1 * 2 ** N to a shift. 9470 9471 if Compile_Time_Known_Value (Rop) 9472 and then Expr_Value (Rop) = Uint_1 9473 and then not Lp2 9474 then 9475 Rewrite (N, Lop); 9476 return; 9477 9478 elsif Compile_Time_Known_Value (Lop) 9479 and then Expr_Value (Lop) = Uint_1 9480 and then not Rp2 9481 then 9482 Rewrite (N, Rop); 9483 return; 9484 end if; 9485 end if; 9486 9487 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that 9488 -- Is_Power_Of_2_For_Shift is set means that we know that our left 9489 -- operand is an integer, as required for this to work. 9490 9491 if Rp2 then 9492 if Lp2 then 9493 9494 -- Convert 2 ** A * 2 ** B into 2 ** (A + B) 9495 9496 Rewrite (N, 9497 Make_Op_Expon (Loc, 9498 Left_Opnd => Make_Integer_Literal (Loc, 2), 9499 Right_Opnd => 9500 Make_Op_Add (Loc, 9501 Left_Opnd => Right_Opnd (Lop), 9502 Right_Opnd => Right_Opnd (Rop)))); 9503 Analyze_And_Resolve (N, Typ); 9504 return; 9505 9506 else 9507 -- If the result is modular, perform the reduction of the result 9508 -- appropriately. 9509 9510 if Is_Modular_Integer_Type (Typ) 9511 and then not Non_Binary_Modulus (Typ) 9512 then 9513 Rewrite (N, 9514 Make_Op_And (Loc, 9515 Left_Opnd => 9516 Make_Op_Shift_Left (Loc, 9517 Left_Opnd => Lop, 9518 Right_Opnd => 9519 Convert_To (Standard_Natural, Right_Opnd (Rop))), 9520 Right_Opnd => 9521 Make_Integer_Literal (Loc, Modulus (Typ) - 1))); 9522 9523 else 9524 Rewrite (N, 9525 Make_Op_Shift_Left (Loc, 9526 Left_Opnd => Lop, 9527 Right_Opnd => 9528 Convert_To (Standard_Natural, Right_Opnd (Rop)))); 9529 end if; 9530 9531 Analyze_And_Resolve (N, Typ); 9532 return; 9533 end if; 9534 9535 -- Same processing for the operands the other way round 9536 9537 elsif Lp2 then 9538 if Is_Modular_Integer_Type (Typ) 9539 and then not Non_Binary_Modulus (Typ) 9540 then 9541 Rewrite (N, 9542 Make_Op_And (Loc, 9543 Left_Opnd => 9544 Make_Op_Shift_Left (Loc, 9545 Left_Opnd => Rop, 9546 Right_Opnd => 9547 Convert_To (Standard_Natural, Right_Opnd (Lop))), 9548 Right_Opnd => 9549 Make_Integer_Literal (Loc, Modulus (Typ) - 1))); 9550 9551 else 9552 Rewrite (N, 9553 Make_Op_Shift_Left (Loc, 9554 Left_Opnd => Rop, 9555 Right_Opnd => 9556 Convert_To (Standard_Natural, Right_Opnd (Lop)))); 9557 end if; 9558 9559 Analyze_And_Resolve (N, Typ); 9560 return; 9561 end if; 9562 9563 -- Do required fixup of universal fixed operation 9564 9565 if Typ = Universal_Fixed then 9566 Fixup_Universal_Fixed_Operation (N); 9567 Typ := Etype (N); 9568 end if; 9569 9570 -- Multiplications with fixed-point results 9571 9572 if Is_Fixed_Point_Type (Typ) then 9573 9574 -- No special processing if Treat_Fixed_As_Integer is set, since from 9575 -- a semantic point of view such operations are simply integer 9576 -- operations and will be treated that way. 9577 9578 if not Treat_Fixed_As_Integer (N) then 9579 9580 -- Case of fixed * integer => fixed 9581 9582 if Is_Integer_Type (Rtyp) then 9583 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); 9584 9585 -- Case of integer * fixed => fixed 9586 9587 elsif Is_Integer_Type (Ltyp) then 9588 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); 9589 9590 -- Case of fixed * fixed => fixed 9591 9592 else 9593 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); 9594 end if; 9595 end if; 9596 9597 -- Other cases of multiplication of fixed-point operands. Again we 9598 -- exclude the cases where Treat_Fixed_As_Integer flag is set. 9599 9600 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) 9601 and then not Treat_Fixed_As_Integer (N) 9602 then 9603 if Is_Integer_Type (Typ) then 9604 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); 9605 else 9606 pragma Assert (Is_Floating_Point_Type (Typ)); 9607 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); 9608 end if; 9609 9610 -- Mixed-mode operations can appear in a non-static universal context, 9611 -- in which case the integer argument must be converted explicitly. 9612 9613 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then 9614 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); 9615 Analyze_And_Resolve (Rop, Universal_Real); 9616 9617 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then 9618 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); 9619 Analyze_And_Resolve (Lop, Universal_Real); 9620 9621 -- Non-fixed point cases, check software overflow checking required 9622 9623 elsif Is_Signed_Integer_Type (Etype (N)) then 9624 Apply_Arithmetic_Overflow_Check (N); 9625 end if; 9626 9627 -- Overflow checks for floating-point if -gnateF mode active 9628 9629 Check_Float_Op_Overflow (N); 9630 9631 Expand_Nonbinary_Modular_Op (N); 9632 end Expand_N_Op_Multiply; 9633 9634 -------------------- 9635 -- Expand_N_Op_Ne -- 9636 -------------------- 9637 9638 procedure Expand_N_Op_Ne (N : Node_Id) is 9639 Typ : constant Entity_Id := Etype (Left_Opnd (N)); 9640 9641 begin 9642 -- Case of elementary type with standard operator. But if unnesting, 9643 -- handle elementary types whose Equivalent_Types are records because 9644 -- there may be padding or undefined fields. 9645 9646 if Is_Elementary_Type (Typ) 9647 and then Sloc (Entity (N)) = Standard_Location 9648 and then not (Ekind_In (Typ, E_Class_Wide_Type, 9649 E_Class_Wide_Subtype, 9650 E_Access_Subprogram_Type, 9651 E_Access_Protected_Subprogram_Type, 9652 E_Anonymous_Access_Protected_Subprogram_Type, 9653 E_Access_Subprogram_Type, 9654 E_Exception_Type) 9655 and then Present (Equivalent_Type (Typ)) 9656 and then Is_Record_Type (Equivalent_Type (Typ))) 9657 then 9658 Binary_Op_Validity_Checks (N); 9659 9660 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if 9661 -- means we no longer have a /= operation, we are all done. 9662 9663 Expand_Compare_Minimize_Eliminate_Overflow (N); 9664 9665 if Nkind (N) /= N_Op_Ne then 9666 return; 9667 end if; 9668 9669 -- Boolean types (requiring handling of non-standard case) 9670 9671 if Is_Boolean_Type (Typ) then 9672 Adjust_Condition (Left_Opnd (N)); 9673 Adjust_Condition (Right_Opnd (N)); 9674 Set_Etype (N, Standard_Boolean); 9675 Adjust_Result_Type (N, Typ); 9676 end if; 9677 9678 Rewrite_Comparison (N); 9679 9680 -- For all cases other than elementary types, we rewrite node as the 9681 -- negation of an equality operation, and reanalyze. The equality to be 9682 -- used is defined in the same scope and has the same signature. This 9683 -- signature must be set explicitly since in an instance it may not have 9684 -- the same visibility as in the generic unit. This avoids duplicating 9685 -- or factoring the complex code for record/array equality tests etc. 9686 9687 -- This case is also used for the minimal expansion performed in 9688 -- GNATprove mode. 9689 9690 else 9691 declare 9692 Loc : constant Source_Ptr := Sloc (N); 9693 Neg : Node_Id; 9694 Ne : constant Entity_Id := Entity (N); 9695 9696 begin 9697 Binary_Op_Validity_Checks (N); 9698 9699 Neg := 9700 Make_Op_Not (Loc, 9701 Right_Opnd => 9702 Make_Op_Eq (Loc, 9703 Left_Opnd => Left_Opnd (N), 9704 Right_Opnd => Right_Opnd (N))); 9705 9706 -- The level of parentheses is useless in GNATprove mode, and 9707 -- bumping its level here leads to wrong columns being used in 9708 -- check messages, hence skip it in this mode. 9709 9710 if not GNATprove_Mode then 9711 Set_Paren_Count (Right_Opnd (Neg), 1); 9712 end if; 9713 9714 if Scope (Ne) /= Standard_Standard then 9715 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); 9716 end if; 9717 9718 -- For navigation purposes, we want to treat the inequality as an 9719 -- implicit reference to the corresponding equality. Preserve the 9720 -- Comes_From_ source flag to generate proper Xref entries. 9721 9722 Preserve_Comes_From_Source (Neg, N); 9723 Preserve_Comes_From_Source (Right_Opnd (Neg), N); 9724 Rewrite (N, Neg); 9725 Analyze_And_Resolve (N, Standard_Boolean); 9726 end; 9727 end if; 9728 9729 -- No need for optimization in GNATprove mode, where we would rather see 9730 -- the original source expression. 9731 9732 if not GNATprove_Mode then 9733 Optimize_Length_Comparison (N); 9734 end if; 9735 end Expand_N_Op_Ne; 9736 9737 --------------------- 9738 -- Expand_N_Op_Not -- 9739 --------------------- 9740 9741 -- If the argument is other than a Boolean array type, there is no special 9742 -- expansion required, except for dealing with validity checks, and non- 9743 -- standard boolean representations. 9744 9745 -- For the packed array case, we call the special routine in Exp_Pakd, 9746 -- except that if the component size is greater than one, we use the 9747 -- standard routine generating a gruesome loop (it is so peculiar to have 9748 -- packed arrays with non-standard Boolean representations anyway, so it 9749 -- does not matter that we do not handle this case efficiently). 9750 9751 -- For the unpacked array case (and for the special packed case where we 9752 -- have non standard Booleans, as discussed above), we generate and insert 9753 -- into the tree the following function definition: 9754 9755 -- function Nnnn (A : arr) is 9756 -- B : arr; 9757 -- begin 9758 -- for J in a'range loop 9759 -- B (J) := not A (J); 9760 -- end loop; 9761 -- return B; 9762 -- end Nnnn; 9763 9764 -- Here arr is the actual subtype of the parameter (and hence always 9765 -- constrained). Then we replace the not with a call to this function. 9766 9767 procedure Expand_N_Op_Not (N : Node_Id) is 9768 Loc : constant Source_Ptr := Sloc (N); 9769 Typ : constant Entity_Id := Etype (N); 9770 Opnd : Node_Id; 9771 Arr : Entity_Id; 9772 A : Entity_Id; 9773 B : Entity_Id; 9774 J : Entity_Id; 9775 A_J : Node_Id; 9776 B_J : Node_Id; 9777 9778 Func_Name : Entity_Id; 9779 Loop_Statement : Node_Id; 9780 9781 begin 9782 Unary_Op_Validity_Checks (N); 9783 9784 -- For boolean operand, deal with non-standard booleans 9785 9786 if Is_Boolean_Type (Typ) then 9787 Adjust_Condition (Right_Opnd (N)); 9788 Set_Etype (N, Standard_Boolean); 9789 Adjust_Result_Type (N, Typ); 9790 return; 9791 end if; 9792 9793 -- Only array types need any other processing 9794 9795 if not Is_Array_Type (Typ) then 9796 return; 9797 end if; 9798 9799 -- Case of array operand. If bit packed with a component size of 1, 9800 -- handle it in Exp_Pakd if the operand is known to be aligned. 9801 9802 if Is_Bit_Packed_Array (Typ) 9803 and then Component_Size (Typ) = 1 9804 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 9805 then 9806 Expand_Packed_Not (N); 9807 return; 9808 end if; 9809 9810 -- Case of array operand which is not bit-packed. If the context is 9811 -- a safe assignment, call in-place operation, If context is a larger 9812 -- boolean expression in the context of a safe assignment, expansion is 9813 -- done by enclosing operation. 9814 9815 Opnd := Relocate_Node (Right_Opnd (N)); 9816 Convert_To_Actual_Subtype (Opnd); 9817 Arr := Etype (Opnd); 9818 Ensure_Defined (Arr, N); 9819 Silly_Boolean_Array_Not_Test (N, Arr); 9820 9821 if Nkind (Parent (N)) = N_Assignment_Statement then 9822 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then 9823 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 9824 return; 9825 9826 -- Special case the negation of a binary operation 9827 9828 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor) 9829 and then Safe_In_Place_Array_Op 9830 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) 9831 then 9832 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 9833 return; 9834 end if; 9835 9836 elsif Nkind (Parent (N)) in N_Binary_Op 9837 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 9838 then 9839 declare 9840 Op1 : constant Node_Id := Left_Opnd (Parent (N)); 9841 Op2 : constant Node_Id := Right_Opnd (Parent (N)); 9842 Lhs : constant Node_Id := Name (Parent (Parent (N))); 9843 9844 begin 9845 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then 9846 9847 -- (not A) op (not B) can be reduced to a single call 9848 9849 if N = Op1 and then Nkind (Op2) = N_Op_Not then 9850 return; 9851 9852 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then 9853 return; 9854 9855 -- A xor (not B) can also be special-cased 9856 9857 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then 9858 return; 9859 end if; 9860 end if; 9861 end; 9862 end if; 9863 9864 A := Make_Defining_Identifier (Loc, Name_uA); 9865 B := Make_Defining_Identifier (Loc, Name_uB); 9866 J := Make_Defining_Identifier (Loc, Name_uJ); 9867 9868 A_J := 9869 Make_Indexed_Component (Loc, 9870 Prefix => New_Occurrence_Of (A, Loc), 9871 Expressions => New_List (New_Occurrence_Of (J, Loc))); 9872 9873 B_J := 9874 Make_Indexed_Component (Loc, 9875 Prefix => New_Occurrence_Of (B, Loc), 9876 Expressions => New_List (New_Occurrence_Of (J, Loc))); 9877 9878 Loop_Statement := 9879 Make_Implicit_Loop_Statement (N, 9880 Identifier => Empty, 9881 9882 Iteration_Scheme => 9883 Make_Iteration_Scheme (Loc, 9884 Loop_Parameter_Specification => 9885 Make_Loop_Parameter_Specification (Loc, 9886 Defining_Identifier => J, 9887 Discrete_Subtype_Definition => 9888 Make_Attribute_Reference (Loc, 9889 Prefix => Make_Identifier (Loc, Chars (A)), 9890 Attribute_Name => Name_Range))), 9891 9892 Statements => New_List ( 9893 Make_Assignment_Statement (Loc, 9894 Name => B_J, 9895 Expression => Make_Op_Not (Loc, A_J)))); 9896 9897 Func_Name := Make_Temporary (Loc, 'N'); 9898 Set_Is_Inlined (Func_Name); 9899 9900 Insert_Action (N, 9901 Make_Subprogram_Body (Loc, 9902 Specification => 9903 Make_Function_Specification (Loc, 9904 Defining_Unit_Name => Func_Name, 9905 Parameter_Specifications => New_List ( 9906 Make_Parameter_Specification (Loc, 9907 Defining_Identifier => A, 9908 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 9909 Result_Definition => New_Occurrence_Of (Typ, Loc)), 9910 9911 Declarations => New_List ( 9912 Make_Object_Declaration (Loc, 9913 Defining_Identifier => B, 9914 Object_Definition => New_Occurrence_Of (Arr, Loc))), 9915 9916 Handled_Statement_Sequence => 9917 Make_Handled_Sequence_Of_Statements (Loc, 9918 Statements => New_List ( 9919 Loop_Statement, 9920 Make_Simple_Return_Statement (Loc, 9921 Expression => Make_Identifier (Loc, Chars (B))))))); 9922 9923 Rewrite (N, 9924 Make_Function_Call (Loc, 9925 Name => New_Occurrence_Of (Func_Name, Loc), 9926 Parameter_Associations => New_List (Opnd))); 9927 9928 Analyze_And_Resolve (N, Typ); 9929 end Expand_N_Op_Not; 9930 9931 -------------------- 9932 -- Expand_N_Op_Or -- 9933 -------------------- 9934 9935 procedure Expand_N_Op_Or (N : Node_Id) is 9936 Typ : constant Entity_Id := Etype (N); 9937 9938 begin 9939 Binary_Op_Validity_Checks (N); 9940 9941 if Is_Array_Type (Etype (N)) then 9942 Expand_Boolean_Operator (N); 9943 9944 elsif Is_Boolean_Type (Etype (N)) then 9945 Adjust_Condition (Left_Opnd (N)); 9946 Adjust_Condition (Right_Opnd (N)); 9947 Set_Etype (N, Standard_Boolean); 9948 Adjust_Result_Type (N, Typ); 9949 9950 elsif Is_Intrinsic_Subprogram (Entity (N)) then 9951 Expand_Intrinsic_Call (N, Entity (N)); 9952 end if; 9953 9954 Expand_Nonbinary_Modular_Op (N); 9955 end Expand_N_Op_Or; 9956 9957 ---------------------- 9958 -- Expand_N_Op_Plus -- 9959 ---------------------- 9960 9961 procedure Expand_N_Op_Plus (N : Node_Id) is 9962 begin 9963 Unary_Op_Validity_Checks (N); 9964 9965 -- Check for MINIMIZED/ELIMINATED overflow mode 9966 9967 if Minimized_Eliminated_Overflow_Check (N) then 9968 Apply_Arithmetic_Overflow_Check (N); 9969 return; 9970 end if; 9971 end Expand_N_Op_Plus; 9972 9973 --------------------- 9974 -- Expand_N_Op_Rem -- 9975 --------------------- 9976 9977 procedure Expand_N_Op_Rem (N : Node_Id) is 9978 Loc : constant Source_Ptr := Sloc (N); 9979 Typ : constant Entity_Id := Etype (N); 9980 9981 Left : Node_Id; 9982 Right : Node_Id; 9983 9984 Lo : Uint; 9985 Hi : Uint; 9986 OK : Boolean; 9987 9988 Lneg : Boolean; 9989 Rneg : Boolean; 9990 -- Set if corresponding operand can be negative 9991 9992 pragma Unreferenced (Hi); 9993 9994 begin 9995 Binary_Op_Validity_Checks (N); 9996 9997 -- Check for MINIMIZED/ELIMINATED overflow mode 9998 9999 if Minimized_Eliminated_Overflow_Check (N) then 10000 Apply_Arithmetic_Overflow_Check (N); 10001 return; 10002 end if; 10003 10004 if Is_Integer_Type (Etype (N)) then 10005 Apply_Divide_Checks (N); 10006 10007 -- All done if we don't have a REM any more, which can happen as a 10008 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 10009 10010 if Nkind (N) /= N_Op_Rem then 10011 return; 10012 end if; 10013 end if; 10014 10015 -- Proceed with expansion of REM 10016 10017 Left := Left_Opnd (N); 10018 Right := Right_Opnd (N); 10019 10020 -- Apply optimization x rem 1 = 0. We don't really need that with gcc, 10021 -- but it is useful with other back ends, and is certainly harmless. 10022 10023 if Is_Integer_Type (Etype (N)) 10024 and then Compile_Time_Known_Value (Right) 10025 and then Expr_Value (Right) = Uint_1 10026 then 10027 -- Call Remove_Side_Effects to ensure that any side effects in the 10028 -- ignored left operand (in particular function calls to user defined 10029 -- functions) are properly executed. 10030 10031 Remove_Side_Effects (Left); 10032 10033 Rewrite (N, Make_Integer_Literal (Loc, 0)); 10034 Analyze_And_Resolve (N, Typ); 10035 return; 10036 end if; 10037 10038 -- Deal with annoying case of largest negative number remainder minus 10039 -- one. Gigi may not handle this case correctly, because on some 10040 -- targets, the mod value is computed using a divide instruction 10041 -- which gives an overflow trap for this case. 10042 10043 -- It would be a bit more efficient to figure out which targets this 10044 -- is really needed for, but in practice it is reasonable to do the 10045 -- following special check in all cases, since it means we get a clearer 10046 -- message, and also the overhead is minimal given that division is 10047 -- expensive in any case. 10048 10049 -- In fact the check is quite easy, if the right operand is -1, then 10050 -- the remainder is always 0, and we can just ignore the left operand 10051 -- completely in this case. 10052 10053 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 10054 Lneg := (not OK) or else Lo < 0; 10055 10056 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True); 10057 Rneg := (not OK) or else Lo < 0; 10058 10059 -- We won't mess with trying to find out if the left operand can really 10060 -- be the largest negative number (that's a pain in the case of private 10061 -- types and this is really marginal). We will just assume that we need 10062 -- the test if the left operand can be negative at all. 10063 10064 if Lneg and Rneg then 10065 Rewrite (N, 10066 Make_If_Expression (Loc, 10067 Expressions => New_List ( 10068 Make_Op_Eq (Loc, 10069 Left_Opnd => Duplicate_Subexpr (Right), 10070 Right_Opnd => 10071 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))), 10072 10073 Unchecked_Convert_To (Typ, 10074 Make_Integer_Literal (Loc, Uint_0)), 10075 10076 Relocate_Node (N)))); 10077 10078 Set_Analyzed (Next (Next (First (Expressions (N))))); 10079 Analyze_And_Resolve (N, Typ); 10080 end if; 10081 end Expand_N_Op_Rem; 10082 10083 ----------------------------- 10084 -- Expand_N_Op_Rotate_Left -- 10085 ----------------------------- 10086 10087 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is 10088 begin 10089 Binary_Op_Validity_Checks (N); 10090 10091 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C, 10092 -- so we rewrite in terms of logical shifts 10093 10094 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits) 10095 10096 -- where Bits is the shift count mod Esize (the mod operation here 10097 -- deals with ludicrous large shift counts, which are apparently OK). 10098 10099 -- What about nonbinary modulus ??? 10100 10101 declare 10102 Loc : constant Source_Ptr := Sloc (N); 10103 Rtp : constant Entity_Id := Etype (Right_Opnd (N)); 10104 Typ : constant Entity_Id := Etype (N); 10105 10106 begin 10107 if Modify_Tree_For_C then 10108 Rewrite (Right_Opnd (N), 10109 Make_Op_Rem (Loc, 10110 Left_Opnd => Relocate_Node (Right_Opnd (N)), 10111 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); 10112 10113 Analyze_And_Resolve (Right_Opnd (N), Rtp); 10114 10115 Rewrite (N, 10116 Make_Op_Or (Loc, 10117 Left_Opnd => 10118 Make_Op_Shift_Left (Loc, 10119 Left_Opnd => Left_Opnd (N), 10120 Right_Opnd => Right_Opnd (N)), 10121 10122 Right_Opnd => 10123 Make_Op_Shift_Right (Loc, 10124 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)), 10125 Right_Opnd => 10126 Make_Op_Subtract (Loc, 10127 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), 10128 Right_Opnd => 10129 Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); 10130 10131 Analyze_And_Resolve (N, Typ); 10132 end if; 10133 end; 10134 end Expand_N_Op_Rotate_Left; 10135 10136 ------------------------------ 10137 -- Expand_N_Op_Rotate_Right -- 10138 ------------------------------ 10139 10140 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is 10141 begin 10142 Binary_Op_Validity_Checks (N); 10143 10144 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C, 10145 -- so we rewrite in terms of logical shifts 10146 10147 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits) 10148 10149 -- where Bits is the shift count mod Esize (the mod operation here 10150 -- deals with ludicrous large shift counts, which are apparently OK). 10151 10152 -- What about nonbinary modulus ??? 10153 10154 declare 10155 Loc : constant Source_Ptr := Sloc (N); 10156 Rtp : constant Entity_Id := Etype (Right_Opnd (N)); 10157 Typ : constant Entity_Id := Etype (N); 10158 10159 begin 10160 Rewrite (Right_Opnd (N), 10161 Make_Op_Rem (Loc, 10162 Left_Opnd => Relocate_Node (Right_Opnd (N)), 10163 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); 10164 10165 Analyze_And_Resolve (Right_Opnd (N), Rtp); 10166 10167 if Modify_Tree_For_C then 10168 Rewrite (N, 10169 Make_Op_Or (Loc, 10170 Left_Opnd => 10171 Make_Op_Shift_Right (Loc, 10172 Left_Opnd => Left_Opnd (N), 10173 Right_Opnd => Right_Opnd (N)), 10174 10175 Right_Opnd => 10176 Make_Op_Shift_Left (Loc, 10177 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)), 10178 Right_Opnd => 10179 Make_Op_Subtract (Loc, 10180 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), 10181 Right_Opnd => 10182 Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); 10183 10184 Analyze_And_Resolve (N, Typ); 10185 end if; 10186 end; 10187 end Expand_N_Op_Rotate_Right; 10188 10189 ---------------------------- 10190 -- Expand_N_Op_Shift_Left -- 10191 ---------------------------- 10192 10193 -- Note: nothing in this routine depends on left as opposed to right shifts 10194 -- so we share the routine for expanding shift right operations. 10195 10196 procedure Expand_N_Op_Shift_Left (N : Node_Id) is 10197 begin 10198 Binary_Op_Validity_Checks (N); 10199 10200 -- If we are in Modify_Tree_For_C mode, then ensure that the right 10201 -- operand is not greater than the word size (since that would not 10202 -- be defined properly by the corresponding C shift operator). 10203 10204 if Modify_Tree_For_C then 10205 declare 10206 Right : constant Node_Id := Right_Opnd (N); 10207 Loc : constant Source_Ptr := Sloc (Right); 10208 Typ : constant Entity_Id := Etype (N); 10209 Siz : constant Uint := Esize (Typ); 10210 Orig : Node_Id; 10211 OK : Boolean; 10212 Lo : Uint; 10213 Hi : Uint; 10214 10215 begin 10216 if Compile_Time_Known_Value (Right) then 10217 if Expr_Value (Right) >= Siz then 10218 Rewrite (N, Make_Integer_Literal (Loc, 0)); 10219 Analyze_And_Resolve (N, Typ); 10220 end if; 10221 10222 -- Not compile time known, find range 10223 10224 else 10225 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 10226 10227 -- Nothing to do if known to be OK range, otherwise expand 10228 10229 if not OK or else Hi >= Siz then 10230 10231 -- Prevent recursion on copy of shift node 10232 10233 Orig := Relocate_Node (N); 10234 Set_Analyzed (Orig); 10235 10236 -- Now do the rewrite 10237 10238 Rewrite (N, 10239 Make_If_Expression (Loc, 10240 Expressions => New_List ( 10241 Make_Op_Ge (Loc, 10242 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), 10243 Right_Opnd => Make_Integer_Literal (Loc, Siz)), 10244 Make_Integer_Literal (Loc, 0), 10245 Orig))); 10246 Analyze_And_Resolve (N, Typ); 10247 end if; 10248 end if; 10249 end; 10250 end if; 10251 end Expand_N_Op_Shift_Left; 10252 10253 ----------------------------- 10254 -- Expand_N_Op_Shift_Right -- 10255 ----------------------------- 10256 10257 procedure Expand_N_Op_Shift_Right (N : Node_Id) is 10258 begin 10259 -- Share shift left circuit 10260 10261 Expand_N_Op_Shift_Left (N); 10262 end Expand_N_Op_Shift_Right; 10263 10264 ---------------------------------------- 10265 -- Expand_N_Op_Shift_Right_Arithmetic -- 10266 ---------------------------------------- 10267 10268 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is 10269 begin 10270 Binary_Op_Validity_Checks (N); 10271 10272 -- If we are in Modify_Tree_For_C mode, there is no shift right 10273 -- arithmetic in C, so we rewrite in terms of logical shifts. 10274 10275 -- Shift_Right (Num, Bits) or 10276 -- (if Num >= Sign 10277 -- then not (Shift_Right (Mask, bits)) 10278 -- else 0) 10279 10280 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1) 10281 10282 -- Note: in almost all C compilers it would work to just shift a 10283 -- signed integer right, but it's undefined and we cannot rely on it. 10284 10285 -- Note: the above works fine for shift counts greater than or equal 10286 -- to the word size, since in this case (not (Shift_Right (Mask, bits))) 10287 -- generates all 1'bits. 10288 10289 -- What about nonbinary modulus ??? 10290 10291 declare 10292 Loc : constant Source_Ptr := Sloc (N); 10293 Typ : constant Entity_Id := Etype (N); 10294 Sign : constant Uint := 2 ** (Esize (Typ) - 1); 10295 Mask : constant Uint := (2 ** Esize (Typ)) - 1; 10296 Left : constant Node_Id := Left_Opnd (N); 10297 Right : constant Node_Id := Right_Opnd (N); 10298 Maskx : Node_Id; 10299 10300 begin 10301 if Modify_Tree_For_C then 10302 10303 -- Here if not (Shift_Right (Mask, bits)) can be computed at 10304 -- compile time as a single constant. 10305 10306 if Compile_Time_Known_Value (Right) then 10307 declare 10308 Val : constant Uint := Expr_Value (Right); 10309 10310 begin 10311 if Val >= Esize (Typ) then 10312 Maskx := Make_Integer_Literal (Loc, Mask); 10313 10314 else 10315 Maskx := 10316 Make_Integer_Literal (Loc, 10317 Intval => Mask - (Mask / (2 ** Expr_Value (Right)))); 10318 end if; 10319 end; 10320 10321 else 10322 Maskx := 10323 Make_Op_Not (Loc, 10324 Right_Opnd => 10325 Make_Op_Shift_Right (Loc, 10326 Left_Opnd => Make_Integer_Literal (Loc, Mask), 10327 Right_Opnd => Duplicate_Subexpr_No_Checks (Right))); 10328 end if; 10329 10330 -- Now do the rewrite 10331 10332 Rewrite (N, 10333 Make_Op_Or (Loc, 10334 Left_Opnd => 10335 Make_Op_Shift_Right (Loc, 10336 Left_Opnd => Left, 10337 Right_Opnd => Right), 10338 Right_Opnd => 10339 Make_If_Expression (Loc, 10340 Expressions => New_List ( 10341 Make_Op_Ge (Loc, 10342 Left_Opnd => Duplicate_Subexpr_No_Checks (Left), 10343 Right_Opnd => Make_Integer_Literal (Loc, Sign)), 10344 Maskx, 10345 Make_Integer_Literal (Loc, 0))))); 10346 Analyze_And_Resolve (N, Typ); 10347 end if; 10348 end; 10349 end Expand_N_Op_Shift_Right_Arithmetic; 10350 10351 -------------------------- 10352 -- Expand_N_Op_Subtract -- 10353 -------------------------- 10354 10355 procedure Expand_N_Op_Subtract (N : Node_Id) is 10356 Typ : constant Entity_Id := Etype (N); 10357 10358 begin 10359 Binary_Op_Validity_Checks (N); 10360 10361 -- Check for MINIMIZED/ELIMINATED overflow mode 10362 10363 if Minimized_Eliminated_Overflow_Check (N) then 10364 Apply_Arithmetic_Overflow_Check (N); 10365 return; 10366 end if; 10367 10368 -- N - 0 = N for integer types 10369 10370 if Is_Integer_Type (Typ) 10371 and then Compile_Time_Known_Value (Right_Opnd (N)) 10372 and then Expr_Value (Right_Opnd (N)) = 0 10373 then 10374 Rewrite (N, Left_Opnd (N)); 10375 return; 10376 end if; 10377 10378 -- Arithmetic overflow checks for signed integer/fixed point types 10379 10380 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then 10381 Apply_Arithmetic_Overflow_Check (N); 10382 end if; 10383 10384 -- Overflow checks for floating-point if -gnateF mode active 10385 10386 Check_Float_Op_Overflow (N); 10387 10388 Expand_Nonbinary_Modular_Op (N); 10389 end Expand_N_Op_Subtract; 10390 10391 --------------------- 10392 -- Expand_N_Op_Xor -- 10393 --------------------- 10394 10395 procedure Expand_N_Op_Xor (N : Node_Id) is 10396 Typ : constant Entity_Id := Etype (N); 10397 10398 begin 10399 Binary_Op_Validity_Checks (N); 10400 10401 if Is_Array_Type (Etype (N)) then 10402 Expand_Boolean_Operator (N); 10403 10404 elsif Is_Boolean_Type (Etype (N)) then 10405 Adjust_Condition (Left_Opnd (N)); 10406 Adjust_Condition (Right_Opnd (N)); 10407 Set_Etype (N, Standard_Boolean); 10408 Adjust_Result_Type (N, Typ); 10409 10410 elsif Is_Intrinsic_Subprogram (Entity (N)) then 10411 Expand_Intrinsic_Call (N, Entity (N)); 10412 end if; 10413 10414 Expand_Nonbinary_Modular_Op (N); 10415 end Expand_N_Op_Xor; 10416 10417 ---------------------- 10418 -- Expand_N_Or_Else -- 10419 ---------------------- 10420 10421 procedure Expand_N_Or_Else (N : Node_Id) 10422 renames Expand_Short_Circuit_Operator; 10423 10424 ----------------------------------- 10425 -- Expand_N_Qualified_Expression -- 10426 ----------------------------------- 10427 10428 procedure Expand_N_Qualified_Expression (N : Node_Id) is 10429 Operand : constant Node_Id := Expression (N); 10430 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 10431 10432 begin 10433 -- Do validity check if validity checking operands 10434 10435 if Validity_Checks_On and Validity_Check_Operands then 10436 Ensure_Valid (Operand); 10437 end if; 10438 10439 -- Apply possible constraint check 10440 10441 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); 10442 10443 if Do_Range_Check (Operand) then 10444 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed); 10445 end if; 10446 end Expand_N_Qualified_Expression; 10447 10448 ------------------------------------ 10449 -- Expand_N_Quantified_Expression -- 10450 ------------------------------------ 10451 10452 -- We expand: 10453 10454 -- for all X in range => Cond 10455 10456 -- into: 10457 10458 -- T := True; 10459 -- for X in range loop 10460 -- if not Cond then 10461 -- T := False; 10462 -- exit; 10463 -- end if; 10464 -- end loop; 10465 10466 -- Similarly, an existentially quantified expression: 10467 10468 -- for some X in range => Cond 10469 10470 -- becomes: 10471 10472 -- T := False; 10473 -- for X in range loop 10474 -- if Cond then 10475 -- T := True; 10476 -- exit; 10477 -- end if; 10478 -- end loop; 10479 10480 -- In both cases, the iteration may be over a container in which case it is 10481 -- given by an iterator specification, not a loop parameter specification. 10482 10483 procedure Expand_N_Quantified_Expression (N : Node_Id) is 10484 Actions : constant List_Id := New_List; 10485 For_All : constant Boolean := All_Present (N); 10486 Iter_Spec : constant Node_Id := Iterator_Specification (N); 10487 Loc : constant Source_Ptr := Sloc (N); 10488 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); 10489 Cond : Node_Id; 10490 Flag : Entity_Id; 10491 Scheme : Node_Id; 10492 Stmts : List_Id; 10493 Var : Entity_Id; 10494 10495 begin 10496 -- Ensure that the bound variable is properly frozen. We must do 10497 -- this before expansion because the expression is about to be 10498 -- converted into a loop, and resulting freeze nodes may end up 10499 -- in the wrong place in the tree. 10500 10501 if Present (Iter_Spec) then 10502 Var := Defining_Identifier (Iter_Spec); 10503 else 10504 Var := Defining_Identifier (Loop_Spec); 10505 end if; 10506 10507 declare 10508 P : Node_Id := Parent (N); 10509 begin 10510 while Nkind (P) in N_Subexpr loop 10511 P := Parent (P); 10512 end loop; 10513 10514 Freeze_Before (P, Etype (Var)); 10515 end; 10516 10517 -- Create the declaration of the flag which tracks the status of the 10518 -- quantified expression. Generate: 10519 10520 -- Flag : Boolean := (True | False); 10521 10522 Flag := Make_Temporary (Loc, 'T', N); 10523 10524 Append_To (Actions, 10525 Make_Object_Declaration (Loc, 10526 Defining_Identifier => Flag, 10527 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 10528 Expression => 10529 New_Occurrence_Of (Boolean_Literals (For_All), Loc))); 10530 10531 -- Construct the circuitry which tracks the status of the quantified 10532 -- expression. Generate: 10533 10534 -- if [not] Cond then 10535 -- Flag := (False | True); 10536 -- exit; 10537 -- end if; 10538 10539 Cond := Relocate_Node (Condition (N)); 10540 10541 if For_All then 10542 Cond := Make_Op_Not (Loc, Cond); 10543 end if; 10544 10545 Stmts := New_List ( 10546 Make_Implicit_If_Statement (N, 10547 Condition => Cond, 10548 Then_Statements => New_List ( 10549 Make_Assignment_Statement (Loc, 10550 Name => New_Occurrence_Of (Flag, Loc), 10551 Expression => 10552 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), 10553 Make_Exit_Statement (Loc)))); 10554 10555 -- Build the loop equivalent of the quantified expression 10556 10557 if Present (Iter_Spec) then 10558 Scheme := 10559 Make_Iteration_Scheme (Loc, 10560 Iterator_Specification => Iter_Spec); 10561 else 10562 Scheme := 10563 Make_Iteration_Scheme (Loc, 10564 Loop_Parameter_Specification => Loop_Spec); 10565 end if; 10566 10567 Append_To (Actions, 10568 Make_Loop_Statement (Loc, 10569 Iteration_Scheme => Scheme, 10570 Statements => Stmts, 10571 End_Label => Empty)); 10572 10573 -- Transform the quantified expression 10574 10575 Rewrite (N, 10576 Make_Expression_With_Actions (Loc, 10577 Expression => New_Occurrence_Of (Flag, Loc), 10578 Actions => Actions)); 10579 Analyze_And_Resolve (N, Standard_Boolean); 10580 end Expand_N_Quantified_Expression; 10581 10582 --------------------------------- 10583 -- Expand_N_Selected_Component -- 10584 --------------------------------- 10585 10586 procedure Expand_N_Selected_Component (N : Node_Id) is 10587 Loc : constant Source_Ptr := Sloc (N); 10588 Par : constant Node_Id := Parent (N); 10589 P : constant Node_Id := Prefix (N); 10590 S : constant Node_Id := Selector_Name (N); 10591 Ptyp : Entity_Id := Underlying_Type (Etype (P)); 10592 Disc : Entity_Id; 10593 New_N : Node_Id; 10594 Dcon : Elmt_Id; 10595 Dval : Node_Id; 10596 10597 function In_Left_Hand_Side (Comp : Node_Id) return Boolean; 10598 -- Gigi needs a temporary for prefixes that depend on a discriminant, 10599 -- unless the context of an assignment can provide size information. 10600 -- Don't we have a general routine that does this??? 10601 10602 function Is_Subtype_Declaration return Boolean; 10603 -- The replacement of a discriminant reference by its value is required 10604 -- if this is part of the initialization of an temporary generated by a 10605 -- change of representation. This shows up as the construction of a 10606 -- discriminant constraint for a subtype declared at the same point as 10607 -- the entity in the prefix of the selected component. We recognize this 10608 -- case when the context of the reference is: 10609 -- subtype ST is T(Obj.D); 10610 -- where the entity for Obj comes from source, and ST has the same sloc. 10611 10612 ----------------------- 10613 -- In_Left_Hand_Side -- 10614 ----------------------- 10615 10616 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is 10617 begin 10618 return (Nkind (Parent (Comp)) = N_Assignment_Statement 10619 and then Comp = Name (Parent (Comp))) 10620 or else (Present (Parent (Comp)) 10621 and then Nkind (Parent (Comp)) in N_Subexpr 10622 and then In_Left_Hand_Side (Parent (Comp))); 10623 end In_Left_Hand_Side; 10624 10625 ----------------------------- 10626 -- Is_Subtype_Declaration -- 10627 ----------------------------- 10628 10629 function Is_Subtype_Declaration return Boolean is 10630 Par : constant Node_Id := Parent (N); 10631 begin 10632 return 10633 Nkind (Par) = N_Index_Or_Discriminant_Constraint 10634 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration 10635 and then Comes_From_Source (Entity (Prefix (N))) 10636 and then Sloc (Par) = Sloc (Entity (Prefix (N))); 10637 end Is_Subtype_Declaration; 10638 10639 -- Start of processing for Expand_N_Selected_Component 10640 10641 begin 10642 -- Insert explicit dereference if required 10643 10644 if Is_Access_Type (Ptyp) then 10645 10646 -- First set prefix type to proper access type, in case it currently 10647 -- has a private (non-access) view of this type. 10648 10649 Set_Etype (P, Ptyp); 10650 10651 Insert_Explicit_Dereference (P); 10652 Analyze_And_Resolve (P, Designated_Type (Ptyp)); 10653 10654 Ptyp := Etype (P); 10655 end if; 10656 10657 -- Deal with discriminant check required 10658 10659 if Do_Discriminant_Check (N) then 10660 if Present (Discriminant_Checking_Func 10661 (Original_Record_Component (Entity (S)))) 10662 then 10663 -- Present the discriminant checking function to the backend, so 10664 -- that it can inline the call to the function. 10665 10666 Add_Inlined_Body 10667 (Discriminant_Checking_Func 10668 (Original_Record_Component (Entity (S))), 10669 N); 10670 10671 -- Now reset the flag and generate the call 10672 10673 Set_Do_Discriminant_Check (N, False); 10674 Generate_Discriminant_Check (N); 10675 10676 -- In the case of Unchecked_Union, no discriminant checking is 10677 -- actually performed. 10678 10679 else 10680 Set_Do_Discriminant_Check (N, False); 10681 end if; 10682 end if; 10683 10684 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 10685 -- function, then additional actuals must be passed. 10686 10687 if Is_Build_In_Place_Function_Call (P) then 10688 Make_Build_In_Place_Call_In_Anonymous_Context (P); 10689 10690 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 10691 -- containing build-in-place function calls whose returned object covers 10692 -- interface types. 10693 10694 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then 10695 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); 10696 end if; 10697 10698 -- Gigi cannot handle unchecked conversions that are the prefix of a 10699 -- selected component with discriminants. This must be checked during 10700 -- expansion, because during analysis the type of the selector is not 10701 -- known at the point the prefix is analyzed. If the conversion is the 10702 -- target of an assignment, then we cannot force the evaluation. 10703 10704 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion 10705 and then Has_Discriminants (Etype (N)) 10706 and then not In_Left_Hand_Side (N) 10707 then 10708 Force_Evaluation (Prefix (N)); 10709 end if; 10710 10711 -- Remaining processing applies only if selector is a discriminant 10712 10713 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then 10714 10715 -- If the selector is a discriminant of a constrained record type, 10716 -- we may be able to rewrite the expression with the actual value 10717 -- of the discriminant, a useful optimization in some cases. 10718 10719 if Is_Record_Type (Ptyp) 10720 and then Has_Discriminants (Ptyp) 10721 and then Is_Constrained (Ptyp) 10722 then 10723 -- Do this optimization for discrete types only, and not for 10724 -- access types (access discriminants get us into trouble). 10725 10726 if not Is_Discrete_Type (Etype (N)) then 10727 null; 10728 10729 -- Don't do this on the left-hand side of an assignment statement. 10730 -- Normally one would think that references like this would not 10731 -- occur, but they do in generated code, and mean that we really 10732 -- do want to assign the discriminant. 10733 10734 elsif Nkind (Par) = N_Assignment_Statement 10735 and then Name (Par) = N 10736 then 10737 null; 10738 10739 -- Don't do this optimization for the prefix of an attribute or 10740 -- the name of an object renaming declaration since these are 10741 -- contexts where we do not want the value anyway. 10742 10743 elsif (Nkind (Par) = N_Attribute_Reference 10744 and then Prefix (Par) = N) 10745 or else Is_Renamed_Object (N) 10746 then 10747 null; 10748 10749 -- Don't do this optimization if we are within the code for a 10750 -- discriminant check, since the whole point of such a check may 10751 -- be to verify the condition on which the code below depends. 10752 10753 elsif Is_In_Discriminant_Check (N) then 10754 null; 10755 10756 -- Green light to see if we can do the optimization. There is 10757 -- still one condition that inhibits the optimization below but 10758 -- now is the time to check the particular discriminant. 10759 10760 else 10761 -- Loop through discriminants to find the matching discriminant 10762 -- constraint to see if we can copy it. 10763 10764 Disc := First_Discriminant (Ptyp); 10765 Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); 10766 Discr_Loop : while Present (Dcon) loop 10767 Dval := Node (Dcon); 10768 10769 -- Check if this is the matching discriminant and if the 10770 -- discriminant value is simple enough to make sense to 10771 -- copy. We don't want to copy complex expressions, and 10772 -- indeed to do so can cause trouble (before we put in 10773 -- this guard, a discriminant expression containing an 10774 -- AND THEN was copied, causing problems for coverage 10775 -- analysis tools). 10776 10777 -- However, if the reference is part of the initialization 10778 -- code generated for an object declaration, we must use 10779 -- the discriminant value from the subtype constraint, 10780 -- because the selected component may be a reference to the 10781 -- object being initialized, whose discriminant is not yet 10782 -- set. This only happens in complex cases involving changes 10783 -- or representation. 10784 10785 if Disc = Entity (Selector_Name (N)) 10786 and then (Is_Entity_Name (Dval) 10787 or else Compile_Time_Known_Value (Dval) 10788 or else Is_Subtype_Declaration) 10789 then 10790 -- Here we have the matching discriminant. Check for 10791 -- the case of a discriminant of a component that is 10792 -- constrained by an outer discriminant, which cannot 10793 -- be optimized away. 10794 10795 if Denotes_Discriminant 10796 (Dval, Check_Concurrent => True) 10797 then 10798 exit Discr_Loop; 10799 10800 elsif Nkind (Original_Node (Dval)) = N_Selected_Component 10801 and then 10802 Denotes_Discriminant 10803 (Selector_Name (Original_Node (Dval)), True) 10804 then 10805 exit Discr_Loop; 10806 10807 -- Do not retrieve value if constraint is not static. It 10808 -- is generally not useful, and the constraint may be a 10809 -- rewritten outer discriminant in which case it is in 10810 -- fact incorrect. 10811 10812 elsif Is_Entity_Name (Dval) 10813 and then 10814 Nkind (Parent (Entity (Dval))) = N_Object_Declaration 10815 and then Present (Expression (Parent (Entity (Dval)))) 10816 and then not 10817 Is_OK_Static_Expression 10818 (Expression (Parent (Entity (Dval)))) 10819 then 10820 exit Discr_Loop; 10821 10822 -- In the context of a case statement, the expression may 10823 -- have the base type of the discriminant, and we need to 10824 -- preserve the constraint to avoid spurious errors on 10825 -- missing cases. 10826 10827 elsif Nkind (Parent (N)) = N_Case_Statement 10828 and then Etype (Dval) /= Etype (Disc) 10829 then 10830 Rewrite (N, 10831 Make_Qualified_Expression (Loc, 10832 Subtype_Mark => 10833 New_Occurrence_Of (Etype (Disc), Loc), 10834 Expression => 10835 New_Copy_Tree (Dval))); 10836 Analyze_And_Resolve (N, Etype (Disc)); 10837 10838 -- In case that comes out as a static expression, 10839 -- reset it (a selected component is never static). 10840 10841 Set_Is_Static_Expression (N, False); 10842 return; 10843 10844 -- Otherwise we can just copy the constraint, but the 10845 -- result is certainly not static. In some cases the 10846 -- discriminant constraint has been analyzed in the 10847 -- context of the original subtype indication, but for 10848 -- itypes the constraint might not have been analyzed 10849 -- yet, and this must be done now. 10850 10851 else 10852 Rewrite (N, New_Copy_Tree (Dval)); 10853 Analyze_And_Resolve (N); 10854 Set_Is_Static_Expression (N, False); 10855 return; 10856 end if; 10857 end if; 10858 10859 Next_Elmt (Dcon); 10860 Next_Discriminant (Disc); 10861 end loop Discr_Loop; 10862 10863 -- Note: the above loop should always find a matching 10864 -- discriminant, but if it does not, we just missed an 10865 -- optimization due to some glitch (perhaps a previous 10866 -- error), so ignore. 10867 10868 end if; 10869 end if; 10870 10871 -- The only remaining processing is in the case of a discriminant of 10872 -- a concurrent object, where we rewrite the prefix to denote the 10873 -- corresponding record type. If the type is derived and has renamed 10874 -- discriminants, use corresponding discriminant, which is the one 10875 -- that appears in the corresponding record. 10876 10877 if not Is_Concurrent_Type (Ptyp) then 10878 return; 10879 end if; 10880 10881 Disc := Entity (Selector_Name (N)); 10882 10883 if Is_Derived_Type (Ptyp) 10884 and then Present (Corresponding_Discriminant (Disc)) 10885 then 10886 Disc := Corresponding_Discriminant (Disc); 10887 end if; 10888 10889 New_N := 10890 Make_Selected_Component (Loc, 10891 Prefix => 10892 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), 10893 New_Copy_Tree (P)), 10894 Selector_Name => Make_Identifier (Loc, Chars (Disc))); 10895 10896 Rewrite (N, New_N); 10897 Analyze (N); 10898 end if; 10899 10900 -- Set Atomic_Sync_Required if necessary for atomic component 10901 10902 if Nkind (N) = N_Selected_Component then 10903 declare 10904 E : constant Entity_Id := Entity (Selector_Name (N)); 10905 Set : Boolean; 10906 10907 begin 10908 -- If component is atomic, but type is not, setting depends on 10909 -- disable/enable state for the component. 10910 10911 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then 10912 Set := not Atomic_Synchronization_Disabled (E); 10913 10914 -- If component is not atomic, but its type is atomic, setting 10915 -- depends on disable/enable state for the type. 10916 10917 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then 10918 Set := not Atomic_Synchronization_Disabled (Etype (E)); 10919 10920 -- If both component and type are atomic, we disable if either 10921 -- component or its type have sync disabled. 10922 10923 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then 10924 Set := (not Atomic_Synchronization_Disabled (E)) 10925 and then 10926 (not Atomic_Synchronization_Disabled (Etype (E))); 10927 10928 else 10929 Set := False; 10930 end if; 10931 10932 -- Set flag if required 10933 10934 if Set then 10935 Activate_Atomic_Synchronization (N); 10936 end if; 10937 end; 10938 end if; 10939 end Expand_N_Selected_Component; 10940 10941 -------------------- 10942 -- Expand_N_Slice -- 10943 -------------------- 10944 10945 procedure Expand_N_Slice (N : Node_Id) is 10946 Loc : constant Source_Ptr := Sloc (N); 10947 Typ : constant Entity_Id := Etype (N); 10948 10949 function Is_Procedure_Actual (N : Node_Id) return Boolean; 10950 -- Check whether the argument is an actual for a procedure call, in 10951 -- which case the expansion of a bit-packed slice is deferred until the 10952 -- call itself is expanded. The reason this is required is that we might 10953 -- have an IN OUT or OUT parameter, and the copy out is essential, and 10954 -- that copy out would be missed if we created a temporary here in 10955 -- Expand_N_Slice. Note that we don't bother to test specifically for an 10956 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it 10957 -- is harmless to defer expansion in the IN case, since the call 10958 -- processing will still generate the appropriate copy in operation, 10959 -- which will take care of the slice. 10960 10961 procedure Make_Temporary_For_Slice; 10962 -- Create a named variable for the value of the slice, in cases where 10963 -- the back end cannot handle it properly, e.g. when packed types or 10964 -- unaligned slices are involved. 10965 10966 ------------------------- 10967 -- Is_Procedure_Actual -- 10968 ------------------------- 10969 10970 function Is_Procedure_Actual (N : Node_Id) return Boolean is 10971 Par : Node_Id := Parent (N); 10972 10973 begin 10974 loop 10975 -- If our parent is a procedure call we can return 10976 10977 if Nkind (Par) = N_Procedure_Call_Statement then 10978 return True; 10979 10980 -- If our parent is a type conversion, keep climbing the tree, 10981 -- since a type conversion can be a procedure actual. Also keep 10982 -- climbing if parameter association or a qualified expression, 10983 -- since these are additional cases that do can appear on 10984 -- procedure actuals. 10985 10986 elsif Nkind_In (Par, N_Type_Conversion, 10987 N_Parameter_Association, 10988 N_Qualified_Expression) 10989 then 10990 Par := Parent (Par); 10991 10992 -- Any other case is not what we are looking for 10993 10994 else 10995 return False; 10996 end if; 10997 end loop; 10998 end Is_Procedure_Actual; 10999 11000 ------------------------------ 11001 -- Make_Temporary_For_Slice -- 11002 ------------------------------ 11003 11004 procedure Make_Temporary_For_Slice is 11005 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); 11006 Decl : Node_Id; 11007 11008 begin 11009 Decl := 11010 Make_Object_Declaration (Loc, 11011 Defining_Identifier => Ent, 11012 Object_Definition => New_Occurrence_Of (Typ, Loc)); 11013 11014 Set_No_Initialization (Decl); 11015 11016 Insert_Actions (N, New_List ( 11017 Decl, 11018 Make_Assignment_Statement (Loc, 11019 Name => New_Occurrence_Of (Ent, Loc), 11020 Expression => Relocate_Node (N)))); 11021 11022 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 11023 Analyze_And_Resolve (N, Typ); 11024 end Make_Temporary_For_Slice; 11025 11026 -- Local variables 11027 11028 Pref : constant Node_Id := Prefix (N); 11029 Pref_Typ : Entity_Id := Etype (Pref); 11030 11031 -- Start of processing for Expand_N_Slice 11032 11033 begin 11034 -- Special handling for access types 11035 11036 if Is_Access_Type (Pref_Typ) then 11037 Pref_Typ := Designated_Type (Pref_Typ); 11038 11039 Rewrite (Pref, 11040 Make_Explicit_Dereference (Sloc (N), 11041 Prefix => Relocate_Node (Pref))); 11042 11043 Analyze_And_Resolve (Pref, Pref_Typ); 11044 end if; 11045 11046 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 11047 -- function, then additional actuals must be passed. 11048 11049 if Is_Build_In_Place_Function_Call (Pref) then 11050 Make_Build_In_Place_Call_In_Anonymous_Context (Pref); 11051 11052 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 11053 -- containing build-in-place function calls whose returned object covers 11054 -- interface types. 11055 11056 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then 11057 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); 11058 end if; 11059 11060 -- The remaining case to be handled is packed slices. We can leave 11061 -- packed slices as they are in the following situations: 11062 11063 -- 1. Right or left side of an assignment (we can handle this 11064 -- situation correctly in the assignment statement expansion). 11065 11066 -- 2. Prefix of indexed component (the slide is optimized away in this 11067 -- case, see the start of Expand_N_Slice.) 11068 11069 -- 3. Object renaming declaration, since we want the name of the 11070 -- slice, not the value. 11071 11072 -- 4. Argument to procedure call, since copy-in/copy-out handling may 11073 -- be required, and this is handled in the expansion of call 11074 -- itself. 11075 11076 -- 5. Prefix of an address attribute (this is an error which is caught 11077 -- elsewhere, and the expansion would interfere with generating the 11078 -- error message) or of a size attribute (because 'Size may change 11079 -- when applied to the temporary instead of the slice directly). 11080 11081 if not Is_Packed (Typ) then 11082 11083 -- Apply transformation for actuals of a function call, where 11084 -- Expand_Actuals is not used. 11085 11086 if Nkind (Parent (N)) = N_Function_Call 11087 and then Is_Possibly_Unaligned_Slice (N) 11088 then 11089 Make_Temporary_For_Slice; 11090 end if; 11091 11092 elsif Nkind (Parent (N)) = N_Assignment_Statement 11093 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement 11094 and then Parent (N) = Name (Parent (Parent (N)))) 11095 then 11096 return; 11097 11098 elsif Nkind (Parent (N)) = N_Indexed_Component 11099 or else Is_Renamed_Object (N) 11100 or else Is_Procedure_Actual (N) 11101 then 11102 return; 11103 11104 elsif Nkind (Parent (N)) = N_Attribute_Reference 11105 and then (Attribute_Name (Parent (N)) = Name_Address 11106 or else Attribute_Name (Parent (N)) = Name_Size) 11107 then 11108 return; 11109 11110 else 11111 Make_Temporary_For_Slice; 11112 end if; 11113 end Expand_N_Slice; 11114 11115 ------------------------------ 11116 -- Expand_N_Type_Conversion -- 11117 ------------------------------ 11118 11119 procedure Expand_N_Type_Conversion (N : Node_Id) is 11120 Loc : constant Source_Ptr := Sloc (N); 11121 Operand : constant Node_Id := Expression (N); 11122 Operand_Acc : Node_Id := Operand; 11123 Target_Type : Entity_Id := Etype (N); 11124 Operand_Type : Entity_Id := Etype (Operand); 11125 11126 procedure Discrete_Range_Check; 11127 -- Handles generation of range check for discrete target value 11128 11129 procedure Handle_Changed_Representation; 11130 -- This is called in the case of record and array type conversions to 11131 -- see if there is a change of representation to be handled. Change of 11132 -- representation is actually handled at the assignment statement level, 11133 -- and what this procedure does is rewrite node N conversion as an 11134 -- assignment to temporary. If there is no change of representation, 11135 -- then the conversion node is unchanged. 11136 11137 procedure Raise_Accessibility_Error; 11138 -- Called when we know that an accessibility check will fail. Rewrites 11139 -- node N to an appropriate raise statement and outputs warning msgs. 11140 -- The Etype of the raise node is set to Target_Type. Note that in this 11141 -- case the rest of the processing should be skipped (i.e. the call to 11142 -- this procedure will be followed by "goto Done"). 11143 11144 procedure Real_Range_Check; 11145 -- Handles generation of range check for real target value 11146 11147 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; 11148 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully 11149 -- evaluates to True. 11150 11151 -------------------------- 11152 -- Discrete_Range_Check -- 11153 -------------------------- 11154 11155 -- Case of conversions to a discrete type. We let Generate_Range_Check 11156 -- do the heavy lifting, after converting a fixed-point operand to an 11157 -- appropriate integer type. 11158 11159 procedure Discrete_Range_Check is 11160 Expr : Node_Id; 11161 Ityp : Entity_Id; 11162 11163 begin 11164 -- Nothing to do if conversion was rewritten 11165 11166 if Nkind (N) /= N_Type_Conversion then 11167 return; 11168 end if; 11169 11170 Expr := Expression (N); 11171 11172 -- Nothing to do if range checks suppressed 11173 11174 if Range_Checks_Suppressed (Target_Type) then 11175 return; 11176 end if; 11177 11178 -- Nothing to do if expression is an entity on which checks have been 11179 -- suppressed. 11180 11181 if Is_Entity_Name (Expr) 11182 and then Range_Checks_Suppressed (Entity (Expr)) 11183 then 11184 return; 11185 end if; 11186 11187 -- Before we do a range check, we have to deal with treating 11188 -- a fixed-point operand as an integer. The way we do this 11189 -- is simply to do an unchecked conversion to an appropriate 11190 -- integer type large enough to hold the result. 11191 11192 if Is_Fixed_Point_Type (Etype (Expr)) then 11193 if Esize (Base_Type (Etype (Expr))) > Esize (Standard_Integer) then 11194 Ityp := Standard_Long_Long_Integer; 11195 else 11196 Ityp := Standard_Integer; 11197 end if; 11198 11199 Set_Do_Range_Check (Expr, False); 11200 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); 11201 end if; 11202 11203 -- Reset overflow flag, since the range check will include 11204 -- dealing with possible overflow, and generate the check. 11205 11206 Set_Do_Overflow_Check (N, False); 11207 11208 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed); 11209 end Discrete_Range_Check; 11210 11211 ----------------------------------- 11212 -- Handle_Changed_Representation -- 11213 ----------------------------------- 11214 11215 procedure Handle_Changed_Representation is 11216 Temp : Entity_Id; 11217 Decl : Node_Id; 11218 Odef : Node_Id; 11219 N_Ix : Node_Id; 11220 Cons : List_Id; 11221 11222 begin 11223 -- Nothing else to do if no change of representation 11224 11225 if Same_Representation (Operand_Type, Target_Type) then 11226 return; 11227 11228 -- The real change of representation work is done by the assignment 11229 -- statement processing. So if this type conversion is appearing as 11230 -- the expression of an assignment statement, nothing needs to be 11231 -- done to the conversion. 11232 11233 elsif Nkind (Parent (N)) = N_Assignment_Statement then 11234 return; 11235 11236 -- Otherwise we need to generate a temporary variable, and do the 11237 -- change of representation assignment into that temporary variable. 11238 -- The conversion is then replaced by a reference to this variable. 11239 11240 else 11241 Cons := No_List; 11242 11243 -- If type is unconstrained we have to add a constraint, copied 11244 -- from the actual value of the left-hand side. 11245 11246 if not Is_Constrained (Target_Type) then 11247 if Has_Discriminants (Operand_Type) then 11248 11249 -- A change of representation can only apply to untagged 11250 -- types. We need to build the constraint that applies to 11251 -- the target type, using the constraints of the operand. 11252 -- The analysis is complicated if there are both inherited 11253 -- discriminants and constrained discriminants. 11254 -- We iterate over the discriminants of the target, and 11255 -- find the discriminant of the same name: 11256 11257 -- a) If there is a corresponding discriminant in the object 11258 -- then the value is a selected component of the operand. 11259 11260 -- b) Otherwise the value of a constrained discriminant is 11261 -- found in the stored constraint of the operand. 11262 11263 declare 11264 Stored : constant Elist_Id := 11265 Stored_Constraint (Operand_Type); 11266 11267 Elmt : Elmt_Id; 11268 11269 Disc_O : Entity_Id; 11270 -- Discriminant of the operand type. Its value in the 11271 -- object is captured in a selected component. 11272 11273 Disc_S : Entity_Id; 11274 -- Stored discriminant of the operand. If present, it 11275 -- corresponds to a constrained discriminant of the 11276 -- parent type. 11277 11278 Disc_T : Entity_Id; 11279 -- Discriminant of the target type 11280 11281 begin 11282 Disc_T := First_Discriminant (Target_Type); 11283 Disc_O := First_Discriminant (Operand_Type); 11284 Disc_S := First_Stored_Discriminant (Operand_Type); 11285 11286 if Present (Stored) then 11287 Elmt := First_Elmt (Stored); 11288 else 11289 Elmt := No_Elmt; -- init to avoid warning 11290 end if; 11291 11292 Cons := New_List; 11293 while Present (Disc_T) loop 11294 if Present (Disc_O) 11295 and then Chars (Disc_T) = Chars (Disc_O) 11296 then 11297 Append_To (Cons, 11298 Make_Selected_Component (Loc, 11299 Prefix => 11300 Duplicate_Subexpr_Move_Checks (Operand), 11301 Selector_Name => 11302 Make_Identifier (Loc, Chars (Disc_O)))); 11303 Next_Discriminant (Disc_O); 11304 11305 elsif Present (Disc_S) then 11306 Append_To (Cons, New_Copy_Tree (Node (Elmt))); 11307 Next_Elmt (Elmt); 11308 end if; 11309 11310 Next_Discriminant (Disc_T); 11311 end loop; 11312 end; 11313 11314 elsif Is_Array_Type (Operand_Type) then 11315 N_Ix := First_Index (Target_Type); 11316 Cons := New_List; 11317 11318 for J in 1 .. Number_Dimensions (Operand_Type) loop 11319 11320 -- We convert the bounds explicitly. We use an unchecked 11321 -- conversion because bounds checks are done elsewhere. 11322 11323 Append_To (Cons, 11324 Make_Range (Loc, 11325 Low_Bound => 11326 Unchecked_Convert_To (Etype (N_Ix), 11327 Make_Attribute_Reference (Loc, 11328 Prefix => 11329 Duplicate_Subexpr_No_Checks 11330 (Operand, Name_Req => True), 11331 Attribute_Name => Name_First, 11332 Expressions => New_List ( 11333 Make_Integer_Literal (Loc, J)))), 11334 11335 High_Bound => 11336 Unchecked_Convert_To (Etype (N_Ix), 11337 Make_Attribute_Reference (Loc, 11338 Prefix => 11339 Duplicate_Subexpr_No_Checks 11340 (Operand, Name_Req => True), 11341 Attribute_Name => Name_Last, 11342 Expressions => New_List ( 11343 Make_Integer_Literal (Loc, J)))))); 11344 11345 Next_Index (N_Ix); 11346 end loop; 11347 end if; 11348 end if; 11349 11350 Odef := New_Occurrence_Of (Target_Type, Loc); 11351 11352 if Present (Cons) then 11353 Odef := 11354 Make_Subtype_Indication (Loc, 11355 Subtype_Mark => Odef, 11356 Constraint => 11357 Make_Index_Or_Discriminant_Constraint (Loc, 11358 Constraints => Cons)); 11359 end if; 11360 11361 Temp := Make_Temporary (Loc, 'C'); 11362 Decl := 11363 Make_Object_Declaration (Loc, 11364 Defining_Identifier => Temp, 11365 Object_Definition => Odef); 11366 11367 Set_No_Initialization (Decl, True); 11368 11369 -- Insert required actions. It is essential to suppress checks 11370 -- since we have suppressed default initialization, which means 11371 -- that the variable we create may have no discriminants. 11372 11373 Insert_Actions (N, 11374 New_List ( 11375 Decl, 11376 Make_Assignment_Statement (Loc, 11377 Name => New_Occurrence_Of (Temp, Loc), 11378 Expression => Relocate_Node (N))), 11379 Suppress => All_Checks); 11380 11381 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 11382 return; 11383 end if; 11384 end Handle_Changed_Representation; 11385 11386 ------------------------------- 11387 -- Raise_Accessibility_Error -- 11388 ------------------------------- 11389 11390 procedure Raise_Accessibility_Error is 11391 begin 11392 Error_Msg_Warn := SPARK_Mode /= On; 11393 Rewrite (N, 11394 Make_Raise_Program_Error (Sloc (N), 11395 Reason => PE_Accessibility_Check_Failed)); 11396 Set_Etype (N, Target_Type); 11397 11398 Error_Msg_N ("<<accessibility check failure", N); 11399 Error_Msg_NE ("\<<& [", N, Standard_Program_Error); 11400 end Raise_Accessibility_Error; 11401 11402 ---------------------- 11403 -- Real_Range_Check -- 11404 ---------------------- 11405 11406 -- Case of conversions to floating-point or fixed-point. If range checks 11407 -- are enabled and the target type has a range constraint, we convert: 11408 11409 -- typ (x) 11410 11411 -- to 11412 11413 -- Tnn : typ'Base := typ'Base (x); 11414 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] 11415 -- typ (Tnn) 11416 11417 -- This is necessary when there is a conversion of integer to float or 11418 -- to fixed-point to ensure that the correct checks are made. It is not 11419 -- necessary for the float-to-float case where it is enough to just set 11420 -- the Do_Range_Check flag on the expression. 11421 11422 procedure Real_Range_Check is 11423 Btyp : constant Entity_Id := Base_Type (Target_Type); 11424 Lo : constant Node_Id := Type_Low_Bound (Target_Type); 11425 Hi : constant Node_Id := Type_High_Bound (Target_Type); 11426 11427 Conv : Node_Id; 11428 Hi_Arg : Node_Id; 11429 Hi_Val : Node_Id; 11430 Lo_Arg : Node_Id; 11431 Lo_Val : Node_Id; 11432 Expr : Entity_Id; 11433 Tnn : Entity_Id; 11434 11435 begin 11436 -- Nothing to do if conversion was rewritten 11437 11438 if Nkind (N) /= N_Type_Conversion then 11439 return; 11440 end if; 11441 11442 Expr := Expression (N); 11443 11444 -- Clear the flag once for all 11445 11446 Set_Do_Range_Check (Expr, False); 11447 11448 -- Nothing to do if range checks suppressed, or target has the same 11449 -- range as the base type (or is the base type). 11450 11451 if Range_Checks_Suppressed (Target_Type) 11452 or else (Lo = Type_Low_Bound (Btyp) 11453 and then 11454 Hi = Type_High_Bound (Btyp)) 11455 then 11456 return; 11457 end if; 11458 11459 -- Nothing to do if expression is an entity on which checks have been 11460 -- suppressed. 11461 11462 if Is_Entity_Name (Expr) 11463 and then Range_Checks_Suppressed (Entity (Expr)) 11464 then 11465 return; 11466 end if; 11467 11468 -- Nothing to do if expression was rewritten into a float-to-float 11469 -- conversion, since this kind of conversion is handled elsewhere. 11470 11471 if Is_Floating_Point_Type (Etype (Expr)) 11472 and then Is_Floating_Point_Type (Target_Type) 11473 then 11474 return; 11475 end if; 11476 11477 -- Nothing to do if bounds are all static and we can tell that the 11478 -- expression is within the bounds of the target. Note that if the 11479 -- operand is of an unconstrained floating-point type, then we do 11480 -- not trust it to be in range (might be infinite) 11481 11482 declare 11483 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr)); 11484 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr)); 11485 11486 begin 11487 if (not Is_Floating_Point_Type (Etype (Expr)) 11488 or else Is_Constrained (Etype (Expr))) 11489 and then Compile_Time_Known_Value (S_Lo) 11490 and then Compile_Time_Known_Value (S_Hi) 11491 and then Compile_Time_Known_Value (Hi) 11492 and then Compile_Time_Known_Value (Lo) 11493 then 11494 declare 11495 D_Lov : constant Ureal := Expr_Value_R (Lo); 11496 D_Hiv : constant Ureal := Expr_Value_R (Hi); 11497 S_Lov : Ureal; 11498 S_Hiv : Ureal; 11499 11500 begin 11501 if Is_Real_Type (Etype (Expr)) then 11502 S_Lov := Expr_Value_R (S_Lo); 11503 S_Hiv := Expr_Value_R (S_Hi); 11504 else 11505 S_Lov := UR_From_Uint (Expr_Value (S_Lo)); 11506 S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); 11507 end if; 11508 11509 if D_Hiv > D_Lov 11510 and then S_Lov >= D_Lov 11511 and then S_Hiv <= D_Hiv 11512 then 11513 return; 11514 end if; 11515 end; 11516 end if; 11517 end; 11518 11519 -- Otherwise rewrite the conversion as described above 11520 11521 Conv := Convert_To (Btyp, Expr); 11522 11523 -- If a conversion is necessary, then copy the specific flags from 11524 -- the original one and also move the Do_Overflow_Check flag since 11525 -- this new conversion is to the base type. 11526 11527 if Nkind (Conv) = N_Type_Conversion then 11528 Set_Conversion_OK (Conv, Conversion_OK (N)); 11529 Set_Float_Truncate (Conv, Float_Truncate (N)); 11530 Set_Rounded_Result (Conv, Rounded_Result (N)); 11531 11532 if Do_Overflow_Check (N) then 11533 Set_Do_Overflow_Check (Conv); 11534 Set_Do_Overflow_Check (N, False); 11535 end if; 11536 end if; 11537 11538 Tnn := Make_Temporary (Loc, 'T', Conv); 11539 11540 -- For a conversion from Float to Fixed where the bounds of the 11541 -- fixed-point type are static, we can obtain a more accurate 11542 -- fixed-point value by converting the result of the floating- 11543 -- point expression to an appropriate integer type, and then 11544 -- performing an unchecked conversion to the target fixed-point 11545 -- type. The range check can then use the corresponding integer 11546 -- value of the bounds instead of requiring further conversions. 11547 -- This preserves the identity: 11548 11549 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val)) 11550 11551 -- which used to fail when Fix_Val was a bound of the type and 11552 -- the 'Small was not a representable number. 11553 -- This transformation requires an integer type large enough to 11554 -- accommodate a fixed-point value. This will not be the case 11555 -- in systems where Duration is larger than Long_Integer. 11556 11557 if Is_Ordinary_Fixed_Point_Type (Target_Type) 11558 and then Is_Floating_Point_Type (Etype (Expr)) 11559 and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer) 11560 and then Nkind (Lo) = N_Real_Literal 11561 and then Nkind (Hi) = N_Real_Literal 11562 then 11563 declare 11564 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv); 11565 Int_Type : Entity_Id; 11566 11567 begin 11568 -- Find an integer type of the appropriate size to perform an 11569 -- unchecked conversion to the target fixed-point type. 11570 11571 if RM_Size (Btyp) > RM_Size (Standard_Integer) then 11572 Int_Type := Standard_Long_Integer; 11573 11574 elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then 11575 Int_Type := Standard_Integer; 11576 11577 else 11578 Int_Type := Standard_Short_Integer; 11579 end if; 11580 11581 -- Generate a temporary with the integer value. Required in the 11582 -- CCG compiler to ensure that run-time checks reference this 11583 -- integer expression (instead of the resulting fixed-point 11584 -- value because fixed-point values are handled by means of 11585 -- unsigned integer types). 11586 11587 Insert_Action (N, 11588 Make_Object_Declaration (Loc, 11589 Defining_Identifier => Expr_Id, 11590 Object_Definition => New_Occurrence_Of (Int_Type, Loc), 11591 Constant_Present => True, 11592 Expression => 11593 Convert_To (Int_Type, Expression (Conv)))); 11594 11595 -- Create integer objects for range checking of result. 11596 11597 Lo_Arg := 11598 Unchecked_Convert_To 11599 (Int_Type, New_Occurrence_Of (Expr_Id, Loc)); 11600 11601 Lo_Val := 11602 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo)); 11603 11604 Hi_Arg := 11605 Unchecked_Convert_To 11606 (Int_Type, New_Occurrence_Of (Expr_Id, Loc)); 11607 11608 Hi_Val := 11609 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi)); 11610 11611 -- Rewrite conversion as an integer conversion of the 11612 -- original floating-point expression, followed by an 11613 -- unchecked conversion to the target fixed-point type. 11614 11615 Conv := 11616 Make_Unchecked_Type_Conversion (Loc, 11617 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 11618 Expression => New_Occurrence_Of (Expr_Id, Loc)); 11619 end; 11620 11621 -- All other conversions 11622 11623 else 11624 Lo_Arg := New_Occurrence_Of (Tnn, Loc); 11625 Lo_Val := 11626 Make_Attribute_Reference (Loc, 11627 Prefix => New_Occurrence_Of (Target_Type, Loc), 11628 Attribute_Name => Name_First); 11629 11630 Hi_Arg := New_Occurrence_Of (Tnn, Loc); 11631 Hi_Val := 11632 Make_Attribute_Reference (Loc, 11633 Prefix => New_Occurrence_Of (Target_Type, Loc), 11634 Attribute_Name => Name_Last); 11635 end if; 11636 11637 -- Build code for range checking. Note that checks are suppressed 11638 -- here since we don't want a recursive range check popping up. 11639 11640 Insert_Actions (N, New_List ( 11641 Make_Object_Declaration (Loc, 11642 Defining_Identifier => Tnn, 11643 Object_Definition => New_Occurrence_Of (Btyp, Loc), 11644 Constant_Present => True, 11645 Expression => Conv), 11646 11647 Make_Raise_Constraint_Error (Loc, 11648 Condition => 11649 Make_Or_Else (Loc, 11650 Left_Opnd => 11651 Make_Op_Lt (Loc, 11652 Left_Opnd => Lo_Arg, 11653 Right_Opnd => Lo_Val), 11654 11655 Right_Opnd => 11656 Make_Op_Gt (Loc, 11657 Left_Opnd => Hi_Arg, 11658 Right_Opnd => Hi_Val)), 11659 Reason => CE_Range_Check_Failed)), 11660 Suppress => All_Checks); 11661 11662 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc)); 11663 end Real_Range_Check; 11664 11665 ----------------------------- 11666 -- Has_Extra_Accessibility -- 11667 ----------------------------- 11668 11669 -- Returns true for a formal of an anonymous access type or for an Ada 11670 -- 2012-style stand-alone object of an anonymous access type. 11671 11672 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is 11673 begin 11674 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then 11675 return Present (Effective_Extra_Accessibility (Id)); 11676 else 11677 return False; 11678 end if; 11679 end Has_Extra_Accessibility; 11680 11681 -- Start of processing for Expand_N_Type_Conversion 11682 11683 begin 11684 -- First remove check marks put by the semantic analysis on the type 11685 -- conversion between array types. We need these checks, and they will 11686 -- be generated by this expansion routine, but we do not depend on these 11687 -- flags being set, and since we do intend to expand the checks in the 11688 -- front end, we don't want them on the tree passed to the back end. 11689 11690 if Is_Array_Type (Target_Type) then 11691 if Is_Constrained (Target_Type) then 11692 Set_Do_Length_Check (N, False); 11693 else 11694 Set_Do_Range_Check (Operand, False); 11695 end if; 11696 end if; 11697 11698 -- Nothing at all to do if conversion is to the identical type so remove 11699 -- the conversion completely, it is useless, except that it may carry 11700 -- an Assignment_OK attribute, which must be propagated to the operand. 11701 11702 if Operand_Type = Target_Type then 11703 if Assignment_OK (N) then 11704 Set_Assignment_OK (Operand); 11705 end if; 11706 11707 Rewrite (N, Relocate_Node (Operand)); 11708 goto Done; 11709 end if; 11710 11711 -- Nothing to do if this is the second argument of read. This is a 11712 -- "backwards" conversion that will be handled by the specialized code 11713 -- in attribute processing. 11714 11715 if Nkind (Parent (N)) = N_Attribute_Reference 11716 and then Attribute_Name (Parent (N)) = Name_Read 11717 and then Next (First (Expressions (Parent (N)))) = N 11718 then 11719 goto Done; 11720 end if; 11721 11722 -- Check for case of converting to a type that has an invariant 11723 -- associated with it. This requires an invariant check. We insert 11724 -- a call: 11725 11726 -- invariant_check (typ (expr)) 11727 11728 -- in the code, after removing side effects from the expression. 11729 -- This is clearer than replacing the conversion into an expression 11730 -- with actions, because the context may impose additional actions 11731 -- (tag checks, membership tests, etc.) that conflict with this 11732 -- rewriting (used previously). 11733 11734 -- Note: the Comes_From_Source check, and then the resetting of this 11735 -- flag prevents what would otherwise be an infinite recursion. 11736 11737 if Has_Invariants (Target_Type) 11738 and then Present (Invariant_Procedure (Target_Type)) 11739 and then Comes_From_Source (N) 11740 then 11741 Set_Comes_From_Source (N, False); 11742 Remove_Side_Effects (N); 11743 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N))); 11744 goto Done; 11745 end if; 11746 11747 -- Here if we may need to expand conversion 11748 11749 -- If the operand of the type conversion is an arithmetic operation on 11750 -- signed integers, and the based type of the signed integer type in 11751 -- question is smaller than Standard.Integer, we promote both of the 11752 -- operands to type Integer. 11753 11754 -- For example, if we have 11755 11756 -- target-type (opnd1 + opnd2) 11757 11758 -- and opnd1 and opnd2 are of type short integer, then we rewrite 11759 -- this as: 11760 11761 -- target-type (integer(opnd1) + integer(opnd2)) 11762 11763 -- We do this because we are always allowed to compute in a larger type 11764 -- if we do the right thing with the result, and in this case we are 11765 -- going to do a conversion which will do an appropriate check to make 11766 -- sure that things are in range of the target type in any case. This 11767 -- avoids some unnecessary intermediate overflows. 11768 11769 -- We might consider a similar transformation in the case where the 11770 -- target is a real type or a 64-bit integer type, and the operand 11771 -- is an arithmetic operation using a 32-bit integer type. However, 11772 -- we do not bother with this case, because it could cause significant 11773 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be 11774 -- much cheaper, but we don't want different behavior on 32-bit and 11775 -- 64-bit machines. Note that the exclusion of the 64-bit case also 11776 -- handles the configurable run-time cases where 64-bit arithmetic 11777 -- may simply be unavailable. 11778 11779 -- Note: this circuit is partially redundant with respect to the circuit 11780 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in 11781 -- the processing here. Also we still need the Checks circuit, since we 11782 -- have to be sure not to generate junk overflow checks in the first 11783 -- place, since it would be trick to remove them here. 11784 11785 if Integer_Promotion_Possible (N) then 11786 11787 -- All conditions met, go ahead with transformation 11788 11789 declare 11790 Opnd : Node_Id; 11791 L, R : Node_Id; 11792 11793 begin 11794 R := 11795 Make_Type_Conversion (Loc, 11796 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 11797 Expression => Relocate_Node (Right_Opnd (Operand))); 11798 11799 Opnd := New_Op_Node (Nkind (Operand), Loc); 11800 Set_Right_Opnd (Opnd, R); 11801 11802 if Nkind (Operand) in N_Binary_Op then 11803 L := 11804 Make_Type_Conversion (Loc, 11805 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 11806 Expression => Relocate_Node (Left_Opnd (Operand))); 11807 11808 Set_Left_Opnd (Opnd, L); 11809 end if; 11810 11811 Rewrite (N, 11812 Make_Type_Conversion (Loc, 11813 Subtype_Mark => Relocate_Node (Subtype_Mark (N)), 11814 Expression => Opnd)); 11815 11816 Analyze_And_Resolve (N, Target_Type); 11817 goto Done; 11818 end; 11819 end if; 11820 11821 -- Do validity check if validity checking operands 11822 11823 if Validity_Checks_On and Validity_Check_Operands then 11824 Ensure_Valid (Operand); 11825 end if; 11826 11827 -- Special case of converting from non-standard boolean type 11828 11829 if Is_Boolean_Type (Operand_Type) 11830 and then (Nonzero_Is_True (Operand_Type)) 11831 then 11832 Adjust_Condition (Operand); 11833 Set_Etype (Operand, Standard_Boolean); 11834 Operand_Type := Standard_Boolean; 11835 end if; 11836 11837 -- Case of converting to an access type 11838 11839 if Is_Access_Type (Target_Type) then 11840 -- In terms of accessibility rules, an anonymous access discriminant 11841 -- is not considered separate from its parent object. 11842 11843 if Nkind (Operand) = N_Selected_Component 11844 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant 11845 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 11846 then 11847 Operand_Acc := Original_Node (Prefix (Operand)); 11848 end if; 11849 11850 -- If this type conversion was internally generated by the front end 11851 -- to displace the pointer to the object to reference an interface 11852 -- type and the original node was an Unrestricted_Access attribute, 11853 -- then skip applying accessibility checks (because, according to the 11854 -- GNAT Reference Manual, this attribute is similar to 'Access except 11855 -- that all accessibility and aliased view checks are omitted). 11856 11857 if not Comes_From_Source (N) 11858 and then Is_Interface (Designated_Type (Target_Type)) 11859 and then Nkind (Original_Node (N)) = N_Attribute_Reference 11860 and then Attribute_Name (Original_Node (N)) = 11861 Name_Unrestricted_Access 11862 then 11863 null; 11864 11865 -- Apply an accessibility check when the conversion operand is an 11866 -- access parameter (or a renaming thereof), unless conversion was 11867 -- expanded from an Unchecked_ or Unrestricted_Access attribute, 11868 -- or for the actual of a class-wide interface parameter. Note that 11869 -- other checks may still need to be applied below (such as tagged 11870 -- type checks). 11871 11872 elsif Is_Entity_Name (Operand_Acc) 11873 and then Has_Extra_Accessibility (Entity (Operand_Acc)) 11874 and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type 11875 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference 11876 or else Attribute_Name (Original_Node (N)) = Name_Access) 11877 then 11878 if not Comes_From_Source (N) 11879 and then Nkind_In (Parent (N), N_Function_Call, 11880 N_Parameter_Association, 11881 N_Procedure_Call_Statement) 11882 and then Is_Interface (Designated_Type (Target_Type)) 11883 and then Is_Class_Wide_Type (Designated_Type (Target_Type)) 11884 then 11885 null; 11886 11887 else 11888 Apply_Accessibility_Check 11889 (Operand_Acc, Target_Type, Insert_Node => Operand); 11890 end if; 11891 11892 -- If the level of the operand type is statically deeper than the 11893 -- level of the target type, then force Program_Error. Note that this 11894 -- can only occur for cases where the attribute is within the body of 11895 -- an instantiation, otherwise the conversion will already have been 11896 -- rejected as illegal. 11897 11898 -- Note: warnings are issued by the analyzer for the instance cases 11899 11900 elsif In_Instance_Body 11901 11902 -- The case where the target type is an anonymous access type of 11903 -- a discriminant is excluded, because the level of such a type 11904 -- depends on the context and currently the level returned for such 11905 -- types is zero, resulting in warnings about check failures 11906 -- in certain legal cases involving class-wide interfaces as the 11907 -- designated type (some cases, such as return statements, are 11908 -- checked at run time, but not clear if these are handled right 11909 -- in general, see 3.10.2(12/2-12.5/3) ???). 11910 11911 and then 11912 not (Ekind (Target_Type) = E_Anonymous_Access_Type 11913 and then Present (Associated_Node_For_Itype (Target_Type)) 11914 and then Nkind (Associated_Node_For_Itype (Target_Type)) = 11915 N_Discriminant_Specification) 11916 and then 11917 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) 11918 then 11919 Raise_Accessibility_Error; 11920 goto Done; 11921 11922 -- When the operand is a selected access discriminant the check needs 11923 -- to be made against the level of the object denoted by the prefix 11924 -- of the selected name. Force Program_Error for this case as well 11925 -- (this accessibility violation can only happen if within the body 11926 -- of an instantiation). 11927 11928 elsif In_Instance_Body 11929 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 11930 and then Nkind (Operand) = N_Selected_Component 11931 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant 11932 and then Object_Access_Level (Operand) > 11933 Type_Access_Level (Target_Type) 11934 then 11935 Raise_Accessibility_Error; 11936 goto Done; 11937 end if; 11938 end if; 11939 11940 -- Case of conversions of tagged types and access to tagged types 11941 11942 -- When needed, that is to say when the expression is class-wide, Add 11943 -- runtime a tag check for (strict) downward conversion by using the 11944 -- membership test, generating: 11945 11946 -- [constraint_error when Operand not in Target_Type'Class] 11947 11948 -- or in the access type case 11949 11950 -- [constraint_error 11951 -- when Operand /= null 11952 -- and then Operand.all not in 11953 -- Designated_Type (Target_Type)'Class] 11954 11955 if (Is_Access_Type (Target_Type) 11956 and then Is_Tagged_Type (Designated_Type (Target_Type))) 11957 or else Is_Tagged_Type (Target_Type) 11958 then 11959 -- Do not do any expansion in the access type case if the parent is a 11960 -- renaming, since this is an error situation which will be caught by 11961 -- Sem_Ch8, and the expansion can interfere with this error check. 11962 11963 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then 11964 goto Done; 11965 end if; 11966 11967 -- Otherwise, proceed with processing tagged conversion 11968 11969 Tagged_Conversion : declare 11970 Actual_Op_Typ : Entity_Id; 11971 Actual_Targ_Typ : Entity_Id; 11972 Make_Conversion : Boolean := False; 11973 Root_Op_Typ : Entity_Id; 11974 11975 procedure Make_Tag_Check (Targ_Typ : Entity_Id); 11976 -- Create a membership check to test whether Operand is a member 11977 -- of Targ_Typ. If the original Target_Type is an access, include 11978 -- a test for null value. The check is inserted at N. 11979 11980 -------------------- 11981 -- Make_Tag_Check -- 11982 -------------------- 11983 11984 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is 11985 Cond : Node_Id; 11986 11987 begin 11988 -- Generate: 11989 -- [Constraint_Error 11990 -- when Operand /= null 11991 -- and then Operand.all not in Targ_Typ] 11992 11993 if Is_Access_Type (Target_Type) then 11994 Cond := 11995 Make_And_Then (Loc, 11996 Left_Opnd => 11997 Make_Op_Ne (Loc, 11998 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 11999 Right_Opnd => Make_Null (Loc)), 12000 12001 Right_Opnd => 12002 Make_Not_In (Loc, 12003 Left_Opnd => 12004 Make_Explicit_Dereference (Loc, 12005 Prefix => Duplicate_Subexpr_No_Checks (Operand)), 12006 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc))); 12007 12008 -- Generate: 12009 -- [Constraint_Error when Operand not in Targ_Typ] 12010 12011 else 12012 Cond := 12013 Make_Not_In (Loc, 12014 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 12015 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)); 12016 end if; 12017 12018 Insert_Action (N, 12019 Make_Raise_Constraint_Error (Loc, 12020 Condition => Cond, 12021 Reason => CE_Tag_Check_Failed), 12022 Suppress => All_Checks); 12023 end Make_Tag_Check; 12024 12025 -- Start of processing for Tagged_Conversion 12026 12027 begin 12028 -- Handle entities from the limited view 12029 12030 if Is_Access_Type (Operand_Type) then 12031 Actual_Op_Typ := 12032 Available_View (Designated_Type (Operand_Type)); 12033 else 12034 Actual_Op_Typ := Operand_Type; 12035 end if; 12036 12037 if Is_Access_Type (Target_Type) then 12038 Actual_Targ_Typ := 12039 Available_View (Designated_Type (Target_Type)); 12040 else 12041 Actual_Targ_Typ := Target_Type; 12042 end if; 12043 12044 Root_Op_Typ := Root_Type (Actual_Op_Typ); 12045 12046 -- Ada 2005 (AI-251): Handle interface type conversion 12047 12048 if Is_Interface (Actual_Op_Typ) 12049 or else 12050 Is_Interface (Actual_Targ_Typ) 12051 then 12052 Expand_Interface_Conversion (N); 12053 goto Done; 12054 end if; 12055 12056 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then 12057 12058 -- Create a runtime tag check for a downward class-wide type 12059 -- conversion. 12060 12061 if Is_Class_Wide_Type (Actual_Op_Typ) 12062 and then Actual_Op_Typ /= Actual_Targ_Typ 12063 and then Root_Op_Typ /= Actual_Targ_Typ 12064 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ, 12065 Use_Full_View => True) 12066 then 12067 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); 12068 Make_Conversion := True; 12069 end if; 12070 12071 -- AI05-0073: If the result subtype of the function is defined 12072 -- by an access_definition designating a specific tagged type 12073 -- T, a check is made that the result value is null or the tag 12074 -- of the object designated by the result value identifies T. 12075 -- Constraint_Error is raised if this check fails. 12076 12077 if Nkind (Parent (N)) = N_Simple_Return_Statement then 12078 declare 12079 Func : Entity_Id; 12080 Func_Typ : Entity_Id; 12081 12082 begin 12083 -- Climb scope stack looking for the enclosing function 12084 12085 Func := Current_Scope; 12086 while Present (Func) 12087 and then Ekind (Func) /= E_Function 12088 loop 12089 Func := Scope (Func); 12090 end loop; 12091 12092 -- The function's return subtype must be defined using 12093 -- an access definition. 12094 12095 if Nkind (Result_Definition (Parent (Func))) = 12096 N_Access_Definition 12097 then 12098 Func_Typ := Directly_Designated_Type (Etype (Func)); 12099 12100 -- The return subtype denotes a specific tagged type, 12101 -- in other words, a non class-wide type. 12102 12103 if Is_Tagged_Type (Func_Typ) 12104 and then not Is_Class_Wide_Type (Func_Typ) 12105 then 12106 Make_Tag_Check (Actual_Targ_Typ); 12107 Make_Conversion := True; 12108 end if; 12109 end if; 12110 end; 12111 end if; 12112 12113 -- We have generated a tag check for either a class-wide type 12114 -- conversion or for AI05-0073. 12115 12116 if Make_Conversion then 12117 declare 12118 Conv : Node_Id; 12119 begin 12120 Conv := 12121 Make_Unchecked_Type_Conversion (Loc, 12122 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 12123 Expression => Relocate_Node (Expression (N))); 12124 Rewrite (N, Conv); 12125 Analyze_And_Resolve (N, Target_Type); 12126 end; 12127 end if; 12128 end if; 12129 end Tagged_Conversion; 12130 12131 -- Case of other access type conversions 12132 12133 elsif Is_Access_Type (Target_Type) then 12134 Apply_Constraint_Check (Operand, Target_Type); 12135 12136 -- Case of conversions from a fixed-point type 12137 12138 -- These conversions require special expansion and processing, found in 12139 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, 12140 -- since from a semantic point of view, these are simple integer 12141 -- conversions, which do not need further processing. 12142 12143 elsif Is_Fixed_Point_Type (Operand_Type) 12144 and then not Conversion_OK (N) 12145 then 12146 -- We should never see universal fixed at this case, since the 12147 -- expansion of the constituent divide or multiply should have 12148 -- eliminated the explicit mention of universal fixed. 12149 12150 pragma Assert (Operand_Type /= Universal_Fixed); 12151 12152 -- Check for special case of the conversion to universal real that 12153 -- occurs as a result of the use of a round attribute. In this case, 12154 -- the real type for the conversion is taken from the target type of 12155 -- the Round attribute and the result must be marked as rounded. 12156 12157 if Target_Type = Universal_Real 12158 and then Nkind (Parent (N)) = N_Attribute_Reference 12159 and then Attribute_Name (Parent (N)) = Name_Round 12160 then 12161 Set_Rounded_Result (N); 12162 Set_Etype (N, Etype (Parent (N))); 12163 Target_Type := Etype (N); 12164 end if; 12165 12166 if Is_Fixed_Point_Type (Target_Type) then 12167 Expand_Convert_Fixed_To_Fixed (N); 12168 Real_Range_Check; 12169 12170 elsif Is_Integer_Type (Target_Type) then 12171 Expand_Convert_Fixed_To_Integer (N); 12172 Discrete_Range_Check; 12173 12174 else 12175 pragma Assert (Is_Floating_Point_Type (Target_Type)); 12176 Expand_Convert_Fixed_To_Float (N); 12177 Real_Range_Check; 12178 end if; 12179 12180 -- Case of conversions to a fixed-point type 12181 12182 -- These conversions require special expansion and processing, found in 12183 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, 12184 -- since from a semantic point of view, these are simple integer 12185 -- conversions, which do not need further processing. 12186 12187 elsif Is_Fixed_Point_Type (Target_Type) 12188 and then not Conversion_OK (N) 12189 then 12190 if Is_Integer_Type (Operand_Type) then 12191 Expand_Convert_Integer_To_Fixed (N); 12192 Real_Range_Check; 12193 else 12194 pragma Assert (Is_Floating_Point_Type (Operand_Type)); 12195 Expand_Convert_Float_To_Fixed (N); 12196 Real_Range_Check; 12197 end if; 12198 12199 -- Case of array conversions 12200 12201 -- Expansion of array conversions, add required length/range checks but 12202 -- only do this if there is no change of representation. For handling of 12203 -- this case, see Handle_Changed_Representation. 12204 12205 elsif Is_Array_Type (Target_Type) then 12206 if Is_Constrained (Target_Type) then 12207 Apply_Length_Check (Operand, Target_Type); 12208 else 12209 Apply_Range_Check (Operand, Target_Type); 12210 end if; 12211 12212 Handle_Changed_Representation; 12213 12214 -- Case of conversions of discriminated types 12215 12216 -- Add required discriminant checks if target is constrained. Again this 12217 -- change is skipped if we have a change of representation. 12218 12219 elsif Has_Discriminants (Target_Type) 12220 and then Is_Constrained (Target_Type) 12221 then 12222 Apply_Discriminant_Check (Operand, Target_Type); 12223 Handle_Changed_Representation; 12224 12225 -- Case of all other record conversions. The only processing required 12226 -- is to check for a change of representation requiring the special 12227 -- assignment processing. 12228 12229 elsif Is_Record_Type (Target_Type) then 12230 12231 -- Ada 2005 (AI-216): Program_Error is raised when converting from 12232 -- a derived Unchecked_Union type to an unconstrained type that is 12233 -- not Unchecked_Union if the operand lacks inferable discriminants. 12234 12235 if Is_Derived_Type (Operand_Type) 12236 and then Is_Unchecked_Union (Base_Type (Operand_Type)) 12237 and then not Is_Constrained (Target_Type) 12238 and then not Is_Unchecked_Union (Base_Type (Target_Type)) 12239 and then not Has_Inferable_Discriminants (Operand) 12240 then 12241 -- To prevent Gigi from generating illegal code, we generate a 12242 -- Program_Error node, but we give it the target type of the 12243 -- conversion (is this requirement documented somewhere ???) 12244 12245 declare 12246 PE : constant Node_Id := Make_Raise_Program_Error (Loc, 12247 Reason => PE_Unchecked_Union_Restriction); 12248 12249 begin 12250 Set_Etype (PE, Target_Type); 12251 Rewrite (N, PE); 12252 12253 end; 12254 else 12255 Handle_Changed_Representation; 12256 end if; 12257 12258 -- Case of conversions of enumeration types 12259 12260 elsif Is_Enumeration_Type (Target_Type) then 12261 12262 -- Special processing is required if there is a change of 12263 -- representation (from enumeration representation clauses). 12264 12265 if not Same_Representation (Target_Type, Operand_Type) then 12266 12267 -- Convert: x(y) to x'val (ytyp'val (y)) 12268 12269 Rewrite (N, 12270 Make_Attribute_Reference (Loc, 12271 Prefix => New_Occurrence_Of (Target_Type, Loc), 12272 Attribute_Name => Name_Val, 12273 Expressions => New_List ( 12274 Make_Attribute_Reference (Loc, 12275 Prefix => New_Occurrence_Of (Operand_Type, Loc), 12276 Attribute_Name => Name_Pos, 12277 Expressions => New_List (Operand))))); 12278 12279 Analyze_And_Resolve (N, Target_Type); 12280 end if; 12281 end if; 12282 12283 -- At this stage, either the conversion node has been transformed into 12284 -- some other equivalent expression, or left as a conversion that can be 12285 -- handled by Gigi, in the following cases: 12286 12287 -- Conversions with no change of representation or type 12288 12289 -- Numeric conversions involving integer, floating- and fixed-point 12290 -- values. Fixed-point values are allowed only if Conversion_OK is 12291 -- set, i.e. if the fixed-point values are to be treated as integers. 12292 12293 -- No other conversions should be passed to Gigi 12294 12295 -- Check: are these rules stated in sinfo??? if so, why restate here??? 12296 12297 -- The only remaining step is to generate a range check if we still have 12298 -- a type conversion at this stage and Do_Range_Check is set. Note that 12299 -- we need to deal with at most 8 out of the 9 possible cases of numeric 12300 -- conversions here, because the float-to-integer case is entirely dealt 12301 -- with by Apply_Float_Conversion_Check. 12302 12303 if Nkind (N) = N_Type_Conversion 12304 and then Do_Range_Check (Expression (N)) 12305 then 12306 -- Float-to-float conversions 12307 12308 if Is_Floating_Point_Type (Target_Type) 12309 and then Is_Floating_Point_Type (Etype (Expression (N))) 12310 then 12311 -- Reset overflow flag, since the range check will include 12312 -- dealing with possible overflow, and generate the check. 12313 12314 Set_Do_Overflow_Check (N, False); 12315 12316 Generate_Range_Check 12317 (Expression (N), Target_Type, CE_Range_Check_Failed); 12318 12319 -- Discrete-to-discrete conversions or fixed-point-to-discrete 12320 -- conversions when Conversion_OK is set. 12321 12322 elsif Is_Discrete_Type (Target_Type) 12323 and then (Is_Discrete_Type (Etype (Expression (N))) 12324 or else (Is_Fixed_Point_Type (Etype (Expression (N))) 12325 and then Conversion_OK (N))) 12326 then 12327 -- If Address is either a source type or target type, 12328 -- suppress range check to avoid typing anomalies when 12329 -- it is a visible integer type. 12330 12331 if Is_Descendant_Of_Address (Etype (Expression (N))) 12332 or else Is_Descendant_Of_Address (Target_Type) 12333 then 12334 Set_Do_Range_Check (Expression (N), False); 12335 else 12336 Discrete_Range_Check; 12337 end if; 12338 12339 -- Conversions to floating- or fixed-point when Conversion_OK is set 12340 12341 elsif Is_Floating_Point_Type (Target_Type) 12342 or else (Is_Fixed_Point_Type (Target_Type) 12343 and then Conversion_OK (N)) 12344 then 12345 Real_Range_Check; 12346 end if; 12347 end if; 12348 12349 -- Here at end of processing 12350 12351 <<Done>> 12352 -- Apply predicate check if required. Note that we can't just call 12353 -- Apply_Predicate_Check here, because the type looks right after 12354 -- the conversion and it would omit the check. The Comes_From_Source 12355 -- guard is necessary to prevent infinite recursions when we generate 12356 -- internal conversions for the purpose of checking predicates. 12357 12358 if Present (Predicate_Function (Target_Type)) 12359 and then not Predicates_Ignored (Target_Type) 12360 and then Target_Type /= Operand_Type 12361 and then Comes_From_Source (N) 12362 then 12363 declare 12364 New_Expr : constant Node_Id := Duplicate_Subexpr (N); 12365 12366 begin 12367 -- Avoid infinite recursion on the subsequent expansion of 12368 -- of the copy of the original type conversion. When needed, 12369 -- a range check has already been applied to the expression. 12370 12371 Set_Comes_From_Source (New_Expr, False); 12372 Insert_Action (N, 12373 Make_Predicate_Check (Target_Type, New_Expr), 12374 Suppress => Range_Check); 12375 end; 12376 end if; 12377 end Expand_N_Type_Conversion; 12378 12379 ----------------------------------- 12380 -- Expand_N_Unchecked_Expression -- 12381 ----------------------------------- 12382 12383 -- Remove the unchecked expression node from the tree. Its job was simply 12384 -- to make sure that its constituent expression was handled with checks 12385 -- off, and now that is done, we can remove it from the tree, and indeed 12386 -- must, since Gigi does not expect to see these nodes. 12387 12388 procedure Expand_N_Unchecked_Expression (N : Node_Id) is 12389 Exp : constant Node_Id := Expression (N); 12390 begin 12391 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); 12392 Rewrite (N, Exp); 12393 end Expand_N_Unchecked_Expression; 12394 12395 ---------------------------------------- 12396 -- Expand_N_Unchecked_Type_Conversion -- 12397 ---------------------------------------- 12398 12399 -- If this cannot be handled by Gigi and we haven't already made a 12400 -- temporary for it, do it now. 12401 12402 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is 12403 Target_Type : constant Entity_Id := Etype (N); 12404 Operand : constant Node_Id := Expression (N); 12405 Operand_Type : constant Entity_Id := Etype (Operand); 12406 12407 begin 12408 -- Nothing at all to do if conversion is to the identical type so remove 12409 -- the conversion completely, it is useless, except that it may carry 12410 -- an Assignment_OK indication which must be propagated to the operand. 12411 12412 if Operand_Type = Target_Type then 12413 12414 -- Code duplicates Expand_N_Unchecked_Expression above, factor??? 12415 12416 if Assignment_OK (N) then 12417 Set_Assignment_OK (Operand); 12418 end if; 12419 12420 Rewrite (N, Relocate_Node (Operand)); 12421 return; 12422 end if; 12423 12424 -- If we have a conversion of a compile time known value to a target 12425 -- type and the value is in range of the target type, then we can simply 12426 -- replace the construct by an integer literal of the correct type. We 12427 -- only apply this to integer types being converted. Possibly it may 12428 -- apply in other cases, but it is too much trouble to worry about. 12429 12430 -- Note that we do not do this transformation if the Kill_Range_Check 12431 -- flag is set, since then the value may be outside the expected range. 12432 -- This happens in the Normalize_Scalars case. 12433 12434 -- We also skip this if either the target or operand type is biased 12435 -- because in this case, the unchecked conversion is supposed to 12436 -- preserve the bit pattern, not the integer value. 12437 12438 if Is_Integer_Type (Target_Type) 12439 and then not Has_Biased_Representation (Target_Type) 12440 and then Is_Integer_Type (Operand_Type) 12441 and then not Has_Biased_Representation (Operand_Type) 12442 and then Compile_Time_Known_Value (Operand) 12443 and then not Kill_Range_Check (N) 12444 then 12445 declare 12446 Val : constant Uint := Expr_Value (Operand); 12447 12448 begin 12449 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) 12450 and then 12451 Compile_Time_Known_Value (Type_High_Bound (Target_Type)) 12452 and then 12453 Val >= Expr_Value (Type_Low_Bound (Target_Type)) 12454 and then 12455 Val <= Expr_Value (Type_High_Bound (Target_Type)) 12456 then 12457 Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); 12458 12459 -- If Address is the target type, just set the type to avoid a 12460 -- spurious type error on the literal when Address is a visible 12461 -- integer type. 12462 12463 if Is_Descendant_Of_Address (Target_Type) then 12464 Set_Etype (N, Target_Type); 12465 else 12466 Analyze_And_Resolve (N, Target_Type); 12467 end if; 12468 12469 return; 12470 end if; 12471 end; 12472 end if; 12473 12474 -- Generate an extra temporary for cases unsupported by the C backend 12475 12476 if Modify_Tree_For_C then 12477 declare 12478 Source : constant Node_Id := Unqual_Conv (Expression (N)); 12479 Source_Typ : Entity_Id := Get_Full_View (Etype (Source)); 12480 12481 begin 12482 if Is_Packed_Array (Source_Typ) then 12483 Source_Typ := Packed_Array_Impl_Type (Source_Typ); 12484 end if; 12485 12486 if Nkind (Source) = N_Function_Call 12487 and then (Is_Composite_Type (Etype (Source)) 12488 or else Is_Composite_Type (Target_Type)) 12489 then 12490 Force_Evaluation (Source); 12491 end if; 12492 end; 12493 end if; 12494 12495 -- Nothing to do if conversion is safe 12496 12497 if Safe_Unchecked_Type_Conversion (N) then 12498 return; 12499 end if; 12500 12501 -- Otherwise force evaluation unless Assignment_OK flag is set (this 12502 -- flag indicates ??? More comments needed here) 12503 12504 if Assignment_OK (N) then 12505 null; 12506 else 12507 Force_Evaluation (N); 12508 end if; 12509 end Expand_N_Unchecked_Type_Conversion; 12510 12511 ---------------------------- 12512 -- Expand_Record_Equality -- 12513 ---------------------------- 12514 12515 -- For non-variant records, Equality is expanded when needed into: 12516 12517 -- and then Lhs.Discr1 = Rhs.Discr1 12518 -- and then ... 12519 -- and then Lhs.Discrn = Rhs.Discrn 12520 -- and then Lhs.Cmp1 = Rhs.Cmp1 12521 -- and then ... 12522 -- and then Lhs.Cmpn = Rhs.Cmpn 12523 12524 -- The expression is folded by the back end for adjacent fields. This 12525 -- function is called for tagged record in only one occasion: for imple- 12526 -- menting predefined primitive equality (see Predefined_Primitives_Bodies) 12527 -- otherwise the primitive "=" is used directly. 12528 12529 function Expand_Record_Equality 12530 (Nod : Node_Id; 12531 Typ : Entity_Id; 12532 Lhs : Node_Id; 12533 Rhs : Node_Id; 12534 Bodies : List_Id) return Node_Id 12535 is 12536 Loc : constant Source_Ptr := Sloc (Nod); 12537 12538 Result : Node_Id; 12539 C : Entity_Id; 12540 12541 First_Time : Boolean := True; 12542 12543 function Element_To_Compare (C : Entity_Id) return Entity_Id; 12544 -- Return the next discriminant or component to compare, starting with 12545 -- C, skipping inherited components. 12546 12547 ------------------------ 12548 -- Element_To_Compare -- 12549 ------------------------ 12550 12551 function Element_To_Compare (C : Entity_Id) return Entity_Id is 12552 Comp : Entity_Id; 12553 12554 begin 12555 Comp := C; 12556 loop 12557 -- Exit loop when the next element to be compared is found, or 12558 -- there is no more such element. 12559 12560 exit when No (Comp); 12561 12562 exit when Ekind_In (Comp, E_Discriminant, E_Component) 12563 and then not ( 12564 12565 -- Skip inherited components 12566 12567 -- Note: for a tagged type, we always generate the "=" primitive 12568 -- for the base type (not on the first subtype), so the test for 12569 -- Comp /= Original_Record_Component (Comp) is True for 12570 -- inherited components only. 12571 12572 (Is_Tagged_Type (Typ) 12573 and then Comp /= Original_Record_Component (Comp)) 12574 12575 -- Skip _Tag 12576 12577 or else Chars (Comp) = Name_uTag 12578 12579 -- Skip interface elements (secondary tags???) 12580 12581 or else Is_Interface (Etype (Comp))); 12582 12583 Next_Entity (Comp); 12584 end loop; 12585 12586 return Comp; 12587 end Element_To_Compare; 12588 12589 -- Start of processing for Expand_Record_Equality 12590 12591 begin 12592 -- Generates the following code: (assuming that Typ has one Discr and 12593 -- component C2 is also a record) 12594 12595 -- Lhs.Discr1 = Rhs.Discr1 12596 -- and then Lhs.C1 = Rhs.C1 12597 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn 12598 -- and then ... 12599 -- and then Lhs.Cmpn = Rhs.Cmpn 12600 12601 Result := New_Occurrence_Of (Standard_True, Loc); 12602 C := Element_To_Compare (First_Entity (Typ)); 12603 while Present (C) loop 12604 declare 12605 New_Lhs : Node_Id; 12606 New_Rhs : Node_Id; 12607 Check : Node_Id; 12608 12609 begin 12610 if First_Time then 12611 New_Lhs := Lhs; 12612 New_Rhs := Rhs; 12613 else 12614 New_Lhs := New_Copy_Tree (Lhs); 12615 New_Rhs := New_Copy_Tree (Rhs); 12616 end if; 12617 12618 Check := 12619 Expand_Composite_Equality (Nod, Etype (C), 12620 Lhs => 12621 Make_Selected_Component (Loc, 12622 Prefix => New_Lhs, 12623 Selector_Name => New_Occurrence_Of (C, Loc)), 12624 Rhs => 12625 Make_Selected_Component (Loc, 12626 Prefix => New_Rhs, 12627 Selector_Name => New_Occurrence_Of (C, Loc)), 12628 Bodies => Bodies); 12629 12630 -- If some (sub)component is an unchecked_union, the whole 12631 -- operation will raise program error. 12632 12633 if Nkind (Check) = N_Raise_Program_Error then 12634 Result := Check; 12635 Set_Etype (Result, Standard_Boolean); 12636 exit; 12637 else 12638 if First_Time then 12639 Result := Check; 12640 12641 -- Generate logical "and" for CodePeer to simplify the 12642 -- generated code and analysis. 12643 12644 elsif CodePeer_Mode then 12645 Result := 12646 Make_Op_And (Loc, 12647 Left_Opnd => Result, 12648 Right_Opnd => Check); 12649 12650 else 12651 Result := 12652 Make_And_Then (Loc, 12653 Left_Opnd => Result, 12654 Right_Opnd => Check); 12655 end if; 12656 end if; 12657 end; 12658 12659 First_Time := False; 12660 C := Element_To_Compare (Next_Entity (C)); 12661 end loop; 12662 12663 return Result; 12664 end Expand_Record_Equality; 12665 12666 --------------------------- 12667 -- Expand_Set_Membership -- 12668 --------------------------- 12669 12670 procedure Expand_Set_Membership (N : Node_Id) is 12671 Lop : constant Node_Id := Left_Opnd (N); 12672 Alt : Node_Id; 12673 Res : Node_Id; 12674 12675 function Make_Cond (Alt : Node_Id) return Node_Id; 12676 -- If the alternative is a subtype mark, create a simple membership 12677 -- test. Otherwise create an equality test for it. 12678 12679 --------------- 12680 -- Make_Cond -- 12681 --------------- 12682 12683 function Make_Cond (Alt : Node_Id) return Node_Id is 12684 Cond : Node_Id; 12685 L : constant Node_Id := New_Copy_Tree (Lop); 12686 R : constant Node_Id := Relocate_Node (Alt); 12687 12688 begin 12689 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) 12690 or else Nkind (Alt) = N_Range 12691 then 12692 Cond := 12693 Make_In (Sloc (Alt), 12694 Left_Opnd => L, 12695 Right_Opnd => R); 12696 else 12697 Cond := 12698 Make_Op_Eq (Sloc (Alt), 12699 Left_Opnd => L, 12700 Right_Opnd => R); 12701 end if; 12702 12703 return Cond; 12704 end Make_Cond; 12705 12706 -- Start of processing for Expand_Set_Membership 12707 12708 begin 12709 Remove_Side_Effects (Lop); 12710 12711 Alt := Last (Alternatives (N)); 12712 Res := Make_Cond (Alt); 12713 12714 Prev (Alt); 12715 while Present (Alt) loop 12716 Res := 12717 Make_Or_Else (Sloc (Alt), 12718 Left_Opnd => Make_Cond (Alt), 12719 Right_Opnd => Res); 12720 Prev (Alt); 12721 end loop; 12722 12723 Rewrite (N, Res); 12724 Analyze_And_Resolve (N, Standard_Boolean); 12725 end Expand_Set_Membership; 12726 12727 ----------------------------------- 12728 -- Expand_Short_Circuit_Operator -- 12729 ----------------------------------- 12730 12731 -- Deal with special expansion if actions are present for the right operand 12732 -- and deal with optimizing case of arguments being True or False. We also 12733 -- deal with the special case of non-standard boolean values. 12734 12735 procedure Expand_Short_Circuit_Operator (N : Node_Id) is 12736 Loc : constant Source_Ptr := Sloc (N); 12737 Typ : constant Entity_Id := Etype (N); 12738 Left : constant Node_Id := Left_Opnd (N); 12739 Right : constant Node_Id := Right_Opnd (N); 12740 LocR : constant Source_Ptr := Sloc (Right); 12741 Actlist : List_Id; 12742 12743 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; 12744 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); 12745 -- If Left = Shortcut_Value then Right need not be evaluated 12746 12747 function Make_Test_Expr (Opnd : Node_Id) return Node_Id; 12748 -- For Opnd a boolean expression, return a Boolean expression equivalent 12749 -- to Opnd /= Shortcut_Value. 12750 12751 function Useful (Actions : List_Id) return Boolean; 12752 -- Return True if Actions is not empty and contains useful nodes to 12753 -- process. 12754 12755 -------------------- 12756 -- Make_Test_Expr -- 12757 -------------------- 12758 12759 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is 12760 begin 12761 if Shortcut_Value then 12762 return Make_Op_Not (Sloc (Opnd), Opnd); 12763 else 12764 return Opnd; 12765 end if; 12766 end Make_Test_Expr; 12767 12768 ------------ 12769 -- Useful -- 12770 ------------ 12771 12772 function Useful (Actions : List_Id) return Boolean is 12773 L : Node_Id; 12774 begin 12775 if Present (Actions) then 12776 L := First (Actions); 12777 12778 -- For now "useful" means not N_Variable_Reference_Marker. 12779 -- Consider stripping other nodes in the future. 12780 12781 while Present (L) loop 12782 if Nkind (L) /= N_Variable_Reference_Marker then 12783 return True; 12784 end if; 12785 12786 Next (L); 12787 end loop; 12788 end if; 12789 12790 return False; 12791 end Useful; 12792 12793 -- Local variables 12794 12795 Op_Var : Entity_Id; 12796 -- Entity for a temporary variable holding the value of the operator, 12797 -- used for expansion in the case where actions are present. 12798 12799 -- Start of processing for Expand_Short_Circuit_Operator 12800 12801 begin 12802 -- Deal with non-standard booleans 12803 12804 if Is_Boolean_Type (Typ) then 12805 Adjust_Condition (Left); 12806 Adjust_Condition (Right); 12807 Set_Etype (N, Standard_Boolean); 12808 end if; 12809 12810 -- Check for cases where left argument is known to be True or False 12811 12812 if Compile_Time_Known_Value (Left) then 12813 12814 -- Mark SCO for left condition as compile time known 12815 12816 if Generate_SCO and then Comes_From_Source (Left) then 12817 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); 12818 end if; 12819 12820 -- Rewrite True AND THEN Right / False OR ELSE Right to Right. 12821 -- Any actions associated with Right will be executed unconditionally 12822 -- and can thus be inserted into the tree unconditionally. 12823 12824 if Expr_Value_E (Left) /= Shortcut_Ent then 12825 if Present (Actions (N)) then 12826 Insert_Actions (N, Actions (N)); 12827 end if; 12828 12829 Rewrite (N, Right); 12830 12831 -- Rewrite False AND THEN Right / True OR ELSE Right to Left. 12832 -- In this case we can forget the actions associated with Right, 12833 -- since they will never be executed. 12834 12835 else 12836 Kill_Dead_Code (Right); 12837 Kill_Dead_Code (Actions (N)); 12838 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 12839 end if; 12840 12841 Adjust_Result_Type (N, Typ); 12842 return; 12843 end if; 12844 12845 -- If Actions are present for the right operand, we have to do some 12846 -- special processing. We can't just let these actions filter back into 12847 -- code preceding the short circuit (which is what would have happened 12848 -- if we had not trapped them in the short-circuit form), since they 12849 -- must only be executed if the right operand of the short circuit is 12850 -- executed and not otherwise. 12851 12852 if Useful (Actions (N)) then 12853 Actlist := Actions (N); 12854 12855 -- The old approach is to expand: 12856 12857 -- left AND THEN right 12858 12859 -- into 12860 12861 -- C : Boolean := False; 12862 -- IF left THEN 12863 -- Actions; 12864 -- IF right THEN 12865 -- C := True; 12866 -- END IF; 12867 -- END IF; 12868 12869 -- and finally rewrite the operator into a reference to C. Similarly 12870 -- for left OR ELSE right, with negated values. Note that this 12871 -- rewrite causes some difficulties for coverage analysis because 12872 -- of the introduction of the new variable C, which obscures the 12873 -- structure of the test. 12874 12875 -- We use this "old approach" if Minimize_Expression_With_Actions 12876 -- is True. 12877 12878 if Minimize_Expression_With_Actions then 12879 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); 12880 12881 Insert_Action (N, 12882 Make_Object_Declaration (Loc, 12883 Defining_Identifier => Op_Var, 12884 Object_Definition => 12885 New_Occurrence_Of (Standard_Boolean, Loc), 12886 Expression => 12887 New_Occurrence_Of (Shortcut_Ent, Loc))); 12888 12889 Append_To (Actlist, 12890 Make_Implicit_If_Statement (Right, 12891 Condition => Make_Test_Expr (Right), 12892 Then_Statements => New_List ( 12893 Make_Assignment_Statement (LocR, 12894 Name => New_Occurrence_Of (Op_Var, LocR), 12895 Expression => 12896 New_Occurrence_Of 12897 (Boolean_Literals (not Shortcut_Value), LocR))))); 12898 12899 Insert_Action (N, 12900 Make_Implicit_If_Statement (Left, 12901 Condition => Make_Test_Expr (Left), 12902 Then_Statements => Actlist)); 12903 12904 Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); 12905 Analyze_And_Resolve (N, Standard_Boolean); 12906 12907 -- The new approach (the default) is to use an 12908 -- Expression_With_Actions node for the right operand of the 12909 -- short-circuit form. Note that this solves the traceability 12910 -- problems for coverage analysis. 12911 12912 else 12913 Rewrite (Right, 12914 Make_Expression_With_Actions (LocR, 12915 Expression => Relocate_Node (Right), 12916 Actions => Actlist)); 12917 12918 Set_Actions (N, No_List); 12919 Analyze_And_Resolve (Right, Standard_Boolean); 12920 end if; 12921 12922 Adjust_Result_Type (N, Typ); 12923 return; 12924 end if; 12925 12926 -- No actions present, check for cases of right argument True/False 12927 12928 if Compile_Time_Known_Value (Right) then 12929 12930 -- Mark SCO for left condition as compile time known 12931 12932 if Generate_SCO and then Comes_From_Source (Right) then 12933 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); 12934 end if; 12935 12936 -- Change (Left and then True), (Left or else False) to Left. Note 12937 -- that we know there are no actions associated with the right 12938 -- operand, since we just checked for this case above. 12939 12940 if Expr_Value_E (Right) /= Shortcut_Ent then 12941 Rewrite (N, Left); 12942 12943 -- Change (Left and then False), (Left or else True) to Right, 12944 -- making sure to preserve any side effects associated with the Left 12945 -- operand. 12946 12947 else 12948 Remove_Side_Effects (Left); 12949 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 12950 end if; 12951 end if; 12952 12953 Adjust_Result_Type (N, Typ); 12954 end Expand_Short_Circuit_Operator; 12955 12956 ------------------------------------ 12957 -- Fixup_Universal_Fixed_Operation -- 12958 ------------------------------------- 12959 12960 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is 12961 Conv : constant Node_Id := Parent (N); 12962 12963 begin 12964 -- We must have a type conversion immediately above us 12965 12966 pragma Assert (Nkind (Conv) = N_Type_Conversion); 12967 12968 -- Normally the type conversion gives our target type. The exception 12969 -- occurs in the case of the Round attribute, where the conversion 12970 -- will be to universal real, and our real type comes from the Round 12971 -- attribute (as well as an indication that we must round the result) 12972 12973 if Nkind (Parent (Conv)) = N_Attribute_Reference 12974 and then Attribute_Name (Parent (Conv)) = Name_Round 12975 then 12976 Set_Etype (N, Base_Type (Etype (Parent (Conv)))); 12977 Set_Rounded_Result (N); 12978 12979 -- Normal case where type comes from conversion above us 12980 12981 else 12982 Set_Etype (N, Base_Type (Etype (Conv))); 12983 end if; 12984 end Fixup_Universal_Fixed_Operation; 12985 12986 --------------------------------- 12987 -- Has_Inferable_Discriminants -- 12988 --------------------------------- 12989 12990 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is 12991 12992 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; 12993 -- Determines whether the left-most prefix of a selected component is a 12994 -- formal parameter in a subprogram. Assumes N is a selected component. 12995 12996 -------------------------------- 12997 -- Prefix_Is_Formal_Parameter -- 12998 -------------------------------- 12999 13000 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is 13001 Sel_Comp : Node_Id; 13002 13003 begin 13004 -- Move to the left-most prefix by climbing up the tree 13005 13006 Sel_Comp := N; 13007 while Present (Parent (Sel_Comp)) 13008 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component 13009 loop 13010 Sel_Comp := Parent (Sel_Comp); 13011 end loop; 13012 13013 return Is_Formal (Entity (Prefix (Sel_Comp))); 13014 end Prefix_Is_Formal_Parameter; 13015 13016 -- Start of processing for Has_Inferable_Discriminants 13017 13018 begin 13019 -- For selected components, the subtype of the selector must be a 13020 -- constrained Unchecked_Union. If the component is subject to a 13021 -- per-object constraint, then the enclosing object must have inferable 13022 -- discriminants. 13023 13024 if Nkind (N) = N_Selected_Component then 13025 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then 13026 13027 -- A small hack. If we have a per-object constrained selected 13028 -- component of a formal parameter, return True since we do not 13029 -- know the actual parameter association yet. 13030 13031 if Prefix_Is_Formal_Parameter (N) then 13032 return True; 13033 13034 -- Otherwise, check the enclosing object and the selector 13035 13036 else 13037 return Has_Inferable_Discriminants (Prefix (N)) 13038 and then Has_Inferable_Discriminants (Selector_Name (N)); 13039 end if; 13040 13041 -- The call to Has_Inferable_Discriminants will determine whether 13042 -- the selector has a constrained Unchecked_Union nominal type. 13043 13044 else 13045 return Has_Inferable_Discriminants (Selector_Name (N)); 13046 end if; 13047 13048 -- A qualified expression has inferable discriminants if its subtype 13049 -- mark is a constrained Unchecked_Union subtype. 13050 13051 elsif Nkind (N) = N_Qualified_Expression then 13052 return Is_Unchecked_Union (Etype (Subtype_Mark (N))) 13053 and then Is_Constrained (Etype (Subtype_Mark (N))); 13054 13055 -- For all other names, it is sufficient to have a constrained 13056 -- Unchecked_Union nominal subtype. 13057 13058 else 13059 return Is_Unchecked_Union (Base_Type (Etype (N))) 13060 and then Is_Constrained (Etype (N)); 13061 end if; 13062 end Has_Inferable_Discriminants; 13063 13064 ------------------------------- 13065 -- Insert_Dereference_Action -- 13066 ------------------------------- 13067 13068 procedure Insert_Dereference_Action (N : Node_Id) is 13069 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; 13070 -- Return true if type of P is derived from Checked_Pool; 13071 13072 ----------------------------- 13073 -- Is_Checked_Storage_Pool -- 13074 ----------------------------- 13075 13076 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is 13077 T : Entity_Id; 13078 13079 begin 13080 if No (P) then 13081 return False; 13082 end if; 13083 13084 T := Etype (P); 13085 while T /= Etype (T) loop 13086 if Is_RTE (T, RE_Checked_Pool) then 13087 return True; 13088 else 13089 T := Etype (T); 13090 end if; 13091 end loop; 13092 13093 return False; 13094 end Is_Checked_Storage_Pool; 13095 13096 -- Local variables 13097 13098 Context : constant Node_Id := Parent (N); 13099 Ptr_Typ : constant Entity_Id := Etype (N); 13100 Desig_Typ : constant Entity_Id := 13101 Available_View (Designated_Type (Ptr_Typ)); 13102 Loc : constant Source_Ptr := Sloc (N); 13103 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ); 13104 13105 Addr : Entity_Id; 13106 Alig : Entity_Id; 13107 Deref : Node_Id; 13108 Size : Entity_Id; 13109 Size_Bits : Node_Id; 13110 Stmt : Node_Id; 13111 13112 -- Start of processing for Insert_Dereference_Action 13113 13114 begin 13115 pragma Assert (Nkind (Context) = N_Explicit_Dereference); 13116 13117 -- Do not re-expand a dereference which has already been processed by 13118 -- this routine. 13119 13120 if Has_Dereference_Action (Context) then 13121 return; 13122 13123 -- Do not perform this type of expansion for internally-generated 13124 -- dereferences. 13125 13126 elsif not Comes_From_Source (Original_Node (Context)) then 13127 return; 13128 13129 -- A dereference action is only applicable to objects which have been 13130 -- allocated on a checked pool. 13131 13132 elsif not Is_Checked_Storage_Pool (Pool) then 13133 return; 13134 end if; 13135 13136 -- Extract the address of the dereferenced object. Generate: 13137 13138 -- Addr : System.Address := <N>'Pool_Address; 13139 13140 Addr := Make_Temporary (Loc, 'P'); 13141 13142 Insert_Action (N, 13143 Make_Object_Declaration (Loc, 13144 Defining_Identifier => Addr, 13145 Object_Definition => 13146 New_Occurrence_Of (RTE (RE_Address), Loc), 13147 Expression => 13148 Make_Attribute_Reference (Loc, 13149 Prefix => Duplicate_Subexpr_Move_Checks (N), 13150 Attribute_Name => Name_Pool_Address))); 13151 13152 -- Calculate the size of the dereferenced object. Generate: 13153 13154 -- Size : Storage_Count := <N>.all'Size / Storage_Unit; 13155 13156 Deref := 13157 Make_Explicit_Dereference (Loc, 13158 Prefix => Duplicate_Subexpr_Move_Checks (N)); 13159 Set_Has_Dereference_Action (Deref); 13160 13161 Size_Bits := 13162 Make_Attribute_Reference (Loc, 13163 Prefix => Deref, 13164 Attribute_Name => Name_Size); 13165 13166 -- Special case of an unconstrained array: need to add descriptor size 13167 13168 if Is_Array_Type (Desig_Typ) 13169 and then not Is_Constrained (First_Subtype (Desig_Typ)) 13170 then 13171 Size_Bits := 13172 Make_Op_Add (Loc, 13173 Left_Opnd => 13174 Make_Attribute_Reference (Loc, 13175 Prefix => 13176 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc), 13177 Attribute_Name => Name_Descriptor_Size), 13178 Right_Opnd => Size_Bits); 13179 end if; 13180 13181 Size := Make_Temporary (Loc, 'S'); 13182 Insert_Action (N, 13183 Make_Object_Declaration (Loc, 13184 Defining_Identifier => Size, 13185 Object_Definition => 13186 New_Occurrence_Of (RTE (RE_Storage_Count), Loc), 13187 Expression => 13188 Make_Op_Divide (Loc, 13189 Left_Opnd => Size_Bits, 13190 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); 13191 13192 -- Calculate the alignment of the dereferenced object. Generate: 13193 -- Alig : constant Storage_Count := <N>.all'Alignment; 13194 13195 Deref := 13196 Make_Explicit_Dereference (Loc, 13197 Prefix => Duplicate_Subexpr_Move_Checks (N)); 13198 Set_Has_Dereference_Action (Deref); 13199 13200 Alig := Make_Temporary (Loc, 'A'); 13201 Insert_Action (N, 13202 Make_Object_Declaration (Loc, 13203 Defining_Identifier => Alig, 13204 Object_Definition => 13205 New_Occurrence_Of (RTE (RE_Storage_Count), Loc), 13206 Expression => 13207 Make_Attribute_Reference (Loc, 13208 Prefix => Deref, 13209 Attribute_Name => Name_Alignment))); 13210 13211 -- A dereference of a controlled object requires special processing. The 13212 -- finalization machinery requests additional space from the underlying 13213 -- pool to allocate and hide two pointers. As a result, a checked pool 13214 -- may mark the wrong memory as valid. Since checked pools do not have 13215 -- knowledge of hidden pointers, we have to bring the two pointers back 13216 -- in view in order to restore the original state of the object. 13217 13218 -- The address manipulation is not performed for access types that are 13219 -- subject to pragma No_Heap_Finalization because the two pointers do 13220 -- not exist in the first place. 13221 13222 if No_Heap_Finalization (Ptr_Typ) then 13223 null; 13224 13225 elsif Needs_Finalization (Desig_Typ) then 13226 13227 -- Adjust the address and size of the dereferenced object. Generate: 13228 -- Adjust_Controlled_Dereference (Addr, Size, Alig); 13229 13230 Stmt := 13231 Make_Procedure_Call_Statement (Loc, 13232 Name => 13233 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc), 13234 Parameter_Associations => New_List ( 13235 New_Occurrence_Of (Addr, Loc), 13236 New_Occurrence_Of (Size, Loc), 13237 New_Occurrence_Of (Alig, Loc))); 13238 13239 -- Class-wide types complicate things because we cannot determine 13240 -- statically whether the actual object is truly controlled. We must 13241 -- generate a runtime check to detect this property. Generate: 13242 -- 13243 -- if Needs_Finalization (<N>.all'Tag) then 13244 -- <Stmt>; 13245 -- end if; 13246 13247 if Is_Class_Wide_Type (Desig_Typ) then 13248 Deref := 13249 Make_Explicit_Dereference (Loc, 13250 Prefix => Duplicate_Subexpr_Move_Checks (N)); 13251 Set_Has_Dereference_Action (Deref); 13252 13253 Stmt := 13254 Make_Implicit_If_Statement (N, 13255 Condition => 13256 Make_Function_Call (Loc, 13257 Name => 13258 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc), 13259 Parameter_Associations => New_List ( 13260 Make_Attribute_Reference (Loc, 13261 Prefix => Deref, 13262 Attribute_Name => Name_Tag))), 13263 Then_Statements => New_List (Stmt)); 13264 end if; 13265 13266 Insert_Action (N, Stmt); 13267 end if; 13268 13269 -- Generate: 13270 -- Dereference (Pool, Addr, Size, Alig); 13271 13272 Insert_Action (N, 13273 Make_Procedure_Call_Statement (Loc, 13274 Name => 13275 New_Occurrence_Of 13276 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), 13277 Parameter_Associations => New_List ( 13278 New_Occurrence_Of (Pool, Loc), 13279 New_Occurrence_Of (Addr, Loc), 13280 New_Occurrence_Of (Size, Loc), 13281 New_Occurrence_Of (Alig, Loc)))); 13282 13283 -- Mark the explicit dereference as processed to avoid potential 13284 -- infinite expansion. 13285 13286 Set_Has_Dereference_Action (Context); 13287 13288 exception 13289 when RE_Not_Available => 13290 return; 13291 end Insert_Dereference_Action; 13292 13293 -------------------------------- 13294 -- Integer_Promotion_Possible -- 13295 -------------------------------- 13296 13297 function Integer_Promotion_Possible (N : Node_Id) return Boolean is 13298 Operand : constant Node_Id := Expression (N); 13299 Operand_Type : constant Entity_Id := Etype (Operand); 13300 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); 13301 13302 begin 13303 pragma Assert (Nkind (N) = N_Type_Conversion); 13304 13305 return 13306 13307 -- We only do the transformation for source constructs. We assume 13308 -- that the expander knows what it is doing when it generates code. 13309 13310 Comes_From_Source (N) 13311 13312 -- If the operand type is Short_Integer or Short_Short_Integer, 13313 -- then we will promote to Integer, which is available on all 13314 -- targets, and is sufficient to ensure no intermediate overflow. 13315 -- Furthermore it is likely to be as efficient or more efficient 13316 -- than using the smaller type for the computation so we do this 13317 -- unconditionally. 13318 13319 and then 13320 (Root_Operand_Type = Base_Type (Standard_Short_Integer) 13321 or else 13322 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) 13323 13324 -- Test for interesting operation, which includes addition, 13325 -- division, exponentiation, multiplication, subtraction, absolute 13326 -- value and unary negation. Unary "+" is omitted since it is a 13327 -- no-op and thus can't overflow. 13328 13329 and then Nkind_In (Operand, N_Op_Abs, 13330 N_Op_Add, 13331 N_Op_Divide, 13332 N_Op_Expon, 13333 N_Op_Minus, 13334 N_Op_Multiply, 13335 N_Op_Subtract); 13336 end Integer_Promotion_Possible; 13337 13338 ------------------------------ 13339 -- Make_Array_Comparison_Op -- 13340 ------------------------------ 13341 13342 -- This is a hand-coded expansion of the following generic function: 13343 13344 -- generic 13345 -- type elem is (<>); 13346 -- type index is (<>); 13347 -- type a is array (index range <>) of elem; 13348 13349 -- function Gnnn (X : a; Y: a) return boolean is 13350 -- J : index := Y'first; 13351 13352 -- begin 13353 -- if X'length = 0 then 13354 -- return false; 13355 13356 -- elsif Y'length = 0 then 13357 -- return true; 13358 13359 -- else 13360 -- for I in X'range loop 13361 -- if X (I) = Y (J) then 13362 -- if J = Y'last then 13363 -- exit; 13364 -- else 13365 -- J := index'succ (J); 13366 -- end if; 13367 13368 -- else 13369 -- return X (I) > Y (J); 13370 -- end if; 13371 -- end loop; 13372 13373 -- return X'length > Y'length; 13374 -- end if; 13375 -- end Gnnn; 13376 13377 -- Note that since we are essentially doing this expansion by hand, we 13378 -- do not need to generate an actual or formal generic part, just the 13379 -- instantiated function itself. 13380 13381 -- Perhaps we could have the actual generic available in the run-time, 13382 -- obtained by rtsfind, and actually expand a real instantiation ??? 13383 13384 function Make_Array_Comparison_Op 13385 (Typ : Entity_Id; 13386 Nod : Node_Id) return Node_Id 13387 is 13388 Loc : constant Source_Ptr := Sloc (Nod); 13389 13390 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); 13391 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); 13392 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); 13393 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 13394 13395 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); 13396 13397 Loop_Statement : Node_Id; 13398 Loop_Body : Node_Id; 13399 If_Stat : Node_Id; 13400 Inner_If : Node_Id; 13401 Final_Expr : Node_Id; 13402 Func_Body : Node_Id; 13403 Func_Name : Entity_Id; 13404 Formals : List_Id; 13405 Length1 : Node_Id; 13406 Length2 : Node_Id; 13407 13408 begin 13409 -- if J = Y'last then 13410 -- exit; 13411 -- else 13412 -- J := index'succ (J); 13413 -- end if; 13414 13415 Inner_If := 13416 Make_Implicit_If_Statement (Nod, 13417 Condition => 13418 Make_Op_Eq (Loc, 13419 Left_Opnd => New_Occurrence_Of (J, Loc), 13420 Right_Opnd => 13421 Make_Attribute_Reference (Loc, 13422 Prefix => New_Occurrence_Of (Y, Loc), 13423 Attribute_Name => Name_Last)), 13424 13425 Then_Statements => New_List ( 13426 Make_Exit_Statement (Loc)), 13427 13428 Else_Statements => 13429 New_List ( 13430 Make_Assignment_Statement (Loc, 13431 Name => New_Occurrence_Of (J, Loc), 13432 Expression => 13433 Make_Attribute_Reference (Loc, 13434 Prefix => New_Occurrence_Of (Index, Loc), 13435 Attribute_Name => Name_Succ, 13436 Expressions => New_List (New_Occurrence_Of (J, Loc)))))); 13437 13438 -- if X (I) = Y (J) then 13439 -- if ... end if; 13440 -- else 13441 -- return X (I) > Y (J); 13442 -- end if; 13443 13444 Loop_Body := 13445 Make_Implicit_If_Statement (Nod, 13446 Condition => 13447 Make_Op_Eq (Loc, 13448 Left_Opnd => 13449 Make_Indexed_Component (Loc, 13450 Prefix => New_Occurrence_Of (X, Loc), 13451 Expressions => New_List (New_Occurrence_Of (I, Loc))), 13452 13453 Right_Opnd => 13454 Make_Indexed_Component (Loc, 13455 Prefix => New_Occurrence_Of (Y, Loc), 13456 Expressions => New_List (New_Occurrence_Of (J, Loc)))), 13457 13458 Then_Statements => New_List (Inner_If), 13459 13460 Else_Statements => New_List ( 13461 Make_Simple_Return_Statement (Loc, 13462 Expression => 13463 Make_Op_Gt (Loc, 13464 Left_Opnd => 13465 Make_Indexed_Component (Loc, 13466 Prefix => New_Occurrence_Of (X, Loc), 13467 Expressions => New_List (New_Occurrence_Of (I, Loc))), 13468 13469 Right_Opnd => 13470 Make_Indexed_Component (Loc, 13471 Prefix => New_Occurrence_Of (Y, Loc), 13472 Expressions => New_List ( 13473 New_Occurrence_Of (J, Loc))))))); 13474 13475 -- for I in X'range loop 13476 -- if ... end if; 13477 -- end loop; 13478 13479 Loop_Statement := 13480 Make_Implicit_Loop_Statement (Nod, 13481 Identifier => Empty, 13482 13483 Iteration_Scheme => 13484 Make_Iteration_Scheme (Loc, 13485 Loop_Parameter_Specification => 13486 Make_Loop_Parameter_Specification (Loc, 13487 Defining_Identifier => I, 13488 Discrete_Subtype_Definition => 13489 Make_Attribute_Reference (Loc, 13490 Prefix => New_Occurrence_Of (X, Loc), 13491 Attribute_Name => Name_Range))), 13492 13493 Statements => New_List (Loop_Body)); 13494 13495 -- if X'length = 0 then 13496 -- return false; 13497 -- elsif Y'length = 0 then 13498 -- return true; 13499 -- else 13500 -- for ... loop ... end loop; 13501 -- return X'length > Y'length; 13502 -- end if; 13503 13504 Length1 := 13505 Make_Attribute_Reference (Loc, 13506 Prefix => New_Occurrence_Of (X, Loc), 13507 Attribute_Name => Name_Length); 13508 13509 Length2 := 13510 Make_Attribute_Reference (Loc, 13511 Prefix => New_Occurrence_Of (Y, Loc), 13512 Attribute_Name => Name_Length); 13513 13514 Final_Expr := 13515 Make_Op_Gt (Loc, 13516 Left_Opnd => Length1, 13517 Right_Opnd => Length2); 13518 13519 If_Stat := 13520 Make_Implicit_If_Statement (Nod, 13521 Condition => 13522 Make_Op_Eq (Loc, 13523 Left_Opnd => 13524 Make_Attribute_Reference (Loc, 13525 Prefix => New_Occurrence_Of (X, Loc), 13526 Attribute_Name => Name_Length), 13527 Right_Opnd => 13528 Make_Integer_Literal (Loc, 0)), 13529 13530 Then_Statements => 13531 New_List ( 13532 Make_Simple_Return_Statement (Loc, 13533 Expression => New_Occurrence_Of (Standard_False, Loc))), 13534 13535 Elsif_Parts => New_List ( 13536 Make_Elsif_Part (Loc, 13537 Condition => 13538 Make_Op_Eq (Loc, 13539 Left_Opnd => 13540 Make_Attribute_Reference (Loc, 13541 Prefix => New_Occurrence_Of (Y, Loc), 13542 Attribute_Name => Name_Length), 13543 Right_Opnd => 13544 Make_Integer_Literal (Loc, 0)), 13545 13546 Then_Statements => 13547 New_List ( 13548 Make_Simple_Return_Statement (Loc, 13549 Expression => New_Occurrence_Of (Standard_True, Loc))))), 13550 13551 Else_Statements => New_List ( 13552 Loop_Statement, 13553 Make_Simple_Return_Statement (Loc, 13554 Expression => Final_Expr))); 13555 13556 -- (X : a; Y: a) 13557 13558 Formals := New_List ( 13559 Make_Parameter_Specification (Loc, 13560 Defining_Identifier => X, 13561 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 13562 13563 Make_Parameter_Specification (Loc, 13564 Defining_Identifier => Y, 13565 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 13566 13567 -- function Gnnn (...) return boolean is 13568 -- J : index := Y'first; 13569 -- begin 13570 -- if ... end if; 13571 -- end Gnnn; 13572 13573 Func_Name := Make_Temporary (Loc, 'G'); 13574 13575 Func_Body := 13576 Make_Subprogram_Body (Loc, 13577 Specification => 13578 Make_Function_Specification (Loc, 13579 Defining_Unit_Name => Func_Name, 13580 Parameter_Specifications => Formals, 13581 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 13582 13583 Declarations => New_List ( 13584 Make_Object_Declaration (Loc, 13585 Defining_Identifier => J, 13586 Object_Definition => New_Occurrence_Of (Index, Loc), 13587 Expression => 13588 Make_Attribute_Reference (Loc, 13589 Prefix => New_Occurrence_Of (Y, Loc), 13590 Attribute_Name => Name_First))), 13591 13592 Handled_Statement_Sequence => 13593 Make_Handled_Sequence_Of_Statements (Loc, 13594 Statements => New_List (If_Stat))); 13595 13596 return Func_Body; 13597 end Make_Array_Comparison_Op; 13598 13599 --------------------------- 13600 -- Make_Boolean_Array_Op -- 13601 --------------------------- 13602 13603 -- For logical operations on boolean arrays, expand in line the following, 13604 -- replacing 'and' with 'or' or 'xor' where needed: 13605 13606 -- function Annn (A : typ; B: typ) return typ is 13607 -- C : typ; 13608 -- begin 13609 -- for J in A'range loop 13610 -- C (J) := A (J) op B (J); 13611 -- end loop; 13612 -- return C; 13613 -- end Annn; 13614 13615 -- Here typ is the boolean array type 13616 13617 function Make_Boolean_Array_Op 13618 (Typ : Entity_Id; 13619 N : Node_Id) return Node_Id 13620 is 13621 Loc : constant Source_Ptr := Sloc (N); 13622 13623 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 13624 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 13625 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); 13626 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 13627 13628 A_J : Node_Id; 13629 B_J : Node_Id; 13630 C_J : Node_Id; 13631 Op : Node_Id; 13632 13633 Formals : List_Id; 13634 Func_Name : Entity_Id; 13635 Func_Body : Node_Id; 13636 Loop_Statement : Node_Id; 13637 13638 begin 13639 A_J := 13640 Make_Indexed_Component (Loc, 13641 Prefix => New_Occurrence_Of (A, Loc), 13642 Expressions => New_List (New_Occurrence_Of (J, Loc))); 13643 13644 B_J := 13645 Make_Indexed_Component (Loc, 13646 Prefix => New_Occurrence_Of (B, Loc), 13647 Expressions => New_List (New_Occurrence_Of (J, Loc))); 13648 13649 C_J := 13650 Make_Indexed_Component (Loc, 13651 Prefix => New_Occurrence_Of (C, Loc), 13652 Expressions => New_List (New_Occurrence_Of (J, Loc))); 13653 13654 if Nkind (N) = N_Op_And then 13655 Op := 13656 Make_Op_And (Loc, 13657 Left_Opnd => A_J, 13658 Right_Opnd => B_J); 13659 13660 elsif Nkind (N) = N_Op_Or then 13661 Op := 13662 Make_Op_Or (Loc, 13663 Left_Opnd => A_J, 13664 Right_Opnd => B_J); 13665 13666 else 13667 Op := 13668 Make_Op_Xor (Loc, 13669 Left_Opnd => A_J, 13670 Right_Opnd => B_J); 13671 end if; 13672 13673 Loop_Statement := 13674 Make_Implicit_Loop_Statement (N, 13675 Identifier => Empty, 13676 13677 Iteration_Scheme => 13678 Make_Iteration_Scheme (Loc, 13679 Loop_Parameter_Specification => 13680 Make_Loop_Parameter_Specification (Loc, 13681 Defining_Identifier => J, 13682 Discrete_Subtype_Definition => 13683 Make_Attribute_Reference (Loc, 13684 Prefix => New_Occurrence_Of (A, Loc), 13685 Attribute_Name => Name_Range))), 13686 13687 Statements => New_List ( 13688 Make_Assignment_Statement (Loc, 13689 Name => C_J, 13690 Expression => Op))); 13691 13692 Formals := New_List ( 13693 Make_Parameter_Specification (Loc, 13694 Defining_Identifier => A, 13695 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 13696 13697 Make_Parameter_Specification (Loc, 13698 Defining_Identifier => B, 13699 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 13700 13701 Func_Name := Make_Temporary (Loc, 'A'); 13702 Set_Is_Inlined (Func_Name); 13703 13704 Func_Body := 13705 Make_Subprogram_Body (Loc, 13706 Specification => 13707 Make_Function_Specification (Loc, 13708 Defining_Unit_Name => Func_Name, 13709 Parameter_Specifications => Formals, 13710 Result_Definition => New_Occurrence_Of (Typ, Loc)), 13711 13712 Declarations => New_List ( 13713 Make_Object_Declaration (Loc, 13714 Defining_Identifier => C, 13715 Object_Definition => New_Occurrence_Of (Typ, Loc))), 13716 13717 Handled_Statement_Sequence => 13718 Make_Handled_Sequence_Of_Statements (Loc, 13719 Statements => New_List ( 13720 Loop_Statement, 13721 Make_Simple_Return_Statement (Loc, 13722 Expression => New_Occurrence_Of (C, Loc))))); 13723 13724 return Func_Body; 13725 end Make_Boolean_Array_Op; 13726 13727 ----------------------------------------- 13728 -- Minimized_Eliminated_Overflow_Check -- 13729 ----------------------------------------- 13730 13731 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is 13732 begin 13733 return 13734 Is_Signed_Integer_Type (Etype (N)) 13735 and then Overflow_Check_Mode in Minimized_Or_Eliminated; 13736 end Minimized_Eliminated_Overflow_Check; 13737 13738 -------------------------------- 13739 -- Optimize_Length_Comparison -- 13740 -------------------------------- 13741 13742 procedure Optimize_Length_Comparison (N : Node_Id) is 13743 Loc : constant Source_Ptr := Sloc (N); 13744 Typ : constant Entity_Id := Etype (N); 13745 Result : Node_Id; 13746 13747 Left : Node_Id; 13748 Right : Node_Id; 13749 -- First and Last attribute reference nodes, which end up as left and 13750 -- right operands of the optimized result. 13751 13752 Is_Zero : Boolean; 13753 -- True for comparison operand of zero 13754 13755 Comp : Node_Id; 13756 -- Comparison operand, set only if Is_Zero is false 13757 13758 Ent : Entity_Id := Empty; 13759 -- Entity whose length is being compared 13760 13761 Index : Node_Id := Empty; 13762 -- Integer_Literal node for length attribute expression, or Empty 13763 -- if there is no such expression present. 13764 13765 Ityp : Entity_Id; 13766 -- Type of array index to which 'Length is applied 13767 13768 Op : Node_Kind := Nkind (N); 13769 -- Kind of comparison operator, gets flipped if operands backwards 13770 13771 function Is_Optimizable (N : Node_Id) return Boolean; 13772 -- Tests N to see if it is an optimizable comparison value (defined as 13773 -- constant zero or one, or something else where the value is known to 13774 -- be positive and in the range of 32-bits, and where the corresponding 13775 -- Length value is also known to be 32-bits. If result is true, sets 13776 -- Is_Zero, Ityp, and Comp accordingly. 13777 13778 function Is_Entity_Length (N : Node_Id) return Boolean; 13779 -- Tests if N is a length attribute applied to a simple entity. If so, 13780 -- returns True, and sets Ent to the entity, and Index to the integer 13781 -- literal provided as an attribute expression, or to Empty if none. 13782 -- Also returns True if the expression is a generated type conversion 13783 -- whose expression is of the desired form. This latter case arises 13784 -- when Apply_Universal_Integer_Attribute_Check installs a conversion 13785 -- to check for being in range, which is not needed in this context. 13786 -- Returns False if neither condition holds. 13787 13788 function Prepare_64 (N : Node_Id) return Node_Id; 13789 -- Given a discrete expression, returns a Long_Long_Integer typed 13790 -- expression representing the underlying value of the expression. 13791 -- This is done with an unchecked conversion to the result type. We 13792 -- use unchecked conversion to handle the enumeration type case. 13793 13794 ---------------------- 13795 -- Is_Entity_Length -- 13796 ---------------------- 13797 13798 function Is_Entity_Length (N : Node_Id) return Boolean is 13799 begin 13800 if Nkind (N) = N_Attribute_Reference 13801 and then Attribute_Name (N) = Name_Length 13802 and then Is_Entity_Name (Prefix (N)) 13803 then 13804 Ent := Entity (Prefix (N)); 13805 13806 if Present (Expressions (N)) then 13807 Index := First (Expressions (N)); 13808 else 13809 Index := Empty; 13810 end if; 13811 13812 return True; 13813 13814 elsif Nkind (N) = N_Type_Conversion 13815 and then not Comes_From_Source (N) 13816 then 13817 return Is_Entity_Length (Expression (N)); 13818 13819 else 13820 return False; 13821 end if; 13822 end Is_Entity_Length; 13823 13824 -------------------- 13825 -- Is_Optimizable -- 13826 -------------------- 13827 13828 function Is_Optimizable (N : Node_Id) return Boolean is 13829 Val : Uint; 13830 OK : Boolean; 13831 Lo : Uint; 13832 Hi : Uint; 13833 Indx : Node_Id; 13834 13835 begin 13836 if Compile_Time_Known_Value (N) then 13837 Val := Expr_Value (N); 13838 13839 if Val = Uint_0 then 13840 Is_Zero := True; 13841 Comp := Empty; 13842 return True; 13843 13844 elsif Val = Uint_1 then 13845 Is_Zero := False; 13846 Comp := Empty; 13847 return True; 13848 end if; 13849 end if; 13850 13851 -- Here we have to make sure of being within 32-bits 13852 13853 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); 13854 13855 if not OK 13856 or else Lo < Uint_1 13857 or else Hi > UI_From_Int (Int'Last) 13858 then 13859 return False; 13860 end if; 13861 13862 -- Comparison value was within range, so now we must check the index 13863 -- value to make sure it is also within 32-bits. 13864 13865 Indx := First_Index (Etype (Ent)); 13866 13867 if Present (Index) then 13868 for J in 2 .. UI_To_Int (Intval (Index)) loop 13869 Next_Index (Indx); 13870 end loop; 13871 end if; 13872 13873 Ityp := Etype (Indx); 13874 13875 if Esize (Ityp) > 32 then 13876 return False; 13877 end if; 13878 13879 Is_Zero := False; 13880 Comp := N; 13881 return True; 13882 end Is_Optimizable; 13883 13884 ---------------- 13885 -- Prepare_64 -- 13886 ---------------- 13887 13888 function Prepare_64 (N : Node_Id) return Node_Id is 13889 begin 13890 return Unchecked_Convert_To (Standard_Long_Long_Integer, N); 13891 end Prepare_64; 13892 13893 -- Start of processing for Optimize_Length_Comparison 13894 13895 begin 13896 -- Nothing to do if not a comparison 13897 13898 if Op not in N_Op_Compare then 13899 return; 13900 end if; 13901 13902 -- Nothing to do if special -gnatd.P debug flag set. 13903 13904 if Debug_Flag_Dot_PP then 13905 return; 13906 end if; 13907 13908 -- Ent'Length op 0/1 13909 13910 if Is_Entity_Length (Left_Opnd (N)) 13911 and then Is_Optimizable (Right_Opnd (N)) 13912 then 13913 null; 13914 13915 -- 0/1 op Ent'Length 13916 13917 elsif Is_Entity_Length (Right_Opnd (N)) 13918 and then Is_Optimizable (Left_Opnd (N)) 13919 then 13920 -- Flip comparison to opposite sense 13921 13922 case Op is 13923 when N_Op_Lt => Op := N_Op_Gt; 13924 when N_Op_Le => Op := N_Op_Ge; 13925 when N_Op_Gt => Op := N_Op_Lt; 13926 when N_Op_Ge => Op := N_Op_Le; 13927 when others => null; 13928 end case; 13929 13930 -- Else optimization not possible 13931 13932 else 13933 return; 13934 end if; 13935 13936 -- Fall through if we will do the optimization 13937 13938 -- Cases to handle: 13939 13940 -- X'Length = 0 => X'First > X'Last 13941 -- X'Length = 1 => X'First = X'Last 13942 -- X'Length = n => X'First + (n - 1) = X'Last 13943 13944 -- X'Length /= 0 => X'First <= X'Last 13945 -- X'Length /= 1 => X'First /= X'Last 13946 -- X'Length /= n => X'First + (n - 1) /= X'Last 13947 13948 -- X'Length >= 0 => always true, warn 13949 -- X'Length >= 1 => X'First <= X'Last 13950 -- X'Length >= n => X'First + (n - 1) <= X'Last 13951 13952 -- X'Length > 0 => X'First <= X'Last 13953 -- X'Length > 1 => X'First < X'Last 13954 -- X'Length > n => X'First + (n - 1) < X'Last 13955 13956 -- X'Length <= 0 => X'First > X'Last (warn, could be =) 13957 -- X'Length <= 1 => X'First >= X'Last 13958 -- X'Length <= n => X'First + (n - 1) >= X'Last 13959 13960 -- X'Length < 0 => always false (warn) 13961 -- X'Length < 1 => X'First > X'Last 13962 -- X'Length < n => X'First + (n - 1) > X'Last 13963 13964 -- Note: for the cases of n (not constant 0,1), we require that the 13965 -- corresponding index type be integer or shorter (i.e. not 64-bit), 13966 -- and the same for the comparison value. Then we do the comparison 13967 -- using 64-bit arithmetic (actually long long integer), so that we 13968 -- cannot have overflow intefering with the result. 13969 13970 -- First deal with warning cases 13971 13972 if Is_Zero then 13973 case Op is 13974 13975 -- X'Length >= 0 13976 13977 when N_Op_Ge => 13978 Rewrite (N, 13979 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc))); 13980 Analyze_And_Resolve (N, Typ); 13981 Warn_On_Known_Condition (N); 13982 return; 13983 13984 -- X'Length < 0 13985 13986 when N_Op_Lt => 13987 Rewrite (N, 13988 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc))); 13989 Analyze_And_Resolve (N, Typ); 13990 Warn_On_Known_Condition (N); 13991 return; 13992 13993 when N_Op_Le => 13994 if Constant_Condition_Warnings 13995 and then Comes_From_Source (Original_Node (N)) 13996 then 13997 Error_Msg_N ("could replace by ""'=""?c?", N); 13998 end if; 13999 14000 Op := N_Op_Eq; 14001 14002 when others => 14003 null; 14004 end case; 14005 end if; 14006 14007 -- Build the First reference we will use 14008 14009 Left := 14010 Make_Attribute_Reference (Loc, 14011 Prefix => New_Occurrence_Of (Ent, Loc), 14012 Attribute_Name => Name_First); 14013 14014 if Present (Index) then 14015 Set_Expressions (Left, New_List (New_Copy (Index))); 14016 end if; 14017 14018 -- If general value case, then do the addition of (n - 1), and 14019 -- also add the needed conversions to type Long_Long_Integer. 14020 14021 if Present (Comp) then 14022 Left := 14023 Make_Op_Add (Loc, 14024 Left_Opnd => Prepare_64 (Left), 14025 Right_Opnd => 14026 Make_Op_Subtract (Loc, 14027 Left_Opnd => Prepare_64 (Comp), 14028 Right_Opnd => Make_Integer_Literal (Loc, 1))); 14029 end if; 14030 14031 -- Build the Last reference we will use 14032 14033 Right := 14034 Make_Attribute_Reference (Loc, 14035 Prefix => New_Occurrence_Of (Ent, Loc), 14036 Attribute_Name => Name_Last); 14037 14038 if Present (Index) then 14039 Set_Expressions (Right, New_List (New_Copy (Index))); 14040 end if; 14041 14042 -- If general operand, convert Last reference to Long_Long_Integer 14043 14044 if Present (Comp) then 14045 Right := Prepare_64 (Right); 14046 end if; 14047 14048 -- Check for cases to optimize 14049 14050 -- X'Length = 0 => X'First > X'Last 14051 -- X'Length < 1 => X'First > X'Last 14052 -- X'Length < n => X'First + (n - 1) > X'Last 14053 14054 if (Is_Zero and then Op = N_Op_Eq) 14055 or else (not Is_Zero and then Op = N_Op_Lt) 14056 then 14057 Result := 14058 Make_Op_Gt (Loc, 14059 Left_Opnd => Left, 14060 Right_Opnd => Right); 14061 14062 -- X'Length = 1 => X'First = X'Last 14063 -- X'Length = n => X'First + (n - 1) = X'Last 14064 14065 elsif not Is_Zero and then Op = N_Op_Eq then 14066 Result := 14067 Make_Op_Eq (Loc, 14068 Left_Opnd => Left, 14069 Right_Opnd => Right); 14070 14071 -- X'Length /= 0 => X'First <= X'Last 14072 -- X'Length > 0 => X'First <= X'Last 14073 14074 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then 14075 Result := 14076 Make_Op_Le (Loc, 14077 Left_Opnd => Left, 14078 Right_Opnd => Right); 14079 14080 -- X'Length /= 1 => X'First /= X'Last 14081 -- X'Length /= n => X'First + (n - 1) /= X'Last 14082 14083 elsif not Is_Zero and then Op = N_Op_Ne then 14084 Result := 14085 Make_Op_Ne (Loc, 14086 Left_Opnd => Left, 14087 Right_Opnd => Right); 14088 14089 -- X'Length >= 1 => X'First <= X'Last 14090 -- X'Length >= n => X'First + (n - 1) <= X'Last 14091 14092 elsif not Is_Zero and then Op = N_Op_Ge then 14093 Result := 14094 Make_Op_Le (Loc, 14095 Left_Opnd => Left, 14096 Right_Opnd => Right); 14097 14098 -- X'Length > 1 => X'First < X'Last 14099 -- X'Length > n => X'First + (n = 1) < X'Last 14100 14101 elsif not Is_Zero and then Op = N_Op_Gt then 14102 Result := 14103 Make_Op_Lt (Loc, 14104 Left_Opnd => Left, 14105 Right_Opnd => Right); 14106 14107 -- X'Length <= 1 => X'First >= X'Last 14108 -- X'Length <= n => X'First + (n - 1) >= X'Last 14109 14110 elsif not Is_Zero and then Op = N_Op_Le then 14111 Result := 14112 Make_Op_Ge (Loc, 14113 Left_Opnd => Left, 14114 Right_Opnd => Right); 14115 14116 -- Should not happen at this stage 14117 14118 else 14119 raise Program_Error; 14120 end if; 14121 14122 -- Rewrite and finish up 14123 14124 Rewrite (N, Result); 14125 Analyze_And_Resolve (N, Typ); 14126 return; 14127 end Optimize_Length_Comparison; 14128 14129 -------------------------------- 14130 -- Process_If_Case_Statements -- 14131 -------------------------------- 14132 14133 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is 14134 Decl : Node_Id; 14135 14136 begin 14137 Decl := First (Stmts); 14138 while Present (Decl) loop 14139 if Nkind (Decl) = N_Object_Declaration 14140 and then Is_Finalizable_Transient (Decl, N) 14141 then 14142 Process_Transient_In_Expression (Decl, N, Stmts); 14143 end if; 14144 14145 Next (Decl); 14146 end loop; 14147 end Process_If_Case_Statements; 14148 14149 ------------------------------------- 14150 -- Process_Transient_In_Expression -- 14151 ------------------------------------- 14152 14153 procedure Process_Transient_In_Expression 14154 (Obj_Decl : Node_Id; 14155 Expr : Node_Id; 14156 Stmts : List_Id) 14157 is 14158 Loc : constant Source_Ptr := Sloc (Obj_Decl); 14159 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); 14160 14161 Hook_Context : constant Node_Id := Find_Hook_Context (Expr); 14162 -- The node on which to insert the hook as an action. This is usually 14163 -- the innermost enclosing non-transient construct. 14164 14165 Fin_Call : Node_Id; 14166 Hook_Assign : Node_Id; 14167 Hook_Clear : Node_Id; 14168 Hook_Decl : Node_Id; 14169 Hook_Insert : Node_Id; 14170 Ptr_Decl : Node_Id; 14171 14172 Fin_Context : Node_Id; 14173 -- The node after which to insert the finalization actions of the 14174 -- transient object. 14175 14176 begin 14177 pragma Assert (Nkind_In (Expr, N_Case_Expression, 14178 N_Expression_With_Actions, 14179 N_If_Expression)); 14180 14181 -- When the context is a Boolean evaluation, all three nodes capture the 14182 -- result of their computation in a local temporary: 14183 14184 -- do 14185 -- Trans_Id : Ctrl_Typ := ...; 14186 -- Result : constant Boolean := ... Trans_Id ...; 14187 -- <finalize Trans_Id> 14188 -- in Result end; 14189 14190 -- As a result, the finalization of any transient objects can safely 14191 -- take place after the result capture. 14192 14193 -- ??? could this be extended to elementary types? 14194 14195 if Is_Boolean_Type (Etype (Expr)) then 14196 Fin_Context := Last (Stmts); 14197 14198 -- Otherwise the immediate context may not be safe enough to carry 14199 -- out transient object finalization due to aliasing and nesting of 14200 -- constructs. Insert calls to [Deep_]Finalize after the innermost 14201 -- enclosing non-transient construct. 14202 14203 else 14204 Fin_Context := Hook_Context; 14205 end if; 14206 14207 -- Mark the transient object as successfully processed to avoid double 14208 -- finalization. 14209 14210 Set_Is_Finalized_Transient (Obj_Id); 14211 14212 -- Construct all the pieces necessary to hook and finalize a transient 14213 -- object. 14214 14215 Build_Transient_Object_Statements 14216 (Obj_Decl => Obj_Decl, 14217 Fin_Call => Fin_Call, 14218 Hook_Assign => Hook_Assign, 14219 Hook_Clear => Hook_Clear, 14220 Hook_Decl => Hook_Decl, 14221 Ptr_Decl => Ptr_Decl, 14222 Finalize_Obj => False); 14223 14224 -- Add the access type which provides a reference to the transient 14225 -- object. Generate: 14226 14227 -- type Ptr_Typ is access all Desig_Typ; 14228 14229 Insert_Action (Hook_Context, Ptr_Decl); 14230 14231 -- Add the temporary which acts as a hook to the transient object. 14232 -- Generate: 14233 14234 -- Hook : Ptr_Id := null; 14235 14236 Insert_Action (Hook_Context, Hook_Decl); 14237 14238 -- When the transient object is initialized by an aggregate, the hook 14239 -- must capture the object after the last aggregate assignment takes 14240 -- place. Only then is the object considered initialized. Generate: 14241 14242 -- Hook := Ptr_Typ (Obj_Id); 14243 -- <or> 14244 -- Hook := Obj_Id'Unrestricted_Access; 14245 14246 if Ekind_In (Obj_Id, E_Constant, E_Variable) 14247 and then Present (Last_Aggregate_Assignment (Obj_Id)) 14248 then 14249 Hook_Insert := Last_Aggregate_Assignment (Obj_Id); 14250 14251 -- Otherwise the hook seizes the related object immediately 14252 14253 else 14254 Hook_Insert := Obj_Decl; 14255 end if; 14256 14257 Insert_After_And_Analyze (Hook_Insert, Hook_Assign); 14258 14259 -- When the node is part of a return statement, there is no need to 14260 -- insert a finalization call, as the general finalization mechanism 14261 -- (see Build_Finalizer) would take care of the transient object on 14262 -- subprogram exit. Note that it would also be impossible to insert the 14263 -- finalization code after the return statement as this will render it 14264 -- unreachable. 14265 14266 if Nkind (Fin_Context) = N_Simple_Return_Statement then 14267 null; 14268 14269 -- Finalize the hook after the context has been evaluated. Generate: 14270 14271 -- if Hook /= null then 14272 -- [Deep_]Finalize (Hook.all); 14273 -- Hook := null; 14274 -- end if; 14275 14276 else 14277 Insert_Action_After (Fin_Context, 14278 Make_Implicit_If_Statement (Obj_Decl, 14279 Condition => 14280 Make_Op_Ne (Loc, 14281 Left_Opnd => 14282 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc), 14283 Right_Opnd => Make_Null (Loc)), 14284 14285 Then_Statements => New_List ( 14286 Fin_Call, 14287 Hook_Clear))); 14288 end if; 14289 end Process_Transient_In_Expression; 14290 14291 ------------------------ 14292 -- Rewrite_Comparison -- 14293 ------------------------ 14294 14295 procedure Rewrite_Comparison (N : Node_Id) is 14296 Typ : constant Entity_Id := Etype (N); 14297 14298 False_Result : Boolean; 14299 True_Result : Boolean; 14300 14301 begin 14302 if Nkind (N) = N_Type_Conversion then 14303 Rewrite_Comparison (Expression (N)); 14304 return; 14305 14306 elsif Nkind (N) not in N_Op_Compare then 14307 return; 14308 end if; 14309 14310 -- Determine the potential outcome of the comparison assuming that the 14311 -- operands are valid and emit a warning when the comparison evaluates 14312 -- to True or False only in the presence of invalid values. 14313 14314 Warn_On_Constant_Valid_Condition (N); 14315 14316 -- Determine the potential outcome of the comparison assuming that the 14317 -- operands are not valid. 14318 14319 Test_Comparison 14320 (Op => N, 14321 Assume_Valid => False, 14322 True_Result => True_Result, 14323 False_Result => False_Result); 14324 14325 -- The outcome is a decisive False or True, rewrite the operator 14326 14327 if False_Result or True_Result then 14328 Rewrite (N, 14329 Convert_To (Typ, 14330 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N)))); 14331 14332 Analyze_And_Resolve (N, Typ); 14333 Warn_On_Known_Condition (N); 14334 end if; 14335 end Rewrite_Comparison; 14336 14337 ---------------------------- 14338 -- Safe_In_Place_Array_Op -- 14339 ---------------------------- 14340 14341 function Safe_In_Place_Array_Op 14342 (Lhs : Node_Id; 14343 Op1 : Node_Id; 14344 Op2 : Node_Id) return Boolean 14345 is 14346 Target : Entity_Id; 14347 14348 function Is_Safe_Operand (Op : Node_Id) return Boolean; 14349 -- Operand is safe if it cannot overlap part of the target of the 14350 -- operation. If the operand and the target are identical, the operand 14351 -- is safe. The operand can be empty in the case of negation. 14352 14353 function Is_Unaliased (N : Node_Id) return Boolean; 14354 -- Check that N is a stand-alone entity 14355 14356 ------------------ 14357 -- Is_Unaliased -- 14358 ------------------ 14359 14360 function Is_Unaliased (N : Node_Id) return Boolean is 14361 begin 14362 return 14363 Is_Entity_Name (N) 14364 and then No (Address_Clause (Entity (N))) 14365 and then No (Renamed_Object (Entity (N))); 14366 end Is_Unaliased; 14367 14368 --------------------- 14369 -- Is_Safe_Operand -- 14370 --------------------- 14371 14372 function Is_Safe_Operand (Op : Node_Id) return Boolean is 14373 begin 14374 if No (Op) then 14375 return True; 14376 14377 elsif Is_Entity_Name (Op) then 14378 return Is_Unaliased (Op); 14379 14380 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then 14381 return Is_Unaliased (Prefix (Op)); 14382 14383 elsif Nkind (Op) = N_Slice then 14384 return 14385 Is_Unaliased (Prefix (Op)) 14386 and then Entity (Prefix (Op)) /= Target; 14387 14388 elsif Nkind (Op) = N_Op_Not then 14389 return Is_Safe_Operand (Right_Opnd (Op)); 14390 14391 else 14392 return False; 14393 end if; 14394 end Is_Safe_Operand; 14395 14396 -- Start of processing for Safe_In_Place_Array_Op 14397 14398 begin 14399 -- Skip this processing if the component size is different from system 14400 -- storage unit (since at least for NOT this would cause problems). 14401 14402 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then 14403 return False; 14404 14405 -- Cannot do in place stuff if non-standard Boolean representation 14406 14407 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then 14408 return False; 14409 14410 elsif not Is_Unaliased (Lhs) then 14411 return False; 14412 14413 else 14414 Target := Entity (Lhs); 14415 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); 14416 end if; 14417 end Safe_In_Place_Array_Op; 14418 14419 ----------------------- 14420 -- Tagged_Membership -- 14421 ----------------------- 14422 14423 -- There are two different cases to consider depending on whether the right 14424 -- operand is a class-wide type or not. If not we just compare the actual 14425 -- tag of the left expr to the target type tag: 14426 -- 14427 -- Left_Expr.Tag = Right_Type'Tag; 14428 -- 14429 -- If it is a class-wide type we use the RT function CW_Membership which is 14430 -- usually implemented by looking in the ancestor tables contained in the 14431 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag 14432 14433 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT 14434 -- function IW_Membership which is usually implemented by looking in the 14435 -- table of abstract interface types plus the ancestor table contained in 14436 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag 14437 14438 procedure Tagged_Membership 14439 (N : Node_Id; 14440 SCIL_Node : out Node_Id; 14441 Result : out Node_Id) 14442 is 14443 Left : constant Node_Id := Left_Opnd (N); 14444 Right : constant Node_Id := Right_Opnd (N); 14445 Loc : constant Source_Ptr := Sloc (N); 14446 14447 Full_R_Typ : Entity_Id; 14448 Left_Type : Entity_Id; 14449 New_Node : Node_Id; 14450 Right_Type : Entity_Id; 14451 Obj_Tag : Node_Id; 14452 14453 begin 14454 SCIL_Node := Empty; 14455 14456 -- Handle entities from the limited view 14457 14458 Left_Type := Available_View (Etype (Left)); 14459 Right_Type := Available_View (Etype (Right)); 14460 14461 -- In the case where the type is an access type, the test is applied 14462 -- using the designated types (needed in Ada 2012 for implicit anonymous 14463 -- access conversions, for AI05-0149). 14464 14465 if Is_Access_Type (Right_Type) then 14466 Left_Type := Designated_Type (Left_Type); 14467 Right_Type := Designated_Type (Right_Type); 14468 end if; 14469 14470 if Is_Class_Wide_Type (Left_Type) then 14471 Left_Type := Root_Type (Left_Type); 14472 end if; 14473 14474 if Is_Class_Wide_Type (Right_Type) then 14475 Full_R_Typ := Underlying_Type (Root_Type (Right_Type)); 14476 else 14477 Full_R_Typ := Underlying_Type (Right_Type); 14478 end if; 14479 14480 Obj_Tag := 14481 Make_Selected_Component (Loc, 14482 Prefix => Relocate_Node (Left), 14483 Selector_Name => 14484 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc)); 14485 14486 if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then 14487 14488 -- No need to issue a run-time check if we statically know that the 14489 -- result of this membership test is always true. For example, 14490 -- considering the following declarations: 14491 14492 -- type Iface is interface; 14493 -- type T is tagged null record; 14494 -- type DT is new T and Iface with null record; 14495 14496 -- Obj1 : T; 14497 -- Obj2 : DT; 14498 14499 -- These membership tests are always true: 14500 14501 -- Obj1 in T'Class 14502 -- Obj2 in T'Class; 14503 -- Obj2 in Iface'Class; 14504 14505 -- We do not need to handle cases where the membership is illegal. 14506 -- For example: 14507 14508 -- Obj1 in DT'Class; -- Compile time error 14509 -- Obj1 in Iface'Class; -- Compile time error 14510 14511 if not Is_Interface (Left_Type) 14512 and then not Is_Class_Wide_Type (Left_Type) 14513 and then (Is_Ancestor (Etype (Right_Type), Left_Type, 14514 Use_Full_View => True) 14515 or else (Is_Interface (Etype (Right_Type)) 14516 and then Interface_Present_In_Ancestor 14517 (Typ => Left_Type, 14518 Iface => Etype (Right_Type)))) 14519 then 14520 Result := New_Occurrence_Of (Standard_True, Loc); 14521 return; 14522 end if; 14523 14524 -- Ada 2005 (AI-251): Class-wide applied to interfaces 14525 14526 if Is_Interface (Etype (Class_Wide_Type (Right_Type))) 14527 14528 -- Support to: "Iface_CW_Typ in Typ'Class" 14529 14530 or else Is_Interface (Left_Type) 14531 then 14532 -- Issue error if IW_Membership operation not available in a 14533 -- configurable run time setting. 14534 14535 if not RTE_Available (RE_IW_Membership) then 14536 Error_Msg_CRT 14537 ("dynamic membership test on interface types", N); 14538 Result := Empty; 14539 return; 14540 end if; 14541 14542 Result := 14543 Make_Function_Call (Loc, 14544 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), 14545 Parameter_Associations => New_List ( 14546 Make_Attribute_Reference (Loc, 14547 Prefix => Obj_Tag, 14548 Attribute_Name => Name_Address), 14549 New_Occurrence_Of ( 14550 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), 14551 Loc))); 14552 14553 -- Ada 95: Normal case 14554 14555 else 14556 Build_CW_Membership (Loc, 14557 Obj_Tag_Node => Obj_Tag, 14558 Typ_Tag_Node => 14559 New_Occurrence_Of ( 14560 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc), 14561 Related_Nod => N, 14562 New_Node => New_Node); 14563 14564 -- Generate the SCIL node for this class-wide membership test. 14565 -- Done here because the previous call to Build_CW_Membership 14566 -- relocates Obj_Tag. 14567 14568 if Generate_SCIL then 14569 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); 14570 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); 14571 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); 14572 end if; 14573 14574 Result := New_Node; 14575 end if; 14576 14577 -- Right_Type is not a class-wide type 14578 14579 else 14580 -- No need to check the tag of the object if Right_Typ is abstract 14581 14582 if Is_Abstract_Type (Right_Type) then 14583 Result := New_Occurrence_Of (Standard_False, Loc); 14584 14585 else 14586 Result := 14587 Make_Op_Eq (Loc, 14588 Left_Opnd => Obj_Tag, 14589 Right_Opnd => 14590 New_Occurrence_Of 14591 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc)); 14592 end if; 14593 end if; 14594 end Tagged_Membership; 14595 14596 ------------------------------ 14597 -- Unary_Op_Validity_Checks -- 14598 ------------------------------ 14599 14600 procedure Unary_Op_Validity_Checks (N : Node_Id) is 14601 begin 14602 if Validity_Checks_On and Validity_Check_Operands then 14603 Ensure_Valid (Right_Opnd (N)); 14604 end if; 14605 end Unary_Op_Validity_Checks; 14606 14607end Exp_Ch4; 14608