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-2020, 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_Ch3; use Exp_Ch3; 35with Exp_Ch6; use Exp_Ch6; 36with Exp_Ch7; use Exp_Ch7; 37with Exp_Ch9; use Exp_Ch9; 38with Exp_Disp; use Exp_Disp; 39with Exp_Fixd; use Exp_Fixd; 40with Exp_Intr; use Exp_Intr; 41with Exp_Pakd; use Exp_Pakd; 42with Exp_Tss; use Exp_Tss; 43with Exp_Util; use Exp_Util; 44with Freeze; use Freeze; 45with Inline; use Inline; 46with Namet; use Namet; 47with Nlists; use Nlists; 48with Nmake; use Nmake; 49with Opt; use Opt; 50with Par_SCO; use Par_SCO; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Aux; use Sem_Aux; 56with Sem_Cat; use Sem_Cat; 57with Sem_Ch3; use Sem_Ch3; 58with Sem_Ch13; use Sem_Ch13; 59with Sem_Eval; use Sem_Eval; 60with Sem_Res; use Sem_Res; 61with Sem_Type; use Sem_Type; 62with Sem_Util; use Sem_Util; 63with Sem_Warn; use Sem_Warn; 64with Sinfo; use Sinfo; 65with Snames; use Snames; 66with Stand; use Stand; 67with SCIL_LL; use SCIL_LL; 68with Targparm; use Targparm; 69with Tbuild; use Tbuild; 70with Ttypes; use Ttypes; 71with Uintp; use Uintp; 72with Urealp; use Urealp; 73with Validsw; use Validsw; 74with Warnsw; use Warnsw; 75 76package body Exp_Ch4 is 77 78 ----------------------- 79 -- Local Subprograms -- 80 ----------------------- 81 82 procedure Binary_Op_Validity_Checks (N : Node_Id); 83 pragma Inline (Binary_Op_Validity_Checks); 84 -- Performs validity checks for a binary operator 85 86 procedure Build_Boolean_Array_Proc_Call 87 (N : Node_Id; 88 Op1 : Node_Id; 89 Op2 : Node_Id); 90 -- If a boolean array assignment can be done in place, build call to 91 -- corresponding library procedure. 92 93 procedure Displace_Allocator_Pointer (N : Node_Id); 94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and 95 -- Expand_Allocator_Expression. Allocating class-wide interface objects 96 -- this routine displaces the pointer to the allocated object to reference 97 -- the component referencing the corresponding secondary dispatch table. 98 99 procedure Expand_Allocator_Expression (N : Node_Id); 100 -- Subsidiary to Expand_N_Allocator, for the case when the expression 101 -- is a qualified expression. 102 103 procedure Expand_Array_Comparison (N : Node_Id); 104 -- This routine handles expansion of the comparison operators (N_Op_Lt, 105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic 106 -- code for these operators is similar, differing only in the details of 107 -- the actual comparison call that is made. Special processing (call a 108 -- run-time routine) 109 110 function Expand_Array_Equality 111 (Nod : Node_Id; 112 Lhs : Node_Id; 113 Rhs : Node_Id; 114 Bodies : List_Id; 115 Typ : Entity_Id) return Node_Id; 116 -- Expand an array equality into a call to a function implementing this 117 -- equality, and a call to it. Loc is the location for the generated nodes. 118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list 119 -- on which to attach bodies of local functions that are created in the 120 -- process. It is the responsibility of the caller to insert those bodies 121 -- at the right place. Nod provides the Sloc value for the generated code. 122 -- Normally the types used for the generated equality routine are taken 123 -- from Lhs and Rhs. However, in some situations of generated code, the 124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies 125 -- the type to be used for the formal parameters. 126 127 procedure Expand_Boolean_Operator (N : Node_Id); 128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the 129 -- case of array type arguments. 130 131 procedure Expand_Nonbinary_Modular_Op (N : Node_Id); 132 -- When generating C code, convert nonbinary modular arithmetic operations 133 -- into code that relies on the front-end expansion of operator Mod. No 134 -- expansion is performed if N is not a nonbinary modular operand. 135 136 procedure Expand_Short_Circuit_Operator (N : Node_Id); 137 -- Common expansion processing for short-circuit boolean operators 138 139 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id); 140 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is 141 -- where we allow comparison of "out of range" values. 142 143 function Expand_Composite_Equality 144 (Nod : Node_Id; 145 Typ : Entity_Id; 146 Lhs : Node_Id; 147 Rhs : Node_Id; 148 Bodies : List_Id) return Node_Id; 149 -- Local recursive function used to expand equality for nested composite 150 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which 151 -- to attach bodies of local functions that are created in the process. It 152 -- is the responsibility of the caller to insert those bodies at the right 153 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are 154 -- the left and right sides for the comparison, and Typ is the type of the 155 -- objects to compare. 156 157 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); 158 -- Routine to expand concatenation of a sequence of two or more operands 159 -- (in the list Operands) and replace node Cnode with the result of the 160 -- concatenation. The operands can be of any appropriate type, and can 161 -- include both arrays and singleton elements. 162 163 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id); 164 -- N is an N_In membership test mode, with the overflow check mode set to 165 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed 166 -- integer type. This is a case where top level processing is required to 167 -- handle overflow checks in subtrees. 168 169 procedure Fixup_Universal_Fixed_Operation (N : Node_Id); 170 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal 171 -- fixed. We do not have such a type at runtime, so the purpose of this 172 -- routine is to find the real type by looking up the tree. We also 173 -- determine if the operation must be rounded. 174 175 function Has_Inferable_Discriminants (N : Node_Id) return Boolean; 176 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable 177 -- discriminants if it has a constrained nominal type, unless the object 178 -- is a component of an enclosing Unchecked_Union object that is subject 179 -- to a per-object constraint and the enclosing object lacks inferable 180 -- discriminants. 181 -- 182 -- An expression of an Unchecked_Union type has inferable discriminants 183 -- if it is either a name of an object with inferable discriminants or a 184 -- qualified expression whose subtype mark denotes a constrained subtype. 185 186 procedure Insert_Dereference_Action (N : Node_Id); 187 -- N is an expression whose type is an access. When the type of the 188 -- associated storage pool is derived from Checked_Pool, generate a 189 -- call to the 'Dereference' primitive operation. 190 191 function Make_Array_Comparison_Op 192 (Typ : Entity_Id; 193 Nod : Node_Id) return Node_Id; 194 -- Comparisons between arrays are expanded in line. This function produces 195 -- the body of the implementation of (a > b), where a and b are one- 196 -- dimensional arrays of some discrete type. The original node is then 197 -- expanded into the appropriate call to this function. Nod provides the 198 -- Sloc value for the generated code. 199 200 function Make_Boolean_Array_Op 201 (Typ : Entity_Id; 202 N : Node_Id) return Node_Id; 203 -- Boolean operations on boolean arrays are expanded in line. This function 204 -- produce the body for the node N, which is (a and b), (a or b), or (a xor 205 -- b). It is used only the normal case and not the packed case. The type 206 -- involved, Typ, is the Boolean array type, and the logical operations in 207 -- the body are simple boolean operations. Note that Typ is always a 208 -- constrained type (the caller has ensured this by using 209 -- Convert_To_Actual_Subtype if necessary). 210 211 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean; 212 -- For signed arithmetic operations when the current overflow mode is 213 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks 214 -- as the first thing we do. We then return. We count on the recursive 215 -- apparatus for overflow checks to call us back with an equivalent 216 -- operation that is in CHECKED mode, avoiding a recursive entry into this 217 -- routine, and that is when we will proceed with the expansion of the 218 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do 219 -- these optimizations without first making this check, since there may be 220 -- operands further down the tree that are relying on the recursive calls 221 -- triggered by the top level nodes to properly process overflow checking 222 -- and remaining expansion on these nodes. Note that this call back may be 223 -- skipped if the operation is done in Bignum mode but that's fine, since 224 -- the Bignum call takes care of everything. 225 226 procedure Narrow_Large_Operation (N : Node_Id); 227 -- Try to compute the result of a large operation in a narrower type than 228 -- its nominal type. This is mainly aimed at getting rid of operations done 229 -- in Universal_Integer that can be generated for attributes. 230 231 procedure Optimize_Length_Comparison (N : Node_Id); 232 -- Given an expression, if it is of the form X'Length op N (or the other 233 -- way round), where N is known at compile time to be 0 or 1, or something 234 -- else where the value is known to be nonnegative and in the 32-bit range, 235 -- and X is a simple entity, and op is a comparison operator, optimizes it 236 -- into a comparison of X'First and X'Last. 237 238 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id); 239 -- Inspect and process statement list Stmt of if or case expression N for 240 -- transient objects. If such objects are found, the routine generates code 241 -- to clean them up when the context of the expression is evaluated. 242 243 procedure Process_Transient_In_Expression 244 (Obj_Decl : Node_Id; 245 Expr : Node_Id; 246 Stmts : List_Id); 247 -- Subsidiary routine to the expansion of expression_with_actions, if and 248 -- case expressions. Generate all necessary code to finalize a transient 249 -- object when the enclosing context is elaborated or evaluated. Obj_Decl 250 -- denotes the declaration of the transient object, which is usually the 251 -- result of a controlled function call. Expr denotes the expression with 252 -- actions, if expression, or case expression node. Stmts denotes the 253 -- statement list which contains Decl, either at the top level or within a 254 -- nested construct. 255 256 procedure Rewrite_Comparison (N : Node_Id); 257 -- If N is the node for a comparison whose outcome can be determined at 258 -- compile time, then the node N can be rewritten with True or False. If 259 -- the outcome cannot be determined at compile time, the call has no 260 -- effect. If N is a type conversion, then this processing is applied to 261 -- its expression. If N is neither comparison nor a type conversion, the 262 -- call has no effect. 263 264 procedure Tagged_Membership 265 (N : Node_Id; 266 SCIL_Node : out Node_Id; 267 Result : out Node_Id); 268 -- Construct the expression corresponding to the tagged membership test. 269 -- Deals with a second operand being (or not) a class-wide type. 270 271 function Safe_In_Place_Array_Op 272 (Lhs : Node_Id; 273 Op1 : Node_Id; 274 Op2 : Node_Id) return Boolean; 275 -- In the context of an assignment, where the right-hand side is a boolean 276 -- operation on arrays, check whether operation can be performed in place. 277 278 procedure Unary_Op_Validity_Checks (N : Node_Id); 279 pragma Inline (Unary_Op_Validity_Checks); 280 -- Performs validity checks for a unary operator 281 282 ------------------------------- 283 -- Binary_Op_Validity_Checks -- 284 ------------------------------- 285 286 procedure Binary_Op_Validity_Checks (N : Node_Id) is 287 begin 288 if Validity_Checks_On and Validity_Check_Operands then 289 Ensure_Valid (Left_Opnd (N)); 290 Ensure_Valid (Right_Opnd (N)); 291 end if; 292 end Binary_Op_Validity_Checks; 293 294 ------------------------------------ 295 -- Build_Boolean_Array_Proc_Call -- 296 ------------------------------------ 297 298 procedure Build_Boolean_Array_Proc_Call 299 (N : Node_Id; 300 Op1 : Node_Id; 301 Op2 : Node_Id) 302 is 303 Loc : constant Source_Ptr := Sloc (N); 304 Kind : constant Node_Kind := Nkind (Expression (N)); 305 Target : constant Node_Id := 306 Make_Attribute_Reference (Loc, 307 Prefix => Name (N), 308 Attribute_Name => Name_Address); 309 310 Arg1 : Node_Id := Op1; 311 Arg2 : Node_Id := Op2; 312 Call_Node : Node_Id; 313 Proc_Name : Entity_Id; 314 315 begin 316 if Kind = N_Op_Not then 317 if Nkind (Op1) in N_Binary_Op then 318 319 -- Use negated version of the binary operators 320 321 if Nkind (Op1) = N_Op_And then 322 Proc_Name := RTE (RE_Vector_Nand); 323 324 elsif Nkind (Op1) = N_Op_Or then 325 Proc_Name := RTE (RE_Vector_Nor); 326 327 else pragma Assert (Nkind (Op1) = N_Op_Xor); 328 Proc_Name := RTE (RE_Vector_Xor); 329 end if; 330 331 Call_Node := 332 Make_Procedure_Call_Statement (Loc, 333 Name => New_Occurrence_Of (Proc_Name, Loc), 334 335 Parameter_Associations => New_List ( 336 Target, 337 Make_Attribute_Reference (Loc, 338 Prefix => Left_Opnd (Op1), 339 Attribute_Name => Name_Address), 340 341 Make_Attribute_Reference (Loc, 342 Prefix => Right_Opnd (Op1), 343 Attribute_Name => Name_Address), 344 345 Make_Attribute_Reference (Loc, 346 Prefix => Left_Opnd (Op1), 347 Attribute_Name => Name_Length))); 348 349 else 350 Proc_Name := RTE (RE_Vector_Not); 351 352 Call_Node := 353 Make_Procedure_Call_Statement (Loc, 354 Name => New_Occurrence_Of (Proc_Name, Loc), 355 Parameter_Associations => New_List ( 356 Target, 357 358 Make_Attribute_Reference (Loc, 359 Prefix => Op1, 360 Attribute_Name => Name_Address), 361 362 Make_Attribute_Reference (Loc, 363 Prefix => Op1, 364 Attribute_Name => Name_Length))); 365 end if; 366 367 else 368 -- We use the following equivalences: 369 370 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) 371 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) 372 -- (not X) xor (not Y) = X xor Y 373 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) 374 375 if Nkind (Op1) = N_Op_Not then 376 Arg1 := Right_Opnd (Op1); 377 Arg2 := Right_Opnd (Op2); 378 379 if Kind = N_Op_And then 380 Proc_Name := RTE (RE_Vector_Nor); 381 elsif Kind = N_Op_Or then 382 Proc_Name := RTE (RE_Vector_Nand); 383 else 384 Proc_Name := RTE (RE_Vector_Xor); 385 end if; 386 387 else 388 if Kind = N_Op_And then 389 Proc_Name := RTE (RE_Vector_And); 390 elsif Kind = N_Op_Or then 391 Proc_Name := RTE (RE_Vector_Or); 392 elsif Nkind (Op2) = N_Op_Not then 393 Proc_Name := RTE (RE_Vector_Nxor); 394 Arg2 := Right_Opnd (Op2); 395 else 396 Proc_Name := RTE (RE_Vector_Xor); 397 end if; 398 end if; 399 400 Call_Node := 401 Make_Procedure_Call_Statement (Loc, 402 Name => New_Occurrence_Of (Proc_Name, Loc), 403 Parameter_Associations => New_List ( 404 Target, 405 Make_Attribute_Reference (Loc, 406 Prefix => Arg1, 407 Attribute_Name => Name_Address), 408 Make_Attribute_Reference (Loc, 409 Prefix => Arg2, 410 Attribute_Name => Name_Address), 411 Make_Attribute_Reference (Loc, 412 Prefix => Arg1, 413 Attribute_Name => Name_Length))); 414 end if; 415 416 Rewrite (N, Call_Node); 417 Analyze (N); 418 419 exception 420 when RE_Not_Available => 421 return; 422 end Build_Boolean_Array_Proc_Call; 423 424 ----------------------- 425 -- Build_Eq_Call -- 426 ----------------------- 427 428 function Build_Eq_Call 429 (Typ : Entity_Id; 430 Loc : Source_Ptr; 431 Lhs : Node_Id; 432 Rhs : Node_Id) return Node_Id 433 is 434 Prim : Node_Id; 435 Prim_E : Elmt_Id; 436 437 begin 438 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); 439 while Present (Prim_E) loop 440 Prim := Node (Prim_E); 441 442 -- Locate primitive equality with the right signature 443 444 if Chars (Prim) = Name_Op_Eq 445 and then Etype (First_Formal (Prim)) = 446 Etype (Next_Formal (First_Formal (Prim))) 447 and then Etype (Prim) = Standard_Boolean 448 then 449 if Is_Abstract_Subprogram (Prim) then 450 return 451 Make_Raise_Program_Error (Loc, 452 Reason => PE_Explicit_Raise); 453 454 else 455 return 456 Make_Function_Call (Loc, 457 Name => New_Occurrence_Of (Prim, Loc), 458 Parameter_Associations => New_List (Lhs, Rhs)); 459 end if; 460 end if; 461 462 Next_Elmt (Prim_E); 463 end loop; 464 465 -- If not found, predefined operation will be used 466 467 return Empty; 468 end Build_Eq_Call; 469 470 -------------------------------- 471 -- Displace_Allocator_Pointer -- 472 -------------------------------- 473 474 procedure Displace_Allocator_Pointer (N : Node_Id) is 475 Loc : constant Source_Ptr := Sloc (N); 476 Orig_Node : constant Node_Id := Original_Node (N); 477 Dtyp : Entity_Id; 478 Etyp : Entity_Id; 479 PtrT : Entity_Id; 480 481 begin 482 -- Do nothing in case of VM targets: the virtual machine will handle 483 -- interfaces directly. 484 485 if not Tagged_Type_Expansion then 486 return; 487 end if; 488 489 pragma Assert (Nkind (N) = N_Identifier 490 and then Nkind (Orig_Node) = N_Allocator); 491 492 PtrT := Etype (Orig_Node); 493 Dtyp := Available_View (Designated_Type (PtrT)); 494 Etyp := Etype (Expression (Orig_Node)); 495 496 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then 497 498 -- If the type of the allocator expression is not an interface type 499 -- we can generate code to reference the record component containing 500 -- the pointer to the secondary dispatch table. 501 502 if not Is_Interface (Etyp) then 503 declare 504 Saved_Typ : constant Entity_Id := Etype (Orig_Node); 505 506 begin 507 -- 1) Get access to the allocated object 508 509 Rewrite (N, 510 Make_Explicit_Dereference (Loc, Relocate_Node (N))); 511 Set_Etype (N, Etyp); 512 Set_Analyzed (N); 513 514 -- 2) Add the conversion to displace the pointer to reference 515 -- the secondary dispatch table. 516 517 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N))); 518 Analyze_And_Resolve (N, Dtyp); 519 520 -- 3) The 'access to the secondary dispatch table will be used 521 -- as the value returned by the allocator. 522 523 Rewrite (N, 524 Make_Attribute_Reference (Loc, 525 Prefix => Relocate_Node (N), 526 Attribute_Name => Name_Access)); 527 Set_Etype (N, Saved_Typ); 528 Set_Analyzed (N); 529 end; 530 531 -- If the type of the allocator expression is an interface type we 532 -- generate a run-time call to displace "this" to reference the 533 -- component containing the pointer to the secondary dispatch table 534 -- or else raise Constraint_Error if the actual object does not 535 -- implement the target interface. This case corresponds to the 536 -- following example: 537 538 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is 539 -- begin 540 -- return new Iface_2'Class'(Obj); 541 -- end Op; 542 543 else 544 Rewrite (N, 545 Unchecked_Convert_To (PtrT, 546 Make_Function_Call (Loc, 547 Name => New_Occurrence_Of (RTE (RE_Displace), Loc), 548 Parameter_Associations => New_List ( 549 Unchecked_Convert_To (RTE (RE_Address), 550 Relocate_Node (N)), 551 552 New_Occurrence_Of 553 (Elists.Node 554 (First_Elmt 555 (Access_Disp_Table (Etype (Base_Type (Dtyp))))), 556 Loc))))); 557 Analyze_And_Resolve (N, PtrT); 558 end if; 559 end if; 560 end Displace_Allocator_Pointer; 561 562 --------------------------------- 563 -- Expand_Allocator_Expression -- 564 --------------------------------- 565 566 procedure Expand_Allocator_Expression (N : Node_Id) is 567 Loc : constant Source_Ptr := Sloc (N); 568 Exp : constant Node_Id := Expression (Expression (N)); 569 PtrT : constant Entity_Id := Etype (N); 570 DesigT : constant Entity_Id := Designated_Type (PtrT); 571 572 procedure Apply_Accessibility_Check 573 (Ref : Node_Id; 574 Built_In_Place : Boolean := False); 575 -- Ada 2005 (AI-344): For an allocator with a class-wide designated 576 -- type, generate an accessibility check to verify that the level of the 577 -- type of the created object is not deeper than the level of the access 578 -- type. If the type of the qualified expression is class-wide, then 579 -- always generate the check (except in the case where it is known to be 580 -- unnecessary, see comment below). Otherwise, only generate the check 581 -- if the level of the qualified expression type is statically deeper 582 -- than the access type. 583 -- 584 -- Although the static accessibility will generally have been performed 585 -- as a legality check, it won't have been done in cases where the 586 -- allocator appears in generic body, so a run-time check is needed in 587 -- general. One special case is when the access type is declared in the 588 -- same scope as the class-wide allocator, in which case the check can 589 -- never fail, so it need not be generated. 590 -- 591 -- As an open issue, there seem to be cases where the static level 592 -- associated with the class-wide object's underlying type is not 593 -- sufficient to perform the proper accessibility check, such as for 594 -- allocators in nested subprograms or accept statements initialized by 595 -- class-wide formals when the actual originates outside at a deeper 596 -- static level. The nested subprogram case might require passing 597 -- accessibility levels along with class-wide parameters, and the task 598 -- case seems to be an actual gap in the language rules that needs to 599 -- be fixed by the ARG. ??? 600 601 ------------------------------- 602 -- Apply_Accessibility_Check -- 603 ------------------------------- 604 605 procedure Apply_Accessibility_Check 606 (Ref : Node_Id; 607 Built_In_Place : Boolean := False) 608 is 609 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); 610 Cond : Node_Id; 611 Fin_Call : Node_Id; 612 Free_Stmt : Node_Id; 613 Obj_Ref : Node_Id; 614 Stmts : List_Id; 615 616 begin 617 if Ada_Version >= Ada_2005 618 and then Is_Class_Wide_Type (DesigT) 619 and then Tagged_Type_Expansion 620 and then not Scope_Suppress.Suppress (Accessibility_Check) 621 and then 622 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) 623 or else 624 (Is_Class_Wide_Type (Etype (Exp)) 625 and then Scope (PtrT) /= Current_Scope)) 626 then 627 -- If the allocator was built in place, Ref is already a reference 628 -- to the access object initialized to the result of the allocator 629 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call 630 -- Remove_Side_Effects for cases where the build-in-place call may 631 -- still be the prefix of the reference (to avoid generating 632 -- duplicate calls). Otherwise, it is the entity associated with 633 -- the object containing the address of the allocated object. 634 635 if Built_In_Place then 636 Remove_Side_Effects (Ref); 637 Obj_Ref := New_Copy_Tree (Ref); 638 else 639 Obj_Ref := New_Occurrence_Of (Ref, Loc); 640 end if; 641 642 -- For access to interface types we must generate code to displace 643 -- the pointer to the base of the object since the subsequent code 644 -- references components located in the TSD of the object (which 645 -- is associated with the primary dispatch table --see a-tags.ads) 646 -- and also generates code invoking Free, which requires also a 647 -- reference to the base of the unallocated object. 648 649 if Is_Interface (DesigT) and then Tagged_Type_Expansion then 650 Obj_Ref := 651 Unchecked_Convert_To (Etype (Obj_Ref), 652 Make_Function_Call (Loc, 653 Name => 654 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 655 Parameter_Associations => New_List ( 656 Unchecked_Convert_To (RTE (RE_Address), 657 New_Copy_Tree (Obj_Ref))))); 658 end if; 659 660 -- Step 1: Create the object clean up code 661 662 Stmts := New_List; 663 664 -- Deallocate the object if the accessibility check fails. This 665 -- is done only on targets or profiles that support deallocation. 666 667 -- Free (Obj_Ref); 668 669 if RTE_Available (RE_Free) then 670 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref)); 671 Set_Storage_Pool (Free_Stmt, Pool_Id); 672 673 Append_To (Stmts, Free_Stmt); 674 675 -- The target or profile cannot deallocate objects 676 677 else 678 Free_Stmt := Empty; 679 end if; 680 681 -- Finalize the object if applicable. Generate: 682 683 -- [Deep_]Finalize (Obj_Ref.all); 684 685 if Needs_Finalization (DesigT) 686 and then not No_Heap_Finalization (PtrT) 687 then 688 Fin_Call := 689 Make_Final_Call 690 (Obj_Ref => 691 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), 692 Typ => DesigT); 693 694 -- Guard against a missing [Deep_]Finalize when the designated 695 -- type was not properly frozen. 696 697 if No (Fin_Call) then 698 Fin_Call := Make_Null_Statement (Loc); 699 end if; 700 701 -- When the target or profile supports deallocation, wrap the 702 -- finalization call in a block to ensure proper deallocation 703 -- even if finalization fails. Generate: 704 705 -- begin 706 -- <Fin_Call> 707 -- exception 708 -- when others => 709 -- <Free_Stmt> 710 -- raise; 711 -- end; 712 713 if Present (Free_Stmt) then 714 Fin_Call := 715 Make_Block_Statement (Loc, 716 Handled_Statement_Sequence => 717 Make_Handled_Sequence_Of_Statements (Loc, 718 Statements => New_List (Fin_Call), 719 720 Exception_Handlers => New_List ( 721 Make_Exception_Handler (Loc, 722 Exception_Choices => New_List ( 723 Make_Others_Choice (Loc)), 724 Statements => New_List ( 725 New_Copy_Tree (Free_Stmt), 726 Make_Raise_Statement (Loc)))))); 727 end if; 728 729 Prepend_To (Stmts, Fin_Call); 730 end if; 731 732 -- Signal the accessibility failure through a Program_Error 733 734 Append_To (Stmts, 735 Make_Raise_Program_Error (Loc, 736 Condition => New_Occurrence_Of (Standard_True, Loc), 737 Reason => PE_Accessibility_Check_Failed)); 738 739 -- Step 2: Create the accessibility comparison 740 741 -- Generate: 742 -- Ref'Tag 743 744 Obj_Ref := 745 Make_Attribute_Reference (Loc, 746 Prefix => Obj_Ref, 747 Attribute_Name => Name_Tag); 748 749 -- For tagged types, determine the accessibility level by looking 750 -- at the type specific data of the dispatch table. Generate: 751 752 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level 753 754 if Tagged_Type_Expansion then 755 Cond := Build_Get_Access_Level (Loc, Obj_Ref); 756 757 -- Use a runtime call to determine the accessibility level when 758 -- compiling on virtual machine targets. Generate: 759 760 -- Get_Access_Level (Ref'Tag) 761 762 else 763 Cond := 764 Make_Function_Call (Loc, 765 Name => 766 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc), 767 Parameter_Associations => New_List (Obj_Ref)); 768 end if; 769 770 Cond := 771 Make_Op_Gt (Loc, 772 Left_Opnd => Cond, 773 Right_Opnd => 774 Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); 775 776 -- Due to the complexity and side effects of the check, utilize an 777 -- if statement instead of the regular Program_Error circuitry. 778 779 Insert_Action (N, 780 Make_Implicit_If_Statement (N, 781 Condition => Cond, 782 Then_Statements => Stmts)); 783 end if; 784 end Apply_Accessibility_Check; 785 786 -- Local variables 787 788 Indic : constant Node_Id := Subtype_Mark (Expression (N)); 789 T : constant Entity_Id := Entity (Indic); 790 Adj_Call : Node_Id; 791 Aggr_In_Place : Boolean; 792 Node : Node_Id; 793 Tag_Assign : Node_Id; 794 Temp : Entity_Id; 795 Temp_Decl : Node_Id; 796 797 TagT : Entity_Id := Empty; 798 -- Type used as source for tag assignment 799 800 TagR : Node_Id := Empty; 801 -- Target reference for tag assignment 802 803 -- Start of processing for Expand_Allocator_Expression 804 805 begin 806 -- Handle call to C++ constructor 807 808 if Is_CPP_Constructor_Call (Exp) then 809 Make_CPP_Constructor_Call_In_Allocator 810 (Allocator => N, 811 Function_Call => Exp); 812 return; 813 end if; 814 815 -- If we have: 816 -- type A is access T1; 817 -- X : A := new T2'(...); 818 -- T1 and T2 can be different subtypes, and we might need to check 819 -- both constraints. First check against the type of the qualified 820 -- expression. 821 822 Apply_Constraint_Check (Exp, T, No_Sliding => True); 823 824 Apply_Predicate_Check (Exp, T); 825 826 -- Check that any anonymous access discriminants are suitable 827 -- for use in an allocator. 828 829 -- Note: This check is performed here instead of during analysis so that 830 -- we can check against the fully resolved etype of Exp. 831 832 if Is_Entity_Name (Exp) 833 and then Has_Anonymous_Access_Discriminant (Etype (Exp)) 834 and then Static_Accessibility_Level (Exp, Object_Decl_Level) 835 > Static_Accessibility_Level (N, Object_Decl_Level) 836 then 837 -- A dynamic check and a warning are generated when we are within 838 -- an instance. 839 840 if In_Instance then 841 Insert_Action (N, 842 Make_Raise_Program_Error (Loc, 843 Reason => PE_Accessibility_Check_Failed)); 844 845 Error_Msg_N ("anonymous access discriminant is too deep for use" 846 & " in allocator<<", N); 847 Error_Msg_N ("\Program_Error [<<", N); 848 849 -- Otherwise, make the error static 850 851 else 852 Error_Msg_N ("anonymous access discriminant is too deep for use" 853 & " in allocator", N); 854 end if; 855 end if; 856 857 if Do_Range_Check (Exp) then 858 Generate_Range_Check (Exp, T, CE_Range_Check_Failed); 859 end if; 860 861 -- A check is also needed in cases where the designated subtype is 862 -- constrained and differs from the subtype given in the qualified 863 -- expression. Note that the check on the qualified expression does 864 -- not allow sliding, but this check does (a relaxation from Ada 83). 865 866 if Is_Constrained (DesigT) 867 and then not Subtypes_Statically_Match (T, DesigT) 868 then 869 Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); 870 871 Apply_Predicate_Check (Exp, DesigT); 872 873 if Do_Range_Check (Exp) then 874 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); 875 end if; 876 end if; 877 878 if Nkind (Exp) = N_Raise_Constraint_Error then 879 Rewrite (N, New_Copy (Exp)); 880 Set_Etype (N, PtrT); 881 return; 882 end if; 883 884 Aggr_In_Place := Is_Delayed_Aggregate (Exp); 885 886 -- Case of tagged type or type requiring finalization 887 888 if Is_Tagged_Type (T) or else Needs_Finalization (T) then 889 890 -- Ada 2005 (AI-318-02): If the initialization expression is a call 891 -- to a build-in-place function, then access to the allocated object 892 -- must be passed to the function. 893 894 if Is_Build_In_Place_Function_Call (Exp) then 895 Make_Build_In_Place_Call_In_Allocator (N, Exp); 896 Apply_Accessibility_Check (N, Built_In_Place => True); 897 return; 898 899 -- Ada 2005 (AI-318-02): Specialization of the previous case for 900 -- expressions containing a build-in-place function call whose 901 -- returned object covers interface types, and Expr has calls to 902 -- Ada.Tags.Displace to displace the pointer to the returned build- 903 -- in-place object to reference the secondary dispatch table of a 904 -- covered interface type. 905 906 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then 907 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp); 908 Apply_Accessibility_Check (N, Built_In_Place => True); 909 return; 910 end if; 911 912 -- Actions inserted before: 913 -- Temp : constant ptr_T := new T'(Expression); 914 -- Temp._tag = T'tag; -- when not class-wide 915 -- [Deep_]Adjust (Temp.all); 916 917 -- We analyze by hand the new internal allocator to avoid any 918 -- recursion and inappropriate call to Initialize. 919 920 -- We don't want to remove side effects when the expression must be 921 -- built in place. In the case of a build-in-place function call, 922 -- that could lead to a duplication of the call, which was already 923 -- substituted for the allocator. 924 925 if not Aggr_In_Place then 926 Remove_Side_Effects (Exp); 927 end if; 928 929 Temp := Make_Temporary (Loc, 'P', N); 930 931 -- For a class wide allocation generate the following code: 932 933 -- type Equiv_Record is record ... end record; 934 -- implicit subtype CW is <Class_Wide_Subytpe>; 935 -- temp : PtrT := new CW'(CW!(expr)); 936 937 if Is_Class_Wide_Type (T) then 938 Expand_Subtype_From_Expr (Empty, T, Indic, Exp); 939 940 -- Ada 2005 (AI-251): If the expression is a class-wide interface 941 -- object we generate code to move up "this" to reference the 942 -- base of the object before allocating the new object. 943 944 -- Note that Exp'Address is recursively expanded into a call 945 -- to Base_Address (Exp.Tag) 946 947 if Is_Class_Wide_Type (Etype (Exp)) 948 and then Is_Interface (Etype (Exp)) 949 and then Tagged_Type_Expansion 950 then 951 Set_Expression 952 (Expression (N), 953 Unchecked_Convert_To (Entity (Indic), 954 Make_Explicit_Dereference (Loc, 955 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 956 Make_Attribute_Reference (Loc, 957 Prefix => Exp, 958 Attribute_Name => Name_Address))))); 959 else 960 Set_Expression 961 (Expression (N), 962 Unchecked_Convert_To (Entity (Indic), Exp)); 963 end if; 964 965 Analyze_And_Resolve (Expression (N), Entity (Indic)); 966 end if; 967 968 -- Processing for allocators returning non-interface types 969 970 if not Is_Interface (Directly_Designated_Type (PtrT)) then 971 if Aggr_In_Place then 972 Temp_Decl := 973 Make_Object_Declaration (Loc, 974 Defining_Identifier => Temp, 975 Object_Definition => New_Occurrence_Of (PtrT, Loc), 976 Expression => 977 Make_Allocator (Loc, 978 Expression => 979 New_Occurrence_Of (Etype (Exp), Loc))); 980 981 -- Copy the Comes_From_Source flag for the allocator we just 982 -- built, since logically this allocator is a replacement of 983 -- the original allocator node. This is for proper handling of 984 -- restriction No_Implicit_Heap_Allocations. 985 986 Preserve_Comes_From_Source 987 (Expression (Temp_Decl), N); 988 989 Set_No_Initialization (Expression (Temp_Decl)); 990 Insert_Action (N, Temp_Decl); 991 992 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 993 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 994 995 else 996 Node := Relocate_Node (N); 997 Set_Analyzed (Node); 998 999 Temp_Decl := 1000 Make_Object_Declaration (Loc, 1001 Defining_Identifier => Temp, 1002 Constant_Present => True, 1003 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1004 Expression => Node); 1005 1006 Insert_Action (N, Temp_Decl); 1007 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1008 end if; 1009 1010 -- Ada 2005 (AI-251): Handle allocators whose designated type is an 1011 -- interface type. In this case we use the type of the qualified 1012 -- expression to allocate the object. 1013 1014 else 1015 declare 1016 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 1017 New_Decl : Node_Id; 1018 1019 begin 1020 New_Decl := 1021 Make_Full_Type_Declaration (Loc, 1022 Defining_Identifier => Def_Id, 1023 Type_Definition => 1024 Make_Access_To_Object_Definition (Loc, 1025 All_Present => True, 1026 Null_Exclusion_Present => False, 1027 Constant_Present => 1028 Is_Access_Constant (Etype (N)), 1029 Subtype_Indication => 1030 New_Occurrence_Of (Etype (Exp), Loc))); 1031 1032 Insert_Action (N, New_Decl); 1033 1034 -- Inherit the allocation-related attributes from the original 1035 -- access type. 1036 1037 Set_Finalization_Master 1038 (Def_Id, Finalization_Master (PtrT)); 1039 1040 Set_Associated_Storage_Pool 1041 (Def_Id, Associated_Storage_Pool (PtrT)); 1042 1043 -- Declare the object using the previous type declaration 1044 1045 if Aggr_In_Place then 1046 Temp_Decl := 1047 Make_Object_Declaration (Loc, 1048 Defining_Identifier => Temp, 1049 Object_Definition => New_Occurrence_Of (Def_Id, Loc), 1050 Expression => 1051 Make_Allocator (Loc, 1052 New_Occurrence_Of (Etype (Exp), Loc))); 1053 1054 -- Copy the Comes_From_Source flag for the allocator we just 1055 -- built, since logically this allocator is a replacement of 1056 -- the original allocator node. This is for proper handling 1057 -- of restriction No_Implicit_Heap_Allocations. 1058 1059 Set_Comes_From_Source 1060 (Expression (Temp_Decl), Comes_From_Source (N)); 1061 1062 Set_No_Initialization (Expression (Temp_Decl)); 1063 Insert_Action (N, Temp_Decl); 1064 1065 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1066 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1067 1068 else 1069 Node := Relocate_Node (N); 1070 Set_Analyzed (Node); 1071 1072 Temp_Decl := 1073 Make_Object_Declaration (Loc, 1074 Defining_Identifier => Temp, 1075 Constant_Present => True, 1076 Object_Definition => New_Occurrence_Of (Def_Id, Loc), 1077 Expression => Node); 1078 1079 Insert_Action (N, Temp_Decl); 1080 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1081 end if; 1082 1083 -- Generate an additional object containing the address of the 1084 -- returned object. The type of this second object declaration 1085 -- is the correct type required for the common processing that 1086 -- is still performed by this subprogram. The displacement of 1087 -- this pointer to reference the component associated with the 1088 -- interface type will be done at the end of common processing. 1089 1090 New_Decl := 1091 Make_Object_Declaration (Loc, 1092 Defining_Identifier => Make_Temporary (Loc, 'P'), 1093 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1094 Expression => 1095 Unchecked_Convert_To (PtrT, 1096 New_Occurrence_Of (Temp, Loc))); 1097 1098 Insert_Action (N, New_Decl); 1099 1100 Temp_Decl := New_Decl; 1101 Temp := Defining_Identifier (New_Decl); 1102 end; 1103 end if; 1104 1105 -- Generate the tag assignment 1106 1107 -- Suppress the tag assignment for VM targets because VM tags are 1108 -- represented implicitly in objects. 1109 1110 if not Tagged_Type_Expansion then 1111 null; 1112 1113 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide 1114 -- interface objects because in this case the tag does not change. 1115 1116 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then 1117 pragma Assert (Is_Class_Wide_Type 1118 (Directly_Designated_Type (Etype (N)))); 1119 null; 1120 1121 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then 1122 TagT := T; 1123 TagR := 1124 Make_Explicit_Dereference (Loc, 1125 Prefix => New_Occurrence_Of (Temp, Loc)); 1126 1127 elsif Is_Private_Type (T) 1128 and then Is_Tagged_Type (Underlying_Type (T)) 1129 then 1130 TagT := Underlying_Type (T); 1131 TagR := 1132 Unchecked_Convert_To (Underlying_Type (T), 1133 Make_Explicit_Dereference (Loc, 1134 Prefix => New_Occurrence_Of (Temp, Loc))); 1135 end if; 1136 1137 if Present (TagT) then 1138 declare 1139 Full_T : constant Entity_Id := Underlying_Type (TagT); 1140 1141 begin 1142 Tag_Assign := 1143 Make_Assignment_Statement (Loc, 1144 Name => 1145 Make_Selected_Component (Loc, 1146 Prefix => TagR, 1147 Selector_Name => 1148 New_Occurrence_Of 1149 (First_Tag_Component (Full_T), Loc)), 1150 1151 Expression => 1152 Unchecked_Convert_To (RTE (RE_Tag), 1153 New_Occurrence_Of 1154 (Elists.Node 1155 (First_Elmt (Access_Disp_Table (Full_T))), Loc))); 1156 end; 1157 1158 -- The previous assignment has to be done in any case 1159 1160 Set_Assignment_OK (Name (Tag_Assign)); 1161 Insert_Action (N, Tag_Assign); 1162 end if; 1163 1164 -- Generate an Adjust call if the object will be moved. In Ada 2005, 1165 -- the object may be inherently limited, in which case there is no 1166 -- Adjust procedure, and the object is built in place. In Ada 95, the 1167 -- object can be limited but not inherently limited if this allocator 1168 -- came from a return statement (we're allocating the result on the 1169 -- secondary stack). In that case, the object will be moved, so we do 1170 -- want to Adjust. However, if it's a nonlimited build-in-place 1171 -- function call, Adjust is not wanted. 1172 1173 if Needs_Finalization (DesigT) 1174 and then Needs_Finalization (T) 1175 and then not Aggr_In_Place 1176 and then not Is_Limited_View (T) 1177 and then not Alloc_For_BIP_Return (N) 1178 and then not Is_Build_In_Place_Function_Call (Expression (N)) 1179 then 1180 -- An unchecked conversion is needed in the classwide case because 1181 -- the designated type can be an ancestor of the subtype mark of 1182 -- the allocator. 1183 1184 Adj_Call := 1185 Make_Adjust_Call 1186 (Obj_Ref => 1187 Unchecked_Convert_To (T, 1188 Make_Explicit_Dereference (Loc, 1189 Prefix => New_Occurrence_Of (Temp, Loc))), 1190 Typ => T); 1191 1192 if Present (Adj_Call) then 1193 Insert_Action (N, Adj_Call); 1194 end if; 1195 end if; 1196 1197 -- Note: the accessibility check must be inserted after the call to 1198 -- [Deep_]Adjust to ensure proper completion of the assignment. 1199 1200 Apply_Accessibility_Check (Temp); 1201 1202 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1203 Analyze_And_Resolve (N, PtrT); 1204 1205 -- Ada 2005 (AI-251): Displace the pointer to reference the record 1206 -- component containing the secondary dispatch table of the interface 1207 -- type. 1208 1209 if Is_Interface (Directly_Designated_Type (PtrT)) then 1210 Displace_Allocator_Pointer (N); 1211 end if; 1212 1213 -- Always force the generation of a temporary for aggregates when 1214 -- generating C code, to simplify the work in the code generator. 1215 1216 elsif Aggr_In_Place 1217 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate) 1218 then 1219 Temp := Make_Temporary (Loc, 'P', N); 1220 Temp_Decl := 1221 Make_Object_Declaration (Loc, 1222 Defining_Identifier => Temp, 1223 Object_Definition => New_Occurrence_Of (PtrT, Loc), 1224 Expression => 1225 Make_Allocator (Loc, 1226 Expression => New_Occurrence_Of (Etype (Exp), Loc))); 1227 1228 -- Copy the Comes_From_Source flag for the allocator we just built, 1229 -- since logically this allocator is a replacement of the original 1230 -- allocator node. This is for proper handling of restriction 1231 -- No_Implicit_Heap_Allocations. 1232 1233 Set_Comes_From_Source 1234 (Expression (Temp_Decl), Comes_From_Source (N)); 1235 1236 Set_No_Initialization (Expression (Temp_Decl)); 1237 Insert_Action (N, Temp_Decl); 1238 1239 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 1240 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); 1241 1242 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1243 Analyze_And_Resolve (N, PtrT); 1244 1245 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then 1246 Install_Null_Excluding_Check (Exp); 1247 1248 elsif Is_Access_Type (DesigT) 1249 and then Nkind (Exp) = N_Allocator 1250 and then Nkind (Expression (Exp)) /= N_Qualified_Expression 1251 then 1252 -- Apply constraint to designated subtype indication 1253 1254 Apply_Constraint_Check 1255 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True); 1256 1257 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then 1258 1259 -- Propagate constraint_error to enclosing allocator 1260 1261 Rewrite (Exp, New_Copy (Expression (Exp))); 1262 end if; 1263 1264 else 1265 Build_Allocate_Deallocate_Proc (N, True); 1266 1267 -- For an access to unconstrained packed array, GIGI needs to see an 1268 -- expression with a constrained subtype in order to compute the 1269 -- proper size for the allocator. 1270 1271 if Is_Packed_Array (T) 1272 and then not Is_Constrained (T) 1273 then 1274 declare 1275 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); 1276 Internal_Exp : constant Node_Id := Relocate_Node (Exp); 1277 begin 1278 Insert_Action (Exp, 1279 Make_Subtype_Declaration (Loc, 1280 Defining_Identifier => ConstrT, 1281 Subtype_Indication => 1282 Make_Subtype_From_Expr (Internal_Exp, T))); 1283 Freeze_Itype (ConstrT, Exp); 1284 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); 1285 end; 1286 end if; 1287 1288 -- Ada 2005 (AI-318-02): If the initialization expression is a call 1289 -- to a build-in-place function, then access to the allocated object 1290 -- must be passed to the function. 1291 1292 if Is_Build_In_Place_Function_Call (Exp) then 1293 Make_Build_In_Place_Call_In_Allocator (N, Exp); 1294 end if; 1295 end if; 1296 1297 exception 1298 when RE_Not_Available => 1299 return; 1300 end Expand_Allocator_Expression; 1301 1302 ----------------------------- 1303 -- Expand_Array_Comparison -- 1304 ----------------------------- 1305 1306 -- Expansion is only required in the case of array types. For the unpacked 1307 -- case, an appropriate runtime routine is called. For packed cases, and 1308 -- also in some other cases where a runtime routine cannot be called, the 1309 -- form of the expansion is: 1310 1311 -- [body for greater_nn; boolean_expression] 1312 1313 -- The body is built by Make_Array_Comparison_Op, and the form of the 1314 -- Boolean expression depends on the operator involved. 1315 1316 procedure Expand_Array_Comparison (N : Node_Id) is 1317 Loc : constant Source_Ptr := Sloc (N); 1318 Op1 : Node_Id := Left_Opnd (N); 1319 Op2 : Node_Id := Right_Opnd (N); 1320 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 1321 Ctyp : constant Entity_Id := Component_Type (Typ1); 1322 1323 Expr : Node_Id; 1324 Func_Body : Node_Id; 1325 Func_Name : Entity_Id; 1326 1327 Comp : RE_Id; 1328 1329 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; 1330 -- True for byte addressable target 1331 1332 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; 1333 -- Returns True if the length of the given operand is known to be less 1334 -- than 4. Returns False if this length is known to be four or greater 1335 -- or is not known at compile time. 1336 1337 ------------------------ 1338 -- Length_Less_Than_4 -- 1339 ------------------------ 1340 1341 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is 1342 Otyp : constant Entity_Id := Etype (Opnd); 1343 1344 begin 1345 if Ekind (Otyp) = E_String_Literal_Subtype then 1346 return String_Literal_Length (Otyp) < 4; 1347 1348 else 1349 declare 1350 Ityp : constant Entity_Id := Etype (First_Index (Otyp)); 1351 Lo : constant Node_Id := Type_Low_Bound (Ityp); 1352 Hi : constant Node_Id := Type_High_Bound (Ityp); 1353 Lov : Uint; 1354 Hiv : Uint; 1355 1356 begin 1357 if Compile_Time_Known_Value (Lo) then 1358 Lov := Expr_Value (Lo); 1359 else 1360 return False; 1361 end if; 1362 1363 if Compile_Time_Known_Value (Hi) then 1364 Hiv := Expr_Value (Hi); 1365 else 1366 return False; 1367 end if; 1368 1369 return Hiv < Lov + 3; 1370 end; 1371 end if; 1372 end Length_Less_Than_4; 1373 1374 -- Start of processing for Expand_Array_Comparison 1375 1376 begin 1377 -- Deal first with unpacked case, where we can call a runtime routine 1378 -- except that we avoid this for targets for which are not addressable 1379 -- by bytes. 1380 1381 if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable then 1382 -- The call we generate is: 1383 1384 -- Compare_Array_xn[_Unaligned] 1385 -- (left'address, right'address, left'length, right'length) <op> 0 1386 1387 -- x = U for unsigned, S for signed 1388 -- n = 8,16,32,64,128 for component size 1389 -- Add _Unaligned if length < 4 and component size is 8. 1390 -- <op> is the standard comparison operator 1391 1392 if Component_Size (Typ1) = 8 then 1393 if Length_Less_Than_4 (Op1) 1394 or else 1395 Length_Less_Than_4 (Op2) 1396 then 1397 if Is_Unsigned_Type (Ctyp) then 1398 Comp := RE_Compare_Array_U8_Unaligned; 1399 else 1400 Comp := RE_Compare_Array_S8_Unaligned; 1401 end if; 1402 1403 else 1404 if Is_Unsigned_Type (Ctyp) then 1405 Comp := RE_Compare_Array_U8; 1406 else 1407 Comp := RE_Compare_Array_S8; 1408 end if; 1409 end if; 1410 1411 elsif Component_Size (Typ1) = 16 then 1412 if Is_Unsigned_Type (Ctyp) then 1413 Comp := RE_Compare_Array_U16; 1414 else 1415 Comp := RE_Compare_Array_S16; 1416 end if; 1417 1418 elsif Component_Size (Typ1) = 32 then 1419 if Is_Unsigned_Type (Ctyp) then 1420 Comp := RE_Compare_Array_U32; 1421 else 1422 Comp := RE_Compare_Array_S32; 1423 end if; 1424 1425 elsif Component_Size (Typ1) = 64 then 1426 if Is_Unsigned_Type (Ctyp) then 1427 Comp := RE_Compare_Array_U64; 1428 else 1429 Comp := RE_Compare_Array_S64; 1430 end if; 1431 1432 else pragma Assert (Component_Size (Typ1) = 128); 1433 if Is_Unsigned_Type (Ctyp) then 1434 Comp := RE_Compare_Array_U128; 1435 else 1436 Comp := RE_Compare_Array_S128; 1437 end if; 1438 end if; 1439 1440 if RTE_Available (Comp) then 1441 1442 -- Expand to a call only if the runtime function is available, 1443 -- otherwise fall back to inline code. 1444 1445 Remove_Side_Effects (Op1, Name_Req => True); 1446 Remove_Side_Effects (Op2, Name_Req => True); 1447 1448 Rewrite (Op1, 1449 Make_Function_Call (Sloc (Op1), 1450 Name => New_Occurrence_Of (RTE (Comp), Loc), 1451 1452 Parameter_Associations => New_List ( 1453 Make_Attribute_Reference (Loc, 1454 Prefix => Relocate_Node (Op1), 1455 Attribute_Name => Name_Address), 1456 1457 Make_Attribute_Reference (Loc, 1458 Prefix => Relocate_Node (Op2), 1459 Attribute_Name => Name_Address), 1460 1461 Make_Attribute_Reference (Loc, 1462 Prefix => Relocate_Node (Op1), 1463 Attribute_Name => Name_Length), 1464 1465 Make_Attribute_Reference (Loc, 1466 Prefix => Relocate_Node (Op2), 1467 Attribute_Name => Name_Length)))); 1468 1469 Rewrite (Op2, 1470 Make_Integer_Literal (Sloc (Op2), 1471 Intval => Uint_0)); 1472 1473 Analyze_And_Resolve (Op1, Standard_Integer); 1474 Analyze_And_Resolve (Op2, Standard_Integer); 1475 return; 1476 end if; 1477 end if; 1478 1479 -- Cases where we cannot make runtime call 1480 1481 -- For (a <= b) we convert to not (a > b) 1482 1483 if Chars (N) = Name_Op_Le then 1484 Rewrite (N, 1485 Make_Op_Not (Loc, 1486 Right_Opnd => 1487 Make_Op_Gt (Loc, 1488 Left_Opnd => Op1, 1489 Right_Opnd => Op2))); 1490 Analyze_And_Resolve (N, Standard_Boolean); 1491 return; 1492 1493 -- For < the Boolean expression is 1494 -- greater__nn (op2, op1) 1495 1496 elsif Chars (N) = Name_Op_Lt then 1497 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1498 1499 -- Switch operands 1500 1501 Op1 := Right_Opnd (N); 1502 Op2 := Left_Opnd (N); 1503 1504 -- For (a >= b) we convert to not (a < b) 1505 1506 elsif Chars (N) = Name_Op_Ge then 1507 Rewrite (N, 1508 Make_Op_Not (Loc, 1509 Right_Opnd => 1510 Make_Op_Lt (Loc, 1511 Left_Opnd => Op1, 1512 Right_Opnd => Op2))); 1513 Analyze_And_Resolve (N, Standard_Boolean); 1514 return; 1515 1516 -- For > the Boolean expression is 1517 -- greater__nn (op1, op2) 1518 1519 else 1520 pragma Assert (Chars (N) = Name_Op_Gt); 1521 Func_Body := Make_Array_Comparison_Op (Typ1, N); 1522 end if; 1523 1524 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 1525 Expr := 1526 Make_Function_Call (Loc, 1527 Name => New_Occurrence_Of (Func_Name, Loc), 1528 Parameter_Associations => New_List (Op1, Op2)); 1529 1530 Insert_Action (N, Func_Body); 1531 Rewrite (N, Expr); 1532 Analyze_And_Resolve (N, Standard_Boolean); 1533 end Expand_Array_Comparison; 1534 1535 --------------------------- 1536 -- Expand_Array_Equality -- 1537 --------------------------- 1538 1539 -- Expand an equality function for multi-dimensional arrays. Here is an 1540 -- example of such a function for Nb_Dimension = 2 1541 1542 -- function Enn (A : atyp; B : btyp) return boolean is 1543 -- begin 1544 -- if (A'length (1) = 0 or else A'length (2) = 0) 1545 -- and then 1546 -- (B'length (1) = 0 or else B'length (2) = 0) 1547 -- then 1548 -- return True; -- RM 4.5.2(22) 1549 -- end if; 1550 1551 -- if A'length (1) /= B'length (1) 1552 -- or else 1553 -- A'length (2) /= B'length (2) 1554 -- then 1555 -- return False; -- RM 4.5.2(23) 1556 -- end if; 1557 1558 -- declare 1559 -- A1 : Index_T1 := A'first (1); 1560 -- B1 : Index_T1 := B'first (1); 1561 -- begin 1562 -- loop 1563 -- declare 1564 -- A2 : Index_T2 := A'first (2); 1565 -- B2 : Index_T2 := B'first (2); 1566 -- begin 1567 -- loop 1568 -- if A (A1, A2) /= B (B1, B2) then 1569 -- return False; 1570 -- end if; 1571 1572 -- exit when A2 = A'last (2); 1573 -- A2 := Index_T2'succ (A2); 1574 -- B2 := Index_T2'succ (B2); 1575 -- end loop; 1576 -- end; 1577 1578 -- exit when A1 = A'last (1); 1579 -- A1 := Index_T1'succ (A1); 1580 -- B1 := Index_T1'succ (B1); 1581 -- end loop; 1582 -- end; 1583 1584 -- return true; 1585 -- end Enn; 1586 1587 -- Note on the formal types used (atyp and btyp). If either of the arrays 1588 -- is of a private type, we use the underlying type, and do an unchecked 1589 -- conversion of the actual. If either of the arrays has a bound depending 1590 -- on a discriminant, then we use the base type since otherwise we have an 1591 -- escaped discriminant in the function. 1592 1593 -- If both arrays are constrained and have the same bounds, we can generate 1594 -- a loop with an explicit iteration scheme using a 'Range attribute over 1595 -- the first array. 1596 1597 function Expand_Array_Equality 1598 (Nod : Node_Id; 1599 Lhs : Node_Id; 1600 Rhs : Node_Id; 1601 Bodies : List_Id; 1602 Typ : Entity_Id) return Node_Id 1603 is 1604 Loc : constant Source_Ptr := Sloc (Nod); 1605 Decls : constant List_Id := New_List; 1606 Index_List1 : constant List_Id := New_List; 1607 Index_List2 : constant List_Id := New_List; 1608 1609 First_Idx : Node_Id; 1610 Formals : List_Id; 1611 Func_Name : Entity_Id; 1612 Func_Body : Node_Id; 1613 1614 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 1615 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 1616 1617 Ltyp : Entity_Id; 1618 Rtyp : Entity_Id; 1619 -- The parameter types to be used for the formals 1620 1621 New_Lhs : Node_Id; 1622 New_Rhs : Node_Id; 1623 -- The LHS and RHS converted to the parameter types 1624 1625 function Arr_Attr 1626 (Arr : Entity_Id; 1627 Nam : Name_Id; 1628 Num : Int) return Node_Id; 1629 -- This builds the attribute reference Arr'Nam (Expr) 1630 1631 function Component_Equality (Typ : Entity_Id) return Node_Id; 1632 -- Create one statement to compare corresponding components, designated 1633 -- by a full set of indexes. 1634 1635 function Get_Arg_Type (N : Node_Id) return Entity_Id; 1636 -- Given one of the arguments, computes the appropriate type to be used 1637 -- for that argument in the corresponding function formal 1638 1639 function Handle_One_Dimension 1640 (N : Int; 1641 Index : Node_Id) return Node_Id; 1642 -- This procedure returns the following code 1643 -- 1644 -- declare 1645 -- Bn : Index_T := B'First (N); 1646 -- begin 1647 -- loop 1648 -- xxx 1649 -- exit when An = A'Last (N); 1650 -- An := Index_T'Succ (An) 1651 -- Bn := Index_T'Succ (Bn) 1652 -- end loop; 1653 -- end; 1654 -- 1655 -- If both indexes are constrained and identical, the procedure 1656 -- returns a simpler loop: 1657 -- 1658 -- for An in A'Range (N) loop 1659 -- xxx 1660 -- end loop 1661 -- 1662 -- N is the dimension for which we are generating a loop. Index is the 1663 -- N'th index node, whose Etype is Index_Type_n in the above code. The 1664 -- xxx statement is either the loop or declare for the next dimension 1665 -- or if this is the last dimension the comparison of corresponding 1666 -- components of the arrays. 1667 -- 1668 -- The actual way the code works is to return the comparison of 1669 -- corresponding components for the N+1 call. That's neater. 1670 1671 function Test_Empty_Arrays return Node_Id; 1672 -- This function constructs the test for both arrays being empty 1673 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) 1674 -- and then 1675 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) 1676 1677 function Test_Lengths_Correspond return Node_Id; 1678 -- This function constructs the test for arrays having different lengths 1679 -- in at least one index position, in which case the resulting code is: 1680 1681 -- A'length (1) /= B'length (1) 1682 -- or else 1683 -- A'length (2) /= B'length (2) 1684 -- or else 1685 -- ... 1686 1687 -------------- 1688 -- Arr_Attr -- 1689 -------------- 1690 1691 function Arr_Attr 1692 (Arr : Entity_Id; 1693 Nam : Name_Id; 1694 Num : Int) return Node_Id 1695 is 1696 begin 1697 return 1698 Make_Attribute_Reference (Loc, 1699 Attribute_Name => Nam, 1700 Prefix => New_Occurrence_Of (Arr, Loc), 1701 Expressions => New_List (Make_Integer_Literal (Loc, Num))); 1702 end Arr_Attr; 1703 1704 ------------------------ 1705 -- Component_Equality -- 1706 ------------------------ 1707 1708 function Component_Equality (Typ : Entity_Id) return Node_Id is 1709 Test : Node_Id; 1710 L, R : Node_Id; 1711 1712 begin 1713 -- if a(i1...) /= b(j1...) then return false; end if; 1714 1715 L := 1716 Make_Indexed_Component (Loc, 1717 Prefix => Make_Identifier (Loc, Chars (A)), 1718 Expressions => Index_List1); 1719 1720 R := 1721 Make_Indexed_Component (Loc, 1722 Prefix => Make_Identifier (Loc, Chars (B)), 1723 Expressions => Index_List2); 1724 1725 Test := Expand_Composite_Equality 1726 (Nod, Component_Type (Typ), L, R, Decls); 1727 1728 -- If some (sub)component is an unchecked_union, the whole operation 1729 -- will raise program error. 1730 1731 if Nkind (Test) = N_Raise_Program_Error then 1732 1733 -- This node is going to be inserted at a location where a 1734 -- statement is expected: clear its Etype so analysis will set 1735 -- it to the expected Standard_Void_Type. 1736 1737 Set_Etype (Test, Empty); 1738 return Test; 1739 1740 else 1741 return 1742 Make_Implicit_If_Statement (Nod, 1743 Condition => Make_Op_Not (Loc, Right_Opnd => Test), 1744 Then_Statements => New_List ( 1745 Make_Simple_Return_Statement (Loc, 1746 Expression => New_Occurrence_Of (Standard_False, Loc)))); 1747 end if; 1748 end Component_Equality; 1749 1750 ------------------ 1751 -- Get_Arg_Type -- 1752 ------------------ 1753 1754 function Get_Arg_Type (N : Node_Id) return Entity_Id is 1755 T : Entity_Id; 1756 X : Node_Id; 1757 1758 begin 1759 T := Etype (N); 1760 1761 if No (T) then 1762 return Typ; 1763 1764 else 1765 T := Underlying_Type (T); 1766 1767 X := First_Index (T); 1768 while Present (X) loop 1769 if Denotes_Discriminant (Type_Low_Bound (Etype (X))) 1770 or else 1771 Denotes_Discriminant (Type_High_Bound (Etype (X))) 1772 then 1773 T := Base_Type (T); 1774 exit; 1775 end if; 1776 1777 Next_Index (X); 1778 end loop; 1779 1780 return T; 1781 end if; 1782 end Get_Arg_Type; 1783 1784 -------------------------- 1785 -- Handle_One_Dimension -- 1786 --------------------------- 1787 1788 function Handle_One_Dimension 1789 (N : Int; 1790 Index : Node_Id) return Node_Id 1791 is 1792 Need_Separate_Indexes : constant Boolean := 1793 Ltyp /= Rtyp or else not Is_Constrained (Ltyp); 1794 -- If the index types are identical, and we are working with 1795 -- constrained types, then we can use the same index for both 1796 -- of the arrays. 1797 1798 An : constant Entity_Id := Make_Temporary (Loc, 'A'); 1799 1800 Bn : Entity_Id; 1801 Index_T : Entity_Id; 1802 Stm_List : List_Id; 1803 Loop_Stm : Node_Id; 1804 1805 begin 1806 if N > Number_Dimensions (Ltyp) then 1807 return Component_Equality (Ltyp); 1808 end if; 1809 1810 -- Case where we generate a loop 1811 1812 Index_T := Base_Type (Etype (Index)); 1813 1814 if Need_Separate_Indexes then 1815 Bn := Make_Temporary (Loc, 'B'); 1816 else 1817 Bn := An; 1818 end if; 1819 1820 Append (New_Occurrence_Of (An, Loc), Index_List1); 1821 Append (New_Occurrence_Of (Bn, Loc), Index_List2); 1822 1823 Stm_List := New_List ( 1824 Handle_One_Dimension (N + 1, Next_Index (Index))); 1825 1826 if Need_Separate_Indexes then 1827 1828 -- Generate guard for loop, followed by increments of indexes 1829 1830 Append_To (Stm_List, 1831 Make_Exit_Statement (Loc, 1832 Condition => 1833 Make_Op_Eq (Loc, 1834 Left_Opnd => New_Occurrence_Of (An, Loc), 1835 Right_Opnd => Arr_Attr (A, Name_Last, N)))); 1836 1837 Append_To (Stm_List, 1838 Make_Assignment_Statement (Loc, 1839 Name => New_Occurrence_Of (An, Loc), 1840 Expression => 1841 Make_Attribute_Reference (Loc, 1842 Prefix => New_Occurrence_Of (Index_T, Loc), 1843 Attribute_Name => Name_Succ, 1844 Expressions => New_List ( 1845 New_Occurrence_Of (An, Loc))))); 1846 1847 Append_To (Stm_List, 1848 Make_Assignment_Statement (Loc, 1849 Name => New_Occurrence_Of (Bn, Loc), 1850 Expression => 1851 Make_Attribute_Reference (Loc, 1852 Prefix => New_Occurrence_Of (Index_T, Loc), 1853 Attribute_Name => Name_Succ, 1854 Expressions => New_List ( 1855 New_Occurrence_Of (Bn, Loc))))); 1856 end if; 1857 1858 -- If separate indexes, we need a declare block for An and Bn, and a 1859 -- loop without an iteration scheme. 1860 1861 if Need_Separate_Indexes then 1862 Loop_Stm := 1863 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); 1864 1865 return 1866 Make_Block_Statement (Loc, 1867 Declarations => New_List ( 1868 Make_Object_Declaration (Loc, 1869 Defining_Identifier => An, 1870 Object_Definition => New_Occurrence_Of (Index_T, Loc), 1871 Expression => Arr_Attr (A, Name_First, N)), 1872 1873 Make_Object_Declaration (Loc, 1874 Defining_Identifier => Bn, 1875 Object_Definition => New_Occurrence_Of (Index_T, Loc), 1876 Expression => Arr_Attr (B, Name_First, N))), 1877 1878 Handled_Statement_Sequence => 1879 Make_Handled_Sequence_Of_Statements (Loc, 1880 Statements => New_List (Loop_Stm))); 1881 1882 -- If no separate indexes, return loop statement with explicit 1883 -- iteration scheme on its own. 1884 1885 else 1886 Loop_Stm := 1887 Make_Implicit_Loop_Statement (Nod, 1888 Statements => Stm_List, 1889 Iteration_Scheme => 1890 Make_Iteration_Scheme (Loc, 1891 Loop_Parameter_Specification => 1892 Make_Loop_Parameter_Specification (Loc, 1893 Defining_Identifier => An, 1894 Discrete_Subtype_Definition => 1895 Arr_Attr (A, Name_Range, N)))); 1896 return Loop_Stm; 1897 end if; 1898 end Handle_One_Dimension; 1899 1900 ----------------------- 1901 -- Test_Empty_Arrays -- 1902 ----------------------- 1903 1904 function Test_Empty_Arrays return Node_Id is 1905 Alist : Node_Id; 1906 Blist : Node_Id; 1907 1908 Atest : Node_Id; 1909 Btest : Node_Id; 1910 1911 begin 1912 Alist := Empty; 1913 Blist := Empty; 1914 for J in 1 .. Number_Dimensions (Ltyp) loop 1915 Atest := 1916 Make_Op_Eq (Loc, 1917 Left_Opnd => Arr_Attr (A, Name_Length, J), 1918 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1919 1920 Btest := 1921 Make_Op_Eq (Loc, 1922 Left_Opnd => Arr_Attr (B, Name_Length, J), 1923 Right_Opnd => Make_Integer_Literal (Loc, 0)); 1924 1925 if No (Alist) then 1926 Alist := Atest; 1927 Blist := Btest; 1928 1929 else 1930 Alist := 1931 Make_Or_Else (Loc, 1932 Left_Opnd => Relocate_Node (Alist), 1933 Right_Opnd => Atest); 1934 1935 Blist := 1936 Make_Or_Else (Loc, 1937 Left_Opnd => Relocate_Node (Blist), 1938 Right_Opnd => Btest); 1939 end if; 1940 end loop; 1941 1942 return 1943 Make_And_Then (Loc, 1944 Left_Opnd => Alist, 1945 Right_Opnd => Blist); 1946 end Test_Empty_Arrays; 1947 1948 ----------------------------- 1949 -- Test_Lengths_Correspond -- 1950 ----------------------------- 1951 1952 function Test_Lengths_Correspond return Node_Id is 1953 Result : Node_Id; 1954 Rtest : Node_Id; 1955 1956 begin 1957 Result := Empty; 1958 for J in 1 .. Number_Dimensions (Ltyp) loop 1959 Rtest := 1960 Make_Op_Ne (Loc, 1961 Left_Opnd => Arr_Attr (A, Name_Length, J), 1962 Right_Opnd => Arr_Attr (B, Name_Length, J)); 1963 1964 if No (Result) then 1965 Result := Rtest; 1966 else 1967 Result := 1968 Make_Or_Else (Loc, 1969 Left_Opnd => Relocate_Node (Result), 1970 Right_Opnd => Rtest); 1971 end if; 1972 end loop; 1973 1974 return Result; 1975 end Test_Lengths_Correspond; 1976 1977 -- Start of processing for Expand_Array_Equality 1978 1979 begin 1980 Ltyp := Get_Arg_Type (Lhs); 1981 Rtyp := Get_Arg_Type (Rhs); 1982 1983 -- For now, if the argument types are not the same, go to the base type, 1984 -- since the code assumes that the formals have the same type. This is 1985 -- fixable in future ??? 1986 1987 if Ltyp /= Rtyp then 1988 Ltyp := Base_Type (Ltyp); 1989 Rtyp := Base_Type (Rtyp); 1990 pragma Assert (Ltyp = Rtyp); 1991 end if; 1992 1993 -- If the array type is distinct from the type of the arguments, it 1994 -- is the full view of a private type. Apply an unchecked conversion 1995 -- to ensure that analysis of the code below succeeds. 1996 1997 if No (Etype (Lhs)) 1998 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp) 1999 then 2000 New_Lhs := OK_Convert_To (Ltyp, Lhs); 2001 else 2002 New_Lhs := Lhs; 2003 end if; 2004 2005 if No (Etype (Rhs)) 2006 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp) 2007 then 2008 New_Rhs := OK_Convert_To (Rtyp, Rhs); 2009 else 2010 New_Rhs := Rhs; 2011 end if; 2012 2013 First_Idx := First_Index (Ltyp); 2014 2015 -- If optimization is enabled and the array boils down to a couple of 2016 -- consecutive elements, generate a simple conjunction of comparisons 2017 -- which should be easier to optimize by the code generator. 2018 2019 if Optimization_Level > 0 2020 and then Ltyp = Rtyp 2021 and then Is_Constrained (Ltyp) 2022 and then Number_Dimensions (Ltyp) = 1 2023 and then Nkind (First_Idx) = N_Range 2024 and then Compile_Time_Known_Value (Low_Bound (First_Idx)) 2025 and then Compile_Time_Known_Value (High_Bound (First_Idx)) 2026 and then Expr_Value (High_Bound (First_Idx)) = 2027 Expr_Value (Low_Bound (First_Idx)) + 1 2028 then 2029 declare 2030 Ctyp : constant Entity_Id := Component_Type (Ltyp); 2031 L, R : Node_Id; 2032 TestL, TestH : Node_Id; 2033 2034 begin 2035 L := 2036 Make_Indexed_Component (Loc, 2037 Prefix => New_Copy_Tree (New_Lhs), 2038 Expressions => 2039 New_List (New_Copy_Tree (Low_Bound (First_Idx)))); 2040 2041 R := 2042 Make_Indexed_Component (Loc, 2043 Prefix => New_Copy_Tree (New_Rhs), 2044 Expressions => 2045 New_List (New_Copy_Tree (Low_Bound (First_Idx)))); 2046 2047 TestL := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies); 2048 2049 L := 2050 Make_Indexed_Component (Loc, 2051 Prefix => New_Lhs, 2052 Expressions => 2053 New_List (New_Copy_Tree (High_Bound (First_Idx)))); 2054 2055 R := 2056 Make_Indexed_Component (Loc, 2057 Prefix => New_Rhs, 2058 Expressions => 2059 New_List (New_Copy_Tree (High_Bound (First_Idx)))); 2060 2061 TestH := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies); 2062 2063 return 2064 Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH); 2065 end; 2066 end if; 2067 2068 -- Build list of formals for function 2069 2070 Formals := New_List ( 2071 Make_Parameter_Specification (Loc, 2072 Defining_Identifier => A, 2073 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)), 2074 2075 Make_Parameter_Specification (Loc, 2076 Defining_Identifier => B, 2077 Parameter_Type => New_Occurrence_Of (Rtyp, Loc))); 2078 2079 Func_Name := Make_Temporary (Loc, 'E'); 2080 2081 -- Build statement sequence for function 2082 2083 Func_Body := 2084 Make_Subprogram_Body (Loc, 2085 Specification => 2086 Make_Function_Specification (Loc, 2087 Defining_Unit_Name => Func_Name, 2088 Parameter_Specifications => Formals, 2089 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 2090 2091 Declarations => Decls, 2092 2093 Handled_Statement_Sequence => 2094 Make_Handled_Sequence_Of_Statements (Loc, 2095 Statements => New_List ( 2096 2097 Make_Implicit_If_Statement (Nod, 2098 Condition => Test_Empty_Arrays, 2099 Then_Statements => New_List ( 2100 Make_Simple_Return_Statement (Loc, 2101 Expression => 2102 New_Occurrence_Of (Standard_True, Loc)))), 2103 2104 Make_Implicit_If_Statement (Nod, 2105 Condition => Test_Lengths_Correspond, 2106 Then_Statements => New_List ( 2107 Make_Simple_Return_Statement (Loc, 2108 Expression => New_Occurrence_Of (Standard_False, Loc)))), 2109 2110 Handle_One_Dimension (1, First_Idx), 2111 2112 Make_Simple_Return_Statement (Loc, 2113 Expression => New_Occurrence_Of (Standard_True, Loc))))); 2114 2115 Set_Has_Completion (Func_Name, True); 2116 Set_Is_Inlined (Func_Name); 2117 2118 Append_To (Bodies, Func_Body); 2119 2120 return 2121 Make_Function_Call (Loc, 2122 Name => New_Occurrence_Of (Func_Name, Loc), 2123 Parameter_Associations => New_List (New_Lhs, New_Rhs)); 2124 end Expand_Array_Equality; 2125 2126 ----------------------------- 2127 -- Expand_Boolean_Operator -- 2128 ----------------------------- 2129 2130 -- Note that we first get the actual subtypes of the operands, since we 2131 -- always want to deal with types that have bounds. 2132 2133 procedure Expand_Boolean_Operator (N : Node_Id) is 2134 Typ : constant Entity_Id := Etype (N); 2135 2136 begin 2137 -- Special case of bit packed array where both operands are known to be 2138 -- properly aligned. In this case we use an efficient run time routine 2139 -- to carry out the operation (see System.Bit_Ops). 2140 2141 if Is_Bit_Packed_Array (Typ) 2142 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) 2143 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 2144 then 2145 Expand_Packed_Boolean_Operator (N); 2146 return; 2147 end if; 2148 2149 -- For the normal non-packed case, the general expansion is to build 2150 -- function for carrying out the comparison (use Make_Boolean_Array_Op) 2151 -- and then inserting it into the tree. The original operator node is 2152 -- then rewritten as a call to this function. We also use this in the 2153 -- packed case if either operand is a possibly unaligned object. 2154 2155 declare 2156 Loc : constant Source_Ptr := Sloc (N); 2157 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 2158 R : Node_Id := Relocate_Node (Right_Opnd (N)); 2159 Func_Body : Node_Id; 2160 Func_Name : Entity_Id; 2161 2162 begin 2163 Convert_To_Actual_Subtype (L); 2164 Convert_To_Actual_Subtype (R); 2165 Ensure_Defined (Etype (L), N); 2166 Ensure_Defined (Etype (R), N); 2167 Apply_Length_Check (R, Etype (L)); 2168 2169 if Nkind (N) = N_Op_Xor then 2170 R := Duplicate_Subexpr (R); 2171 Silly_Boolean_Array_Xor_Test (N, R, Etype (L)); 2172 end if; 2173 2174 if Nkind (Parent (N)) = N_Assignment_Statement 2175 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) 2176 then 2177 Build_Boolean_Array_Proc_Call (Parent (N), L, R); 2178 2179 elsif Nkind (Parent (N)) = N_Op_Not 2180 and then Nkind (N) = N_Op_And 2181 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 2182 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) 2183 then 2184 return; 2185 else 2186 Func_Body := Make_Boolean_Array_Op (Etype (L), N); 2187 Func_Name := Defining_Unit_Name (Specification (Func_Body)); 2188 Insert_Action (N, Func_Body); 2189 2190 -- Now rewrite the expression with a call 2191 2192 if Transform_Function_Array then 2193 declare 2194 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 2195 Call : Node_Id; 2196 Decl : Node_Id; 2197 2198 begin 2199 -- Generate: 2200 -- Temp : ...; 2201 2202 Decl := 2203 Make_Object_Declaration (Loc, 2204 Defining_Identifier => Temp_Id, 2205 Object_Definition => 2206 New_Occurrence_Of (Etype (L), Loc)); 2207 2208 -- Generate: 2209 -- Proc_Call (L, R, Temp); 2210 2211 Call := 2212 Make_Procedure_Call_Statement (Loc, 2213 Name => New_Occurrence_Of (Func_Name, Loc), 2214 Parameter_Associations => 2215 New_List ( 2216 L, 2217 Make_Type_Conversion 2218 (Loc, New_Occurrence_Of (Etype (L), Loc), R), 2219 New_Occurrence_Of (Temp_Id, Loc))); 2220 2221 Insert_Actions (Parent (N), New_List (Decl, Call)); 2222 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); 2223 end; 2224 else 2225 Rewrite (N, 2226 Make_Function_Call (Loc, 2227 Name => New_Occurrence_Of (Func_Name, Loc), 2228 Parameter_Associations => 2229 New_List ( 2230 L, 2231 Make_Type_Conversion 2232 (Loc, New_Occurrence_Of (Etype (L), Loc), R)))); 2233 end if; 2234 2235 Analyze_And_Resolve (N, Typ); 2236 end if; 2237 end; 2238 end Expand_Boolean_Operator; 2239 2240 ------------------------------------------------ 2241 -- Expand_Compare_Minimize_Eliminate_Overflow -- 2242 ------------------------------------------------ 2243 2244 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is 2245 Loc : constant Source_Ptr := Sloc (N); 2246 2247 Result_Type : constant Entity_Id := Etype (N); 2248 -- Capture result type (could be a derived boolean type) 2249 2250 Llo, Lhi : Uint; 2251 Rlo, Rhi : Uint; 2252 2253 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 2254 -- Entity for Long_Long_Integer'Base 2255 2256 Check : constant Overflow_Mode_Type := Overflow_Check_Mode; 2257 -- Current overflow checking mode 2258 2259 procedure Set_True; 2260 procedure Set_False; 2261 -- These procedures rewrite N with an occurrence of Standard_True or 2262 -- Standard_False, and then makes a call to Warn_On_Known_Condition. 2263 2264 --------------- 2265 -- Set_False -- 2266 --------------- 2267 2268 procedure Set_False is 2269 begin 2270 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 2271 Warn_On_Known_Condition (N); 2272 end Set_False; 2273 2274 -------------- 2275 -- Set_True -- 2276 -------------- 2277 2278 procedure Set_True is 2279 begin 2280 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 2281 Warn_On_Known_Condition (N); 2282 end Set_True; 2283 2284 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow 2285 2286 begin 2287 -- Nothing to do unless we have a comparison operator with operands 2288 -- that are signed integer types, and we are operating in either 2289 -- MINIMIZED or ELIMINATED overflow checking mode. 2290 2291 if Nkind (N) not in N_Op_Compare 2292 or else Check not in Minimized_Or_Eliminated 2293 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N))) 2294 then 2295 return; 2296 end if; 2297 2298 -- OK, this is the case we are interested in. First step is to process 2299 -- our operands using the Minimize_Eliminate circuitry which applies 2300 -- this processing to the two operand subtrees. 2301 2302 Minimize_Eliminate_Overflows 2303 (Left_Opnd (N), Llo, Lhi, Top_Level => False); 2304 Minimize_Eliminate_Overflows 2305 (Right_Opnd (N), Rlo, Rhi, Top_Level => False); 2306 2307 -- See if the range information decides the result of the comparison. 2308 -- We can only do this if we in fact have full range information (which 2309 -- won't be the case if either operand is bignum at this stage). 2310 2311 if Llo /= No_Uint and then Rlo /= No_Uint then 2312 case N_Op_Compare (Nkind (N)) is 2313 when N_Op_Eq => 2314 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2315 Set_True; 2316 elsif Llo > Rhi or else Lhi < Rlo then 2317 Set_False; 2318 end if; 2319 2320 when N_Op_Ge => 2321 if Llo >= Rhi then 2322 Set_True; 2323 elsif Lhi < Rlo then 2324 Set_False; 2325 end if; 2326 2327 when N_Op_Gt => 2328 if Llo > Rhi then 2329 Set_True; 2330 elsif Lhi <= Rlo then 2331 Set_False; 2332 end if; 2333 2334 when N_Op_Le => 2335 if Llo > Rhi then 2336 Set_False; 2337 elsif Lhi <= Rlo then 2338 Set_True; 2339 end if; 2340 2341 when N_Op_Lt => 2342 if Llo >= Rhi then 2343 Set_False; 2344 elsif Lhi < Rlo then 2345 Set_True; 2346 end if; 2347 2348 when N_Op_Ne => 2349 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then 2350 Set_False; 2351 elsif Llo > Rhi or else Lhi < Rlo then 2352 Set_True; 2353 end if; 2354 end case; 2355 2356 -- All done if we did the rewrite 2357 2358 if Nkind (N) not in N_Op_Compare then 2359 return; 2360 end if; 2361 end if; 2362 2363 -- Otherwise, time to do the comparison 2364 2365 declare 2366 Ltype : constant Entity_Id := Etype (Left_Opnd (N)); 2367 Rtype : constant Entity_Id := Etype (Right_Opnd (N)); 2368 2369 begin 2370 -- If the two operands have the same signed integer type we are 2371 -- all set, nothing more to do. This is the case where either 2372 -- both operands were unchanged, or we rewrote both of them to 2373 -- be Long_Long_Integer. 2374 2375 -- Note: Entity for the comparison may be wrong, but it's not worth 2376 -- the effort to change it, since the back end does not use it. 2377 2378 if Is_Signed_Integer_Type (Ltype) 2379 and then Base_Type (Ltype) = Base_Type (Rtype) 2380 then 2381 return; 2382 2383 -- Here if bignums are involved (can only happen in ELIMINATED mode) 2384 2385 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then 2386 declare 2387 Left : Node_Id := Left_Opnd (N); 2388 Right : Node_Id := Right_Opnd (N); 2389 -- Bignum references for left and right operands 2390 2391 begin 2392 if not Is_RTE (Ltype, RE_Bignum) then 2393 Left := Convert_To_Bignum (Left); 2394 elsif not Is_RTE (Rtype, RE_Bignum) then 2395 Right := Convert_To_Bignum (Right); 2396 end if; 2397 2398 -- We rewrite our node with: 2399 2400 -- do 2401 -- Bnn : Result_Type; 2402 -- declare 2403 -- M : Mark_Id := SS_Mark; 2404 -- begin 2405 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc) 2406 -- SS_Release (M); 2407 -- end; 2408 -- in 2409 -- Bnn 2410 -- end 2411 2412 declare 2413 Blk : constant Node_Id := Make_Bignum_Block (Loc); 2414 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 2415 Ent : RE_Id; 2416 2417 begin 2418 case N_Op_Compare (Nkind (N)) is 2419 when N_Op_Eq => Ent := RE_Big_EQ; 2420 when N_Op_Ge => Ent := RE_Big_GE; 2421 when N_Op_Gt => Ent := RE_Big_GT; 2422 when N_Op_Le => Ent := RE_Big_LE; 2423 when N_Op_Lt => Ent := RE_Big_LT; 2424 when N_Op_Ne => Ent := RE_Big_NE; 2425 end case; 2426 2427 -- Insert assignment to Bnn into the bignum block 2428 2429 Insert_Before 2430 (First (Statements (Handled_Statement_Sequence (Blk))), 2431 Make_Assignment_Statement (Loc, 2432 Name => New_Occurrence_Of (Bnn, Loc), 2433 Expression => 2434 Make_Function_Call (Loc, 2435 Name => 2436 New_Occurrence_Of (RTE (Ent), Loc), 2437 Parameter_Associations => New_List (Left, Right)))); 2438 2439 -- Now do the rewrite with expression actions 2440 2441 Rewrite (N, 2442 Make_Expression_With_Actions (Loc, 2443 Actions => New_List ( 2444 Make_Object_Declaration (Loc, 2445 Defining_Identifier => Bnn, 2446 Object_Definition => 2447 New_Occurrence_Of (Result_Type, Loc)), 2448 Blk), 2449 Expression => New_Occurrence_Of (Bnn, Loc))); 2450 Analyze_And_Resolve (N, Result_Type); 2451 end; 2452 end; 2453 2454 -- No bignums involved, but types are different, so we must have 2455 -- rewritten one of the operands as a Long_Long_Integer but not 2456 -- the other one. 2457 2458 -- If left operand is Long_Long_Integer, convert right operand 2459 -- and we are done (with a comparison of two Long_Long_Integers). 2460 2461 elsif Ltype = LLIB then 2462 Convert_To_And_Rewrite (LLIB, Right_Opnd (N)); 2463 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks); 2464 return; 2465 2466 -- If right operand is Long_Long_Integer, convert left operand 2467 -- and we are done (with a comparison of two Long_Long_Integers). 2468 2469 -- This is the only remaining possibility 2470 2471 else pragma Assert (Rtype = LLIB); 2472 Convert_To_And_Rewrite (LLIB, Left_Opnd (N)); 2473 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks); 2474 return; 2475 end if; 2476 end; 2477 end Expand_Compare_Minimize_Eliminate_Overflow; 2478 2479 ------------------------------- 2480 -- Expand_Composite_Equality -- 2481 ------------------------------- 2482 2483 -- This function is only called for comparing internal fields of composite 2484 -- types when these fields are themselves composites. This is a special 2485 -- case because it is not possible to respect normal Ada visibility rules. 2486 2487 function Expand_Composite_Equality 2488 (Nod : Node_Id; 2489 Typ : Entity_Id; 2490 Lhs : Node_Id; 2491 Rhs : Node_Id; 2492 Bodies : List_Id) return Node_Id 2493 is 2494 Loc : constant Source_Ptr := Sloc (Nod); 2495 Full_Type : Entity_Id; 2496 Eq_Op : Entity_Id; 2497 2498 -- Start of processing for Expand_Composite_Equality 2499 2500 begin 2501 if Is_Private_Type (Typ) then 2502 Full_Type := Underlying_Type (Typ); 2503 else 2504 Full_Type := Typ; 2505 end if; 2506 2507 -- If the private type has no completion the context may be the 2508 -- expansion of a composite equality for a composite type with some 2509 -- still incomplete components. The expression will not be analyzed 2510 -- until the enclosing type is completed, at which point this will be 2511 -- properly expanded, unless there is a bona fide completion error. 2512 2513 if No (Full_Type) then 2514 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2515 end if; 2516 2517 Full_Type := Base_Type (Full_Type); 2518 2519 -- When the base type itself is private, use the full view to expand 2520 -- the composite equality. 2521 2522 if Is_Private_Type (Full_Type) then 2523 Full_Type := Underlying_Type (Full_Type); 2524 end if; 2525 2526 -- Case of array types 2527 2528 if Is_Array_Type (Full_Type) then 2529 2530 -- If the operand is an elementary type other than a floating-point 2531 -- type, then we can simply use the built-in block bitwise equality, 2532 -- since the predefined equality operators always apply and bitwise 2533 -- equality is fine for all these cases. 2534 2535 if Is_Elementary_Type (Component_Type (Full_Type)) 2536 and then not Is_Floating_Point_Type (Component_Type (Full_Type)) 2537 then 2538 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2539 2540 -- For composite component types, and floating-point types, use the 2541 -- expansion. This deals with tagged component types (where we use 2542 -- the applicable equality routine) and floating-point (where we 2543 -- need to worry about negative zeroes), and also the case of any 2544 -- composite type recursively containing such fields. 2545 2546 else 2547 declare 2548 Comp_Typ : Entity_Id; 2549 Hi : Node_Id; 2550 Indx : Node_Id; 2551 Ityp : Entity_Id; 2552 Lo : Node_Id; 2553 2554 begin 2555 -- Do the comparison in the type (or its full view) and not in 2556 -- its unconstrained base type, because the latter operation is 2557 -- more complex and would also require an unchecked conversion. 2558 2559 if Is_Private_Type (Typ) then 2560 Comp_Typ := Underlying_Type (Typ); 2561 else 2562 Comp_Typ := Typ; 2563 end if; 2564 2565 -- Except for the case where the bounds of the type depend on a 2566 -- discriminant, or else we would run into scoping issues. 2567 2568 Indx := First_Index (Comp_Typ); 2569 while Present (Indx) loop 2570 Ityp := Etype (Indx); 2571 2572 Lo := Type_Low_Bound (Ityp); 2573 Hi := Type_High_Bound (Ityp); 2574 2575 if (Nkind (Lo) = N_Identifier 2576 and then Ekind (Entity (Lo)) = E_Discriminant) 2577 or else 2578 (Nkind (Hi) = N_Identifier 2579 and then Ekind (Entity (Hi)) = E_Discriminant) 2580 then 2581 Comp_Typ := Full_Type; 2582 exit; 2583 end if; 2584 2585 Next_Index (Indx); 2586 end loop; 2587 2588 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Comp_Typ); 2589 end; 2590 end if; 2591 2592 -- Case of tagged record types 2593 2594 elsif Is_Tagged_Type (Full_Type) then 2595 Eq_Op := Find_Primitive_Eq (Typ); 2596 pragma Assert (Present (Eq_Op)); 2597 2598 return 2599 Make_Function_Call (Loc, 2600 Name => New_Occurrence_Of (Eq_Op, Loc), 2601 Parameter_Associations => 2602 New_List 2603 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), 2604 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs))); 2605 2606 -- Case of untagged record types 2607 2608 elsif Is_Record_Type (Full_Type) then 2609 Eq_Op := TSS (Full_Type, TSS_Composite_Equality); 2610 2611 if Present (Eq_Op) then 2612 if Etype (First_Formal (Eq_Op)) /= Full_Type then 2613 2614 -- Inherited equality from parent type. Convert the actuals to 2615 -- match signature of operation. 2616 2617 declare 2618 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2619 2620 begin 2621 return 2622 Make_Function_Call (Loc, 2623 Name => New_Occurrence_Of (Eq_Op, Loc), 2624 Parameter_Associations => New_List ( 2625 OK_Convert_To (T, Lhs), 2626 OK_Convert_To (T, Rhs))); 2627 end; 2628 2629 else 2630 -- Comparison between Unchecked_Union components 2631 2632 if Is_Unchecked_Union (Full_Type) then 2633 declare 2634 Lhs_Type : Node_Id := Full_Type; 2635 Rhs_Type : Node_Id := Full_Type; 2636 Lhs_Discr_Val : Node_Id; 2637 Rhs_Discr_Val : Node_Id; 2638 2639 begin 2640 -- Lhs subtype 2641 2642 if Nkind (Lhs) = N_Selected_Component then 2643 Lhs_Type := Etype (Entity (Selector_Name (Lhs))); 2644 end if; 2645 2646 -- Rhs subtype 2647 2648 if Nkind (Rhs) = N_Selected_Component then 2649 Rhs_Type := Etype (Entity (Selector_Name (Rhs))); 2650 end if; 2651 2652 -- Lhs of the composite equality 2653 2654 if Is_Constrained (Lhs_Type) then 2655 2656 -- Since the enclosing record type can never be an 2657 -- Unchecked_Union (this code is executed for records 2658 -- that do not have variants), we may reference its 2659 -- discriminant(s). 2660 2661 if Nkind (Lhs) = N_Selected_Component 2662 and then Has_Per_Object_Constraint 2663 (Entity (Selector_Name (Lhs))) 2664 then 2665 Lhs_Discr_Val := 2666 Make_Selected_Component (Loc, 2667 Prefix => Prefix (Lhs), 2668 Selector_Name => 2669 New_Copy 2670 (Get_Discriminant_Value 2671 (First_Discriminant (Lhs_Type), 2672 Lhs_Type, 2673 Stored_Constraint (Lhs_Type)))); 2674 2675 else 2676 Lhs_Discr_Val := 2677 New_Copy 2678 (Get_Discriminant_Value 2679 (First_Discriminant (Lhs_Type), 2680 Lhs_Type, 2681 Stored_Constraint (Lhs_Type))); 2682 2683 end if; 2684 else 2685 -- It is not possible to infer the discriminant since 2686 -- the subtype is not constrained. 2687 2688 return 2689 Make_Raise_Program_Error (Loc, 2690 Reason => PE_Unchecked_Union_Restriction); 2691 end if; 2692 2693 -- Rhs of the composite equality 2694 2695 if Is_Constrained (Rhs_Type) then 2696 if Nkind (Rhs) = N_Selected_Component 2697 and then Has_Per_Object_Constraint 2698 (Entity (Selector_Name (Rhs))) 2699 then 2700 Rhs_Discr_Val := 2701 Make_Selected_Component (Loc, 2702 Prefix => Prefix (Rhs), 2703 Selector_Name => 2704 New_Copy 2705 (Get_Discriminant_Value 2706 (First_Discriminant (Rhs_Type), 2707 Rhs_Type, 2708 Stored_Constraint (Rhs_Type)))); 2709 2710 else 2711 Rhs_Discr_Val := 2712 New_Copy 2713 (Get_Discriminant_Value 2714 (First_Discriminant (Rhs_Type), 2715 Rhs_Type, 2716 Stored_Constraint (Rhs_Type))); 2717 2718 end if; 2719 else 2720 return 2721 Make_Raise_Program_Error (Loc, 2722 Reason => PE_Unchecked_Union_Restriction); 2723 end if; 2724 2725 -- Call the TSS equality function with the inferred 2726 -- discriminant values. 2727 2728 return 2729 Make_Function_Call (Loc, 2730 Name => New_Occurrence_Of (Eq_Op, Loc), 2731 Parameter_Associations => New_List ( 2732 Lhs, 2733 Rhs, 2734 Lhs_Discr_Val, 2735 Rhs_Discr_Val)); 2736 end; 2737 2738 -- All cases other than comparing Unchecked_Union types 2739 2740 else 2741 declare 2742 T : constant Entity_Id := Etype (First_Formal (Eq_Op)); 2743 begin 2744 return 2745 Make_Function_Call (Loc, 2746 Name => 2747 New_Occurrence_Of (Eq_Op, Loc), 2748 Parameter_Associations => New_List ( 2749 OK_Convert_To (T, Lhs), 2750 OK_Convert_To (T, Rhs))); 2751 end; 2752 end if; 2753 end if; 2754 2755 -- Equality composes in Ada 2012 for untagged record types. It also 2756 -- composes for bounded strings, because they are part of the 2757 -- predefined environment. We could make it compose for bounded 2758 -- strings by making them tagged, or by making sure all subcomponents 2759 -- are set to the same value, even when not used. Instead, we have 2760 -- this special case in the compiler, because it's more efficient. 2761 2762 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then 2763 2764 -- If no TSS has been created for the type, check whether there is 2765 -- a primitive equality declared for it. 2766 2767 declare 2768 Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs); 2769 2770 begin 2771 -- Use user-defined primitive if it exists, otherwise use 2772 -- predefined equality. 2773 2774 if Present (Op) then 2775 return Op; 2776 else 2777 return Make_Op_Eq (Loc, Lhs, Rhs); 2778 end if; 2779 end; 2780 2781 else 2782 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies); 2783 end if; 2784 2785 -- Non-composite types (always use predefined equality) 2786 2787 else 2788 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); 2789 end if; 2790 end Expand_Composite_Equality; 2791 2792 ------------------------ 2793 -- Expand_Concatenate -- 2794 ------------------------ 2795 2796 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is 2797 Loc : constant Source_Ptr := Sloc (Cnode); 2798 2799 Atyp : constant Entity_Id := Base_Type (Etype (Cnode)); 2800 -- Result type of concatenation 2801 2802 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode))); 2803 -- Component type. Elements of this component type can appear as one 2804 -- of the operands of concatenation as well as arrays. 2805 2806 Istyp : constant Entity_Id := Etype (First_Index (Atyp)); 2807 -- Index subtype 2808 2809 Ityp : constant Entity_Id := Base_Type (Istyp); 2810 -- Index type. This is the base type of the index subtype, and is used 2811 -- for all computed bounds (which may be out of range of Istyp in the 2812 -- case of null ranges). 2813 2814 Artyp : Entity_Id; 2815 -- This is the type we use to do arithmetic to compute the bounds and 2816 -- lengths of operands. The choice of this type is a little subtle and 2817 -- is discussed in a separate section at the start of the body code. 2818 2819 Concatenation_Error : exception; 2820 -- Raised if concatenation is sure to raise a CE 2821 2822 Result_May_Be_Null : Boolean := True; 2823 -- Reset to False if at least one operand is encountered which is known 2824 -- at compile time to be non-null. Used for handling the special case 2825 -- of setting the high bound to the last operand high bound for a null 2826 -- result, thus ensuring a proper high bound in the super-flat case. 2827 2828 N : constant Nat := List_Length (Opnds); 2829 -- Number of concatenation operands including possibly null operands 2830 2831 NN : Nat := 0; 2832 -- Number of operands excluding any known to be null, except that the 2833 -- last operand is always retained, in case it provides the bounds for 2834 -- a null result. 2835 2836 Opnd : Node_Id := Empty; 2837 -- Current operand being processed in the loop through operands. After 2838 -- this loop is complete, always contains the last operand (which is not 2839 -- the same as Operands (NN), since null operands are skipped). 2840 2841 -- Arrays describing the operands, only the first NN entries of each 2842 -- array are set (NN < N when we exclude known null operands). 2843 2844 Is_Fixed_Length : array (1 .. N) of Boolean; 2845 -- True if length of corresponding operand known at compile time 2846 2847 Operands : array (1 .. N) of Node_Id; 2848 -- Set to the corresponding entry in the Opnds list (but note that null 2849 -- operands are excluded, so not all entries in the list are stored). 2850 2851 Fixed_Length : array (1 .. N) of Uint; 2852 -- Set to length of operand. Entries in this array are set only if the 2853 -- corresponding entry in Is_Fixed_Length is True. 2854 2855 Opnd_Low_Bound : array (1 .. N) of Node_Id; 2856 -- Set to lower bound of operand. Either an integer literal in the case 2857 -- where the bound is known at compile time, else actual lower bound. 2858 -- The operand low bound is of type Ityp. 2859 2860 Var_Length : array (1 .. N) of Entity_Id; 2861 -- Set to an entity of type Natural that contains the length of an 2862 -- operand whose length is not known at compile time. Entries in this 2863 -- array are set only if the corresponding entry in Is_Fixed_Length 2864 -- is False. The entity is of type Artyp. 2865 2866 Aggr_Length : array (0 .. N) of Node_Id; 2867 -- The J'th entry in an expression node that represents the total length 2868 -- of operands 1 through J. It is either an integer literal node, or a 2869 -- reference to a constant entity with the right value, so it is fine 2870 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth 2871 -- entry always is set to zero. The length is of type Artyp. 2872 2873 Low_Bound : Node_Id := Empty; 2874 -- A tree node representing the low bound of the result (of type Ityp). 2875 -- This is either an integer literal node, or an identifier reference to 2876 -- a constant entity initialized to the appropriate value. 2877 2878 Last_Opnd_Low_Bound : Node_Id := Empty; 2879 -- A tree node representing the low bound of the last operand. This 2880 -- need only be set if the result could be null. It is used for the 2881 -- special case of setting the right low bound for a null result. 2882 -- This is of type Ityp. 2883 2884 Last_Opnd_High_Bound : Node_Id := Empty; 2885 -- A tree node representing the high bound of the last operand. This 2886 -- need only be set if the result could be null. It is used for the 2887 -- special case of setting the right high bound for a null result. 2888 -- This is of type Ityp. 2889 2890 High_Bound : Node_Id := Empty; 2891 -- A tree node representing the high bound of the result (of type Ityp) 2892 2893 Result : Node_Id := Empty; 2894 -- Result of the concatenation (of type Ityp) 2895 2896 Actions : constant List_Id := New_List; 2897 -- Collect actions to be inserted 2898 2899 Known_Non_Null_Operand_Seen : Boolean; 2900 -- Set True during generation of the assignments of operands into 2901 -- result once an operand known to be non-null has been seen. 2902 2903 function Library_Level_Target return Boolean; 2904 -- Return True if the concatenation is within the expression of the 2905 -- declaration of a library-level object. 2906 2907 function Make_Artyp_Literal (Val : Nat) return Node_Id; 2908 -- This function makes an N_Integer_Literal node that is returned in 2909 -- analyzed form with the type set to Artyp. Importantly this literal 2910 -- is not flagged as static, so that if we do computations with it that 2911 -- result in statically detected out of range conditions, we will not 2912 -- generate error messages but instead warning messages. 2913 2914 function To_Artyp (X : Node_Id) return Node_Id; 2915 -- Given a node of type Ityp, returns the corresponding value of type 2916 -- Artyp. For non-enumeration types, this is a plain integer conversion. 2917 -- For enum types, the Pos of the value is returned. 2918 2919 function To_Ityp (X : Node_Id) return Node_Id; 2920 -- The inverse function (uses Val in the case of enumeration types) 2921 2922 -------------------------- 2923 -- Library_Level_Target -- 2924 -------------------------- 2925 2926 function Library_Level_Target return Boolean is 2927 P : Node_Id := Parent (Cnode); 2928 2929 begin 2930 while Present (P) loop 2931 if Nkind (P) = N_Object_Declaration then 2932 return Is_Library_Level_Entity (Defining_Identifier (P)); 2933 2934 -- Prevent the search from going too far 2935 2936 elsif Is_Body_Or_Package_Declaration (P) then 2937 return False; 2938 end if; 2939 2940 P := Parent (P); 2941 end loop; 2942 2943 return False; 2944 end Library_Level_Target; 2945 2946 ------------------------ 2947 -- Make_Artyp_Literal -- 2948 ------------------------ 2949 2950 function Make_Artyp_Literal (Val : Nat) return Node_Id is 2951 Result : constant Node_Id := Make_Integer_Literal (Loc, Val); 2952 begin 2953 Set_Etype (Result, Artyp); 2954 Set_Analyzed (Result, True); 2955 Set_Is_Static_Expression (Result, False); 2956 return Result; 2957 end Make_Artyp_Literal; 2958 2959 -------------- 2960 -- To_Artyp -- 2961 -------------- 2962 2963 function To_Artyp (X : Node_Id) return Node_Id is 2964 begin 2965 if Ityp = Base_Type (Artyp) then 2966 return X; 2967 2968 elsif Is_Enumeration_Type (Ityp) then 2969 return 2970 Make_Attribute_Reference (Loc, 2971 Prefix => New_Occurrence_Of (Ityp, Loc), 2972 Attribute_Name => Name_Pos, 2973 Expressions => New_List (X)); 2974 2975 else 2976 return Convert_To (Artyp, X); 2977 end if; 2978 end To_Artyp; 2979 2980 ------------- 2981 -- To_Ityp -- 2982 ------------- 2983 2984 function To_Ityp (X : Node_Id) return Node_Id is 2985 begin 2986 if Is_Enumeration_Type (Ityp) then 2987 return 2988 Make_Attribute_Reference (Loc, 2989 Prefix => New_Occurrence_Of (Ityp, Loc), 2990 Attribute_Name => Name_Val, 2991 Expressions => New_List (X)); 2992 2993 -- Case where we will do a type conversion 2994 2995 else 2996 if Ityp = Base_Type (Artyp) then 2997 return X; 2998 else 2999 return Convert_To (Ityp, X); 3000 end if; 3001 end if; 3002 end To_Ityp; 3003 3004 -- Local Declarations 3005 3006 Opnd_Typ : Entity_Id; 3007 Subtyp_Ind : Entity_Id; 3008 Ent : Entity_Id; 3009 Len : Uint; 3010 J : Nat; 3011 Clen : Node_Id; 3012 Set : Boolean; 3013 3014 -- Start of processing for Expand_Concatenate 3015 3016 begin 3017 -- Choose an appropriate computational type 3018 3019 -- We will be doing calculations of lengths and bounds in this routine 3020 -- and computing one from the other in some cases, e.g. getting the high 3021 -- bound by adding the length-1 to the low bound. 3022 3023 -- We can't just use the index type, or even its base type for this 3024 -- purpose for two reasons. First it might be an enumeration type which 3025 -- is not suitable for computations of any kind, and second it may 3026 -- simply not have enough range. For example if the index type is 3027 -- -128..+127 then lengths can be up to 256, which is out of range of 3028 -- the type. 3029 3030 -- For enumeration types, we can simply use Standard_Integer, this is 3031 -- sufficient since the actual number of enumeration literals cannot 3032 -- possibly exceed the range of integer (remember we will be doing the 3033 -- arithmetic with POS values, not representation values). 3034 3035 if Is_Enumeration_Type (Ityp) then 3036 Artyp := Standard_Integer; 3037 3038 -- If index type is Positive, we use the standard unsigned type, to give 3039 -- more room on the top of the range, obviating the need for an overflow 3040 -- check when creating the upper bound. This is needed to avoid junk 3041 -- overflow checks in the common case of String types. 3042 3043 -- ??? Disabled for now 3044 3045 -- elsif Istyp = Standard_Positive then 3046 -- Artyp := Standard_Unsigned; 3047 3048 -- For modular types, we use a 32-bit modular type for types whose size 3049 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the 3050 -- identity type, and for larger unsigned types we use a 64-bit type. 3051 3052 elsif Is_Modular_Integer_Type (Ityp) then 3053 if RM_Size (Ityp) < Standard_Integer_Size then 3054 Artyp := Standard_Unsigned; 3055 elsif RM_Size (Ityp) = Standard_Integer_Size then 3056 Artyp := Ityp; 3057 else 3058 Artyp := Standard_Long_Long_Unsigned; 3059 end if; 3060 3061 -- Similar treatment for signed types 3062 3063 else 3064 if RM_Size (Ityp) < Standard_Integer_Size then 3065 Artyp := Standard_Integer; 3066 elsif RM_Size (Ityp) = Standard_Integer_Size then 3067 Artyp := Ityp; 3068 else 3069 Artyp := Standard_Long_Long_Integer; 3070 end if; 3071 end if; 3072 3073 -- Supply dummy entry at start of length array 3074 3075 Aggr_Length (0) := Make_Artyp_Literal (0); 3076 3077 -- Go through operands setting up the above arrays 3078 3079 J := 1; 3080 while J <= N loop 3081 Opnd := Remove_Head (Opnds); 3082 Opnd_Typ := Etype (Opnd); 3083 3084 -- The parent got messed up when we put the operands in a list, 3085 -- so now put back the proper parent for the saved operand, that 3086 -- is to say the concatenation node, to make sure that each operand 3087 -- is seen as a subexpression, e.g. if actions must be inserted. 3088 3089 Set_Parent (Opnd, Cnode); 3090 3091 -- Set will be True when we have setup one entry in the array 3092 3093 Set := False; 3094 3095 -- Singleton element (or character literal) case 3096 3097 if Base_Type (Opnd_Typ) = Ctyp then 3098 NN := NN + 1; 3099 Operands (NN) := Opnd; 3100 Is_Fixed_Length (NN) := True; 3101 Fixed_Length (NN) := Uint_1; 3102 Result_May_Be_Null := False; 3103 3104 -- Set low bound of operand (no need to set Last_Opnd_High_Bound 3105 -- since we know that the result cannot be null). 3106 3107 Opnd_Low_Bound (NN) := 3108 Make_Attribute_Reference (Loc, 3109 Prefix => New_Occurrence_Of (Istyp, Loc), 3110 Attribute_Name => Name_First); 3111 3112 Set := True; 3113 3114 -- String literal case (can only occur for strings of course) 3115 3116 elsif Nkind (Opnd) = N_String_Literal then 3117 Len := String_Literal_Length (Opnd_Typ); 3118 3119 if Len /= 0 then 3120 Result_May_Be_Null := False; 3121 end if; 3122 3123 -- Capture last operand low and high bound if result could be null 3124 3125 if J = N and then Result_May_Be_Null then 3126 Last_Opnd_Low_Bound := 3127 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3128 3129 Last_Opnd_High_Bound := 3130 Make_Op_Subtract (Loc, 3131 Left_Opnd => 3132 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), 3133 Right_Opnd => Make_Integer_Literal (Loc, 1)); 3134 end if; 3135 3136 -- Skip null string literal 3137 3138 if J < N and then Len = 0 then 3139 goto Continue; 3140 end if; 3141 3142 NN := NN + 1; 3143 Operands (NN) := Opnd; 3144 Is_Fixed_Length (NN) := True; 3145 3146 -- Set length and bounds 3147 3148 Fixed_Length (NN) := Len; 3149 3150 Opnd_Low_Bound (NN) := 3151 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); 3152 3153 Set := True; 3154 3155 -- All other cases 3156 3157 else 3158 -- Check constrained case with known bounds 3159 3160 if Is_Constrained (Opnd_Typ) then 3161 declare 3162 Index : constant Node_Id := First_Index (Opnd_Typ); 3163 Indx_Typ : constant Entity_Id := Etype (Index); 3164 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ); 3165 Hi : constant Node_Id := Type_High_Bound (Indx_Typ); 3166 3167 begin 3168 -- Fixed length constrained array type with known at compile 3169 -- time bounds is last case of fixed length operand. 3170 3171 if Compile_Time_Known_Value (Lo) 3172 and then 3173 Compile_Time_Known_Value (Hi) 3174 then 3175 declare 3176 Loval : constant Uint := Expr_Value (Lo); 3177 Hival : constant Uint := Expr_Value (Hi); 3178 Len : constant Uint := 3179 UI_Max (Hival - Loval + 1, Uint_0); 3180 3181 begin 3182 if Len > 0 then 3183 Result_May_Be_Null := False; 3184 end if; 3185 3186 -- Capture last operand bounds if result could be null 3187 3188 if J = N and then Result_May_Be_Null then 3189 Last_Opnd_Low_Bound := 3190 Convert_To (Ityp, 3191 Make_Integer_Literal (Loc, Expr_Value (Lo))); 3192 3193 Last_Opnd_High_Bound := 3194 Convert_To (Ityp, 3195 Make_Integer_Literal (Loc, Expr_Value (Hi))); 3196 end if; 3197 3198 -- Exclude null length case unless last operand 3199 3200 if J < N and then Len = 0 then 3201 goto Continue; 3202 end if; 3203 3204 NN := NN + 1; 3205 Operands (NN) := Opnd; 3206 Is_Fixed_Length (NN) := True; 3207 Fixed_Length (NN) := Len; 3208 3209 Opnd_Low_Bound (NN) := 3210 To_Ityp 3211 (Make_Integer_Literal (Loc, Expr_Value (Lo))); 3212 Set := True; 3213 end; 3214 end if; 3215 end; 3216 end if; 3217 3218 -- All cases where the length is not known at compile time, or the 3219 -- special case of an operand which is known to be null but has a 3220 -- lower bound other than 1 or is other than a string type. 3221 3222 if not Set then 3223 NN := NN + 1; 3224 3225 -- Capture operand bounds 3226 3227 Opnd_Low_Bound (NN) := 3228 Make_Attribute_Reference (Loc, 3229 Prefix => 3230 Duplicate_Subexpr (Opnd, Name_Req => True), 3231 Attribute_Name => Name_First); 3232 3233 -- Capture last operand bounds if result could be null 3234 3235 if J = N and Result_May_Be_Null then 3236 Last_Opnd_Low_Bound := 3237 Convert_To (Ityp, 3238 Make_Attribute_Reference (Loc, 3239 Prefix => 3240 Duplicate_Subexpr (Opnd, Name_Req => True), 3241 Attribute_Name => Name_First)); 3242 3243 Last_Opnd_High_Bound := 3244 Convert_To (Ityp, 3245 Make_Attribute_Reference (Loc, 3246 Prefix => 3247 Duplicate_Subexpr (Opnd, Name_Req => True), 3248 Attribute_Name => Name_Last)); 3249 end if; 3250 3251 -- Capture length of operand in entity 3252 3253 Operands (NN) := Opnd; 3254 Is_Fixed_Length (NN) := False; 3255 3256 Var_Length (NN) := Make_Temporary (Loc, 'L'); 3257 3258 Append_To (Actions, 3259 Make_Object_Declaration (Loc, 3260 Defining_Identifier => Var_Length (NN), 3261 Constant_Present => True, 3262 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3263 Expression => 3264 Make_Attribute_Reference (Loc, 3265 Prefix => 3266 Duplicate_Subexpr (Opnd, Name_Req => True), 3267 Attribute_Name => Name_Length))); 3268 end if; 3269 end if; 3270 3271 -- Set next entry in aggregate length array 3272 3273 -- For first entry, make either integer literal for fixed length 3274 -- or a reference to the saved length for variable length. 3275 3276 if NN = 1 then 3277 if Is_Fixed_Length (1) then 3278 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1)); 3279 else 3280 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc); 3281 end if; 3282 3283 -- If entry is fixed length and only fixed lengths so far, make 3284 -- appropriate new integer literal adding new length. 3285 3286 elsif Is_Fixed_Length (NN) 3287 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal 3288 then 3289 Aggr_Length (NN) := 3290 Make_Integer_Literal (Loc, 3291 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1))); 3292 3293 -- All other cases, construct an addition node for the length and 3294 -- create an entity initialized to this length. 3295 3296 else 3297 Ent := Make_Temporary (Loc, 'L'); 3298 3299 if Is_Fixed_Length (NN) then 3300 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); 3301 else 3302 Clen := New_Occurrence_Of (Var_Length (NN), Loc); 3303 end if; 3304 3305 Append_To (Actions, 3306 Make_Object_Declaration (Loc, 3307 Defining_Identifier => Ent, 3308 Constant_Present => True, 3309 Object_Definition => New_Occurrence_Of (Artyp, Loc), 3310 Expression => 3311 Make_Op_Add (Loc, 3312 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)), 3313 Right_Opnd => Clen))); 3314 3315 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent)); 3316 end if; 3317 3318 <<Continue>> 3319 J := J + 1; 3320 end loop; 3321 3322 -- If we have only skipped null operands, return the last operand 3323 3324 if NN = 0 then 3325 Result := Opnd; 3326 goto Done; 3327 end if; 3328 3329 -- If we have only one non-null operand, return it and we are done. 3330 -- There is one case in which this cannot be done, and that is when 3331 -- the sole operand is of the element type, in which case it must be 3332 -- converted to an array, and the easiest way of doing that is to go 3333 -- through the normal general circuit. 3334 3335 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then 3336 Result := Operands (1); 3337 goto Done; 3338 end if; 3339 3340 -- Cases where we have a real concatenation 3341 3342 -- Next step is to find the low bound for the result array that we 3343 -- will allocate. The rules for this are in (RM 4.5.6(5-7)). 3344 3345 -- If the ultimate ancestor of the index subtype is a constrained array 3346 -- definition, then the lower bound is that of the index subtype as 3347 -- specified by (RM 4.5.3(6)). 3348 3349 -- The right test here is to go to the root type, and then the ultimate 3350 -- ancestor is the first subtype of this root type. 3351 3352 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then 3353 Low_Bound := 3354 Make_Attribute_Reference (Loc, 3355 Prefix => 3356 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc), 3357 Attribute_Name => Name_First); 3358 3359 -- If the first operand in the list has known length we know that 3360 -- the lower bound of the result is the lower bound of this operand. 3361 3362 elsif Is_Fixed_Length (1) then 3363 Low_Bound := Opnd_Low_Bound (1); 3364 3365 -- OK, we don't know the lower bound, we have to build a horrible 3366 -- if expression node of the form 3367 3368 -- if Cond1'Length /= 0 then 3369 -- Opnd1 low bound 3370 -- else 3371 -- if Opnd2'Length /= 0 then 3372 -- Opnd2 low bound 3373 -- else 3374 -- ... 3375 3376 -- The nesting ends either when we hit an operand whose length is known 3377 -- at compile time, or on reaching the last operand, whose low bound we 3378 -- take unconditionally whether or not it is null. It's easiest to do 3379 -- this with a recursive procedure: 3380 3381 else 3382 declare 3383 function Get_Known_Bound (J : Nat) return Node_Id; 3384 -- Returns the lower bound determined by operands J .. NN 3385 3386 --------------------- 3387 -- Get_Known_Bound -- 3388 --------------------- 3389 3390 function Get_Known_Bound (J : Nat) return Node_Id is 3391 begin 3392 if Is_Fixed_Length (J) or else J = NN then 3393 return New_Copy_Tree (Opnd_Low_Bound (J)); 3394 3395 else 3396 return 3397 Make_If_Expression (Loc, 3398 Expressions => New_List ( 3399 3400 Make_Op_Ne (Loc, 3401 Left_Opnd => 3402 New_Occurrence_Of (Var_Length (J), Loc), 3403 Right_Opnd => 3404 Make_Integer_Literal (Loc, 0)), 3405 3406 New_Copy_Tree (Opnd_Low_Bound (J)), 3407 Get_Known_Bound (J + 1))); 3408 end if; 3409 end Get_Known_Bound; 3410 3411 begin 3412 Ent := Make_Temporary (Loc, 'L'); 3413 3414 Append_To (Actions, 3415 Make_Object_Declaration (Loc, 3416 Defining_Identifier => Ent, 3417 Constant_Present => True, 3418 Object_Definition => New_Occurrence_Of (Ityp, Loc), 3419 Expression => Get_Known_Bound (1))); 3420 3421 Low_Bound := New_Occurrence_Of (Ent, Loc); 3422 end; 3423 end if; 3424 3425 pragma Assert (Present (Low_Bound)); 3426 3427 -- Now we can safely compute the upper bound, normally 3428 -- Low_Bound + Length - 1. 3429 3430 High_Bound := 3431 To_Ityp 3432 (Make_Op_Add (Loc, 3433 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3434 Right_Opnd => 3435 Make_Op_Subtract (Loc, 3436 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3437 Right_Opnd => Make_Artyp_Literal (1)))); 3438 3439 -- Note that calculation of the high bound may cause overflow in some 3440 -- very weird cases, so in the general case we need an overflow check on 3441 -- the high bound. We can avoid this for the common case of string types 3442 -- and other types whose index is Positive, since we chose a wider range 3443 -- for the arithmetic type. If checks are suppressed we do not set the 3444 -- flag, and possibly superfluous warnings will be omitted. 3445 3446 if Istyp /= Standard_Positive 3447 and then not Overflow_Checks_Suppressed (Istyp) 3448 then 3449 Activate_Overflow_Check (High_Bound); 3450 end if; 3451 3452 -- Handle the exceptional case where the result is null, in which case 3453 -- case the bounds come from the last operand (so that we get the proper 3454 -- bounds if the last operand is super-flat). 3455 3456 if Result_May_Be_Null then 3457 Low_Bound := 3458 Make_If_Expression (Loc, 3459 Expressions => New_List ( 3460 Make_Op_Eq (Loc, 3461 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3462 Right_Opnd => Make_Artyp_Literal (0)), 3463 Last_Opnd_Low_Bound, 3464 Low_Bound)); 3465 3466 High_Bound := 3467 Make_If_Expression (Loc, 3468 Expressions => New_List ( 3469 Make_Op_Eq (Loc, 3470 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)), 3471 Right_Opnd => Make_Artyp_Literal (0)), 3472 Last_Opnd_High_Bound, 3473 High_Bound)); 3474 end if; 3475 3476 -- Here is where we insert the saved up actions 3477 3478 Insert_Actions (Cnode, Actions, Suppress => All_Checks); 3479 3480 -- Now we construct an array object with appropriate bounds. We mark 3481 -- the target as internal to prevent useless initialization when 3482 -- Initialize_Scalars is enabled. Also since this is the actual result 3483 -- entity, we make sure we have debug information for the result. 3484 3485 Subtyp_Ind := 3486 Make_Subtype_Indication (Loc, 3487 Subtype_Mark => New_Occurrence_Of (Atyp, Loc), 3488 Constraint => 3489 Make_Index_Or_Discriminant_Constraint (Loc, 3490 Constraints => New_List ( 3491 Make_Range (Loc, 3492 Low_Bound => Low_Bound, 3493 High_Bound => High_Bound)))); 3494 3495 Ent := Make_Temporary (Loc, 'S'); 3496 Set_Is_Internal (Ent); 3497 Set_Debug_Info_Needed (Ent); 3498 3499 -- If we are concatenating strings and the current scope already uses 3500 -- the secondary stack, allocate the resulting string also on the 3501 -- secondary stack to avoid putting too much pressure on the primary 3502 -- stack. 3503 -- Don't do this if -gnatd.h is set, as this will break the wrapping of 3504 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat. 3505 3506 if Atyp = Standard_String 3507 and then Uses_Sec_Stack (Current_Scope) 3508 and then RTE_Available (RE_SS_Pool) 3509 and then not Debug_Flag_Dot_H 3510 then 3511 -- Generate: 3512 -- subtype Axx is ...; 3513 -- type Ayy is access Axx; 3514 -- Rxx : Ayy := new <subtype> [storage_pool = ss_pool]; 3515 -- Sxx : <subtype> renames Rxx.all; 3516 3517 declare 3518 Alloc : Node_Id; 3519 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); 3520 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); 3521 Temp : Entity_Id; 3522 3523 begin 3524 Insert_Action (Cnode, 3525 Make_Subtype_Declaration (Loc, 3526 Defining_Identifier => ConstrT, 3527 Subtype_Indication => Subtyp_Ind), 3528 Suppress => All_Checks); 3529 Freeze_Itype (ConstrT, Cnode); 3530 3531 Insert_Action (Cnode, 3532 Make_Full_Type_Declaration (Loc, 3533 Defining_Identifier => Acc_Typ, 3534 Type_Definition => 3535 Make_Access_To_Object_Definition (Loc, 3536 Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))), 3537 Suppress => All_Checks); 3538 Alloc := 3539 Make_Allocator (Loc, 3540 Expression => New_Occurrence_Of (ConstrT, Loc)); 3541 3542 -- Allocate on the secondary stack. This is currently done 3543 -- only for type String, which normally doesn't have default 3544 -- initialization, but we need to Set_No_Initialization in case 3545 -- of Initialize_Scalars or Normalize_Scalars; otherwise, the 3546 -- allocator will get transformed and will not use the secondary 3547 -- stack. 3548 3549 Set_Storage_Pool (Alloc, RTE (RE_SS_Pool)); 3550 Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate)); 3551 Set_No_Initialization (Alloc); 3552 3553 Temp := Make_Temporary (Loc, 'R', Alloc); 3554 Insert_Action (Cnode, 3555 Make_Object_Declaration (Loc, 3556 Defining_Identifier => Temp, 3557 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), 3558 Expression => Alloc), 3559 Suppress => All_Checks); 3560 3561 Insert_Action (Cnode, 3562 Make_Object_Renaming_Declaration (Loc, 3563 Defining_Identifier => Ent, 3564 Subtype_Mark => New_Occurrence_Of (ConstrT, Loc), 3565 Name => 3566 Make_Explicit_Dereference (Loc, 3567 Prefix => New_Occurrence_Of (Temp, Loc))), 3568 Suppress => All_Checks); 3569 end; 3570 else 3571 -- If the bound is statically known to be out of range, we do not 3572 -- want to abort, we want a warning and a runtime constraint error. 3573 -- Note that we have arranged that the result will not be treated as 3574 -- a static constant, so we won't get an illegality during this 3575 -- insertion. 3576 -- We also enable checks (in particular range checks) in case the 3577 -- bounds of Subtyp_Ind are out of range. 3578 3579 Insert_Action (Cnode, 3580 Make_Object_Declaration (Loc, 3581 Defining_Identifier => Ent, 3582 Object_Definition => Subtyp_Ind)); 3583 end if; 3584 3585 -- If the result of the concatenation appears as the initializing 3586 -- expression of an object declaration, we can just rename the 3587 -- result, rather than copying it. 3588 3589 Set_OK_To_Rename (Ent); 3590 3591 -- Catch the static out of range case now 3592 3593 if Raises_Constraint_Error (High_Bound) then 3594 raise Concatenation_Error; 3595 end if; 3596 3597 -- Now we will generate the assignments to do the actual concatenation 3598 3599 -- There is one case in which we will not do this, namely when all the 3600 -- following conditions are met: 3601 3602 -- The result type is Standard.String 3603 3604 -- There are nine or fewer retained (non-null) operands 3605 3606 -- The optimization level is -O0 or the debug flag gnatd.C is set, 3607 -- and the debug flag gnatd.c is not set. 3608 3609 -- The corresponding System.Concat_n.Str_Concat_n routine is 3610 -- available in the run time. 3611 3612 -- If all these conditions are met then we generate a call to the 3613 -- relevant concatenation routine. The purpose of this is to avoid 3614 -- undesirable code bloat at -O0. 3615 3616 -- If the concatenation is within the declaration of a library-level 3617 -- object, we call the built-in concatenation routines to prevent code 3618 -- bloat, regardless of the optimization level. This is space efficient 3619 -- and prevents linking problems when units are compiled with different 3620 -- optimization levels. 3621 3622 if Atyp = Standard_String 3623 and then NN in 2 .. 9 3624 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC) 3625 and then not Debug_Flag_Dot_C) 3626 or else Library_Level_Target) 3627 then 3628 declare 3629 RR : constant array (Nat range 2 .. 9) of RE_Id := 3630 (RE_Str_Concat_2, 3631 RE_Str_Concat_3, 3632 RE_Str_Concat_4, 3633 RE_Str_Concat_5, 3634 RE_Str_Concat_6, 3635 RE_Str_Concat_7, 3636 RE_Str_Concat_8, 3637 RE_Str_Concat_9); 3638 3639 begin 3640 if RTE_Available (RR (NN)) then 3641 declare 3642 Opnds : constant List_Id := 3643 New_List (New_Occurrence_Of (Ent, Loc)); 3644 3645 begin 3646 for J in 1 .. NN loop 3647 if Is_List_Member (Operands (J)) then 3648 Remove (Operands (J)); 3649 end if; 3650 3651 if Base_Type (Etype (Operands (J))) = Ctyp then 3652 Append_To (Opnds, 3653 Make_Aggregate (Loc, 3654 Component_Associations => New_List ( 3655 Make_Component_Association (Loc, 3656 Choices => New_List ( 3657 Make_Integer_Literal (Loc, 1)), 3658 Expression => Operands (J))))); 3659 3660 else 3661 Append_To (Opnds, Operands (J)); 3662 end if; 3663 end loop; 3664 3665 Insert_Action (Cnode, 3666 Make_Procedure_Call_Statement (Loc, 3667 Name => New_Occurrence_Of (RTE (RR (NN)), Loc), 3668 Parameter_Associations => Opnds)); 3669 3670 Result := New_Occurrence_Of (Ent, Loc); 3671 goto Done; 3672 end; 3673 end if; 3674 end; 3675 end if; 3676 3677 -- Not special case so generate the assignments 3678 3679 Known_Non_Null_Operand_Seen := False; 3680 3681 for J in 1 .. NN loop 3682 declare 3683 Lo : constant Node_Id := 3684 Make_Op_Add (Loc, 3685 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3686 Right_Opnd => Aggr_Length (J - 1)); 3687 3688 Hi : constant Node_Id := 3689 Make_Op_Add (Loc, 3690 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)), 3691 Right_Opnd => 3692 Make_Op_Subtract (Loc, 3693 Left_Opnd => Aggr_Length (J), 3694 Right_Opnd => Make_Artyp_Literal (1))); 3695 3696 begin 3697 -- Singleton case, simple assignment 3698 3699 if Base_Type (Etype (Operands (J))) = Ctyp then 3700 Known_Non_Null_Operand_Seen := True; 3701 Insert_Action (Cnode, 3702 Make_Assignment_Statement (Loc, 3703 Name => 3704 Make_Indexed_Component (Loc, 3705 Prefix => New_Occurrence_Of (Ent, Loc), 3706 Expressions => New_List (To_Ityp (Lo))), 3707 Expression => Operands (J)), 3708 Suppress => All_Checks); 3709 3710 -- Array case, slice assignment, skipped when argument is fixed 3711 -- length and known to be null. 3712 3713 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then 3714 declare 3715 Assign : Node_Id := 3716 Make_Assignment_Statement (Loc, 3717 Name => 3718 Make_Slice (Loc, 3719 Prefix => 3720 New_Occurrence_Of (Ent, Loc), 3721 Discrete_Range => 3722 Make_Range (Loc, 3723 Low_Bound => To_Ityp (Lo), 3724 High_Bound => To_Ityp (Hi))), 3725 Expression => Operands (J)); 3726 begin 3727 if Is_Fixed_Length (J) then 3728 Known_Non_Null_Operand_Seen := True; 3729 3730 elsif not Known_Non_Null_Operand_Seen then 3731 3732 -- Here if operand length is not statically known and no 3733 -- operand known to be non-null has been processed yet. 3734 -- If operand length is 0, we do not need to perform the 3735 -- assignment, and we must avoid the evaluation of the 3736 -- high bound of the slice, since it may underflow if the 3737 -- low bound is Ityp'First. 3738 3739 Assign := 3740 Make_Implicit_If_Statement (Cnode, 3741 Condition => 3742 Make_Op_Ne (Loc, 3743 Left_Opnd => 3744 New_Occurrence_Of (Var_Length (J), Loc), 3745 Right_Opnd => Make_Integer_Literal (Loc, 0)), 3746 Then_Statements => New_List (Assign)); 3747 end if; 3748 3749 Insert_Action (Cnode, Assign, Suppress => All_Checks); 3750 end; 3751 end if; 3752 end; 3753 end loop; 3754 3755 -- Finally we build the result, which is a reference to the array object 3756 3757 Result := New_Occurrence_Of (Ent, Loc); 3758 3759 <<Done>> 3760 pragma Assert (Present (Result)); 3761 Rewrite (Cnode, Result); 3762 Analyze_And_Resolve (Cnode, Atyp); 3763 3764 exception 3765 when Concatenation_Error => 3766 3767 -- Kill warning generated for the declaration of the static out of 3768 -- range high bound, and instead generate a Constraint_Error with 3769 -- an appropriate specific message. 3770 3771 Kill_Dead_Code (Declaration_Node (Entity (High_Bound))); 3772 Apply_Compile_Time_Constraint_Error 3773 (N => Cnode, 3774 Msg => "concatenation result upper bound out of range??", 3775 Reason => CE_Range_Check_Failed); 3776 end Expand_Concatenate; 3777 3778 --------------------------------------------------- 3779 -- Expand_Membership_Minimize_Eliminate_Overflow -- 3780 --------------------------------------------------- 3781 3782 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is 3783 pragma Assert (Nkind (N) = N_In); 3784 -- Despite the name, this routine applies only to N_In, not to 3785 -- N_Not_In. The latter is always rewritten as not (X in Y). 3786 3787 Result_Type : constant Entity_Id := Etype (N); 3788 -- Capture result type, may be a derived boolean type 3789 3790 Loc : constant Source_Ptr := Sloc (N); 3791 Lop : constant Node_Id := Left_Opnd (N); 3792 Rop : constant Node_Id := Right_Opnd (N); 3793 3794 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It 3795 -- is thus tempting to capture these values, but due to the rewrites 3796 -- that occur as a result of overflow checking, these values change 3797 -- as we go along, and it is safe just to always use Etype explicitly. 3798 3799 Restype : constant Entity_Id := Etype (N); 3800 -- Save result type 3801 3802 Lo, Hi : Uint; 3803 -- Bounds in Minimize calls, not used currently 3804 3805 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 3806 -- Entity for Long_Long_Integer'Base (Standard should export this???) 3807 3808 begin 3809 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False); 3810 3811 -- If right operand is a subtype name, and the subtype name has no 3812 -- predicate, then we can just replace the right operand with an 3813 -- explicit range T'First .. T'Last, and use the explicit range code. 3814 3815 if Nkind (Rop) /= N_Range 3816 and then No (Predicate_Function (Etype (Rop))) 3817 then 3818 declare 3819 Rtyp : constant Entity_Id := Etype (Rop); 3820 begin 3821 Rewrite (Rop, 3822 Make_Range (Loc, 3823 Low_Bound => 3824 Make_Attribute_Reference (Loc, 3825 Attribute_Name => Name_First, 3826 Prefix => New_Occurrence_Of (Rtyp, Loc)), 3827 High_Bound => 3828 Make_Attribute_Reference (Loc, 3829 Attribute_Name => Name_Last, 3830 Prefix => New_Occurrence_Of (Rtyp, Loc)))); 3831 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks); 3832 end; 3833 end if; 3834 3835 -- Here for the explicit range case. Note that the bounds of the range 3836 -- have not been processed for minimized or eliminated checks. 3837 3838 if Nkind (Rop) = N_Range then 3839 Minimize_Eliminate_Overflows 3840 (Low_Bound (Rop), Lo, Hi, Top_Level => False); 3841 Minimize_Eliminate_Overflows 3842 (High_Bound (Rop), Lo, Hi, Top_Level => False); 3843 3844 -- We have A in B .. C, treated as A >= B and then A <= C 3845 3846 -- Bignum case 3847 3848 if Is_RTE (Etype (Lop), RE_Bignum) 3849 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum) 3850 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum) 3851 then 3852 declare 3853 Blk : constant Node_Id := Make_Bignum_Block (Loc); 3854 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 3855 L : constant Entity_Id := 3856 Make_Defining_Identifier (Loc, Name_uL); 3857 Lopnd : constant Node_Id := Convert_To_Bignum (Lop); 3858 Lbound : constant Node_Id := 3859 Convert_To_Bignum (Low_Bound (Rop)); 3860 Hbound : constant Node_Id := 3861 Convert_To_Bignum (High_Bound (Rop)); 3862 3863 -- Now we rewrite the membership test node to look like 3864 3865 -- do 3866 -- Bnn : Result_Type; 3867 -- declare 3868 -- M : Mark_Id := SS_Mark; 3869 -- L : Bignum := Lopnd; 3870 -- begin 3871 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound) 3872 -- SS_Release (M); 3873 -- end; 3874 -- in 3875 -- Bnn 3876 -- end 3877 3878 begin 3879 -- Insert declaration of L into declarations of bignum block 3880 3881 Insert_After 3882 (Last (Declarations (Blk)), 3883 Make_Object_Declaration (Loc, 3884 Defining_Identifier => L, 3885 Object_Definition => 3886 New_Occurrence_Of (RTE (RE_Bignum), Loc), 3887 Expression => Lopnd)); 3888 3889 -- Insert assignment to Bnn into expressions of bignum block 3890 3891 Insert_Before 3892 (First (Statements (Handled_Statement_Sequence (Blk))), 3893 Make_Assignment_Statement (Loc, 3894 Name => New_Occurrence_Of (Bnn, Loc), 3895 Expression => 3896 Make_And_Then (Loc, 3897 Left_Opnd => 3898 Make_Function_Call (Loc, 3899 Name => 3900 New_Occurrence_Of (RTE (RE_Big_GE), Loc), 3901 Parameter_Associations => New_List ( 3902 New_Occurrence_Of (L, Loc), 3903 Lbound)), 3904 3905 Right_Opnd => 3906 Make_Function_Call (Loc, 3907 Name => 3908 New_Occurrence_Of (RTE (RE_Big_LE), Loc), 3909 Parameter_Associations => New_List ( 3910 New_Occurrence_Of (L, Loc), 3911 Hbound))))); 3912 3913 -- Now rewrite the node 3914 3915 Rewrite (N, 3916 Make_Expression_With_Actions (Loc, 3917 Actions => New_List ( 3918 Make_Object_Declaration (Loc, 3919 Defining_Identifier => Bnn, 3920 Object_Definition => 3921 New_Occurrence_Of (Result_Type, Loc)), 3922 Blk), 3923 Expression => New_Occurrence_Of (Bnn, Loc))); 3924 Analyze_And_Resolve (N, Result_Type); 3925 return; 3926 end; 3927 3928 -- Here if no bignums around 3929 3930 else 3931 -- Case where types are all the same 3932 3933 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop))) 3934 and then 3935 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop))) 3936 then 3937 null; 3938 3939 -- If types are not all the same, it means that we have rewritten 3940 -- at least one of them to be of type Long_Long_Integer, and we 3941 -- will convert the other operands to Long_Long_Integer. 3942 3943 else 3944 Convert_To_And_Rewrite (LLIB, Lop); 3945 Set_Analyzed (Lop, False); 3946 Analyze_And_Resolve (Lop, LLIB); 3947 3948 -- For the right operand, avoid unnecessary recursion into 3949 -- this routine, we know that overflow is not possible. 3950 3951 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop)); 3952 Convert_To_And_Rewrite (LLIB, High_Bound (Rop)); 3953 Set_Analyzed (Rop, False); 3954 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check); 3955 end if; 3956 3957 -- Now the three operands are of the same signed integer type, 3958 -- so we can use the normal expansion routine for membership, 3959 -- setting the flag to prevent recursion into this procedure. 3960 3961 Set_No_Minimize_Eliminate (N); 3962 Expand_N_In (N); 3963 end if; 3964 3965 -- Right operand is a subtype name and the subtype has a predicate. We 3966 -- have to make sure the predicate is checked, and for that we need to 3967 -- use the standard N_In circuitry with appropriate types. 3968 3969 else 3970 pragma Assert (Present (Predicate_Function (Etype (Rop)))); 3971 3972 -- If types are "right", just call Expand_N_In preventing recursion 3973 3974 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then 3975 Set_No_Minimize_Eliminate (N); 3976 Expand_N_In (N); 3977 3978 -- Bignum case 3979 3980 elsif Is_RTE (Etype (Lop), RE_Bignum) then 3981 3982 -- For X in T, we want to rewrite our node as 3983 3984 -- do 3985 -- Bnn : Result_Type; 3986 3987 -- declare 3988 -- M : Mark_Id := SS_Mark; 3989 -- Lnn : Long_Long_Integer'Base 3990 -- Nnn : Bignum; 3991 3992 -- begin 3993 -- Nnn := X; 3994 3995 -- if not Bignum_In_LLI_Range (Nnn) then 3996 -- Bnn := False; 3997 -- else 3998 -- Lnn := From_Bignum (Nnn); 3999 -- Bnn := 4000 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last) 4001 -- and then T'Base (Lnn) in T; 4002 -- end if; 4003 4004 -- SS_Release (M); 4005 -- end 4006 -- in 4007 -- Bnn 4008 -- end 4009 4010 -- A bit gruesome, but there doesn't seem to be a simpler way 4011 4012 declare 4013 Blk : constant Node_Id := Make_Bignum_Block (Loc); 4014 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); 4015 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N); 4016 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N); 4017 T : constant Entity_Id := Etype (Rop); 4018 TB : constant Entity_Id := Base_Type (T); 4019 Nin : Node_Id; 4020 4021 begin 4022 -- Mark the last membership operation to prevent recursion 4023 4024 Nin := 4025 Make_In (Loc, 4026 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)), 4027 Right_Opnd => New_Occurrence_Of (T, Loc)); 4028 Set_No_Minimize_Eliminate (Nin); 4029 4030 -- Now decorate the block 4031 4032 Insert_After 4033 (Last (Declarations (Blk)), 4034 Make_Object_Declaration (Loc, 4035 Defining_Identifier => Lnn, 4036 Object_Definition => New_Occurrence_Of (LLIB, Loc))); 4037 4038 Insert_After 4039 (Last (Declarations (Blk)), 4040 Make_Object_Declaration (Loc, 4041 Defining_Identifier => Nnn, 4042 Object_Definition => 4043 New_Occurrence_Of (RTE (RE_Bignum), Loc))); 4044 4045 Insert_List_Before 4046 (First (Statements (Handled_Statement_Sequence (Blk))), 4047 New_List ( 4048 Make_Assignment_Statement (Loc, 4049 Name => New_Occurrence_Of (Nnn, Loc), 4050 Expression => Relocate_Node (Lop)), 4051 4052 Make_Implicit_If_Statement (N, 4053 Condition => 4054 Make_Op_Not (Loc, 4055 Right_Opnd => 4056 Make_Function_Call (Loc, 4057 Name => 4058 New_Occurrence_Of 4059 (RTE (RE_Bignum_In_LLI_Range), Loc), 4060 Parameter_Associations => New_List ( 4061 New_Occurrence_Of (Nnn, Loc)))), 4062 4063 Then_Statements => New_List ( 4064 Make_Assignment_Statement (Loc, 4065 Name => New_Occurrence_Of (Bnn, Loc), 4066 Expression => 4067 New_Occurrence_Of (Standard_False, Loc))), 4068 4069 Else_Statements => New_List ( 4070 Make_Assignment_Statement (Loc, 4071 Name => New_Occurrence_Of (Lnn, Loc), 4072 Expression => 4073 Make_Function_Call (Loc, 4074 Name => 4075 New_Occurrence_Of (RTE (RE_From_Bignum), Loc), 4076 Parameter_Associations => New_List ( 4077 New_Occurrence_Of (Nnn, Loc)))), 4078 4079 Make_Assignment_Statement (Loc, 4080 Name => New_Occurrence_Of (Bnn, Loc), 4081 Expression => 4082 Make_And_Then (Loc, 4083 Left_Opnd => 4084 Make_In (Loc, 4085 Left_Opnd => New_Occurrence_Of (Lnn, Loc), 4086 Right_Opnd => 4087 Make_Range (Loc, 4088 Low_Bound => 4089 Convert_To (LLIB, 4090 Make_Attribute_Reference (Loc, 4091 Attribute_Name => Name_First, 4092 Prefix => 4093 New_Occurrence_Of (TB, Loc))), 4094 4095 High_Bound => 4096 Convert_To (LLIB, 4097 Make_Attribute_Reference (Loc, 4098 Attribute_Name => Name_Last, 4099 Prefix => 4100 New_Occurrence_Of (TB, Loc))))), 4101 4102 Right_Opnd => Nin)))))); 4103 4104 -- Now we can do the rewrite 4105 4106 Rewrite (N, 4107 Make_Expression_With_Actions (Loc, 4108 Actions => New_List ( 4109 Make_Object_Declaration (Loc, 4110 Defining_Identifier => Bnn, 4111 Object_Definition => 4112 New_Occurrence_Of (Result_Type, Loc)), 4113 Blk), 4114 Expression => New_Occurrence_Of (Bnn, Loc))); 4115 Analyze_And_Resolve (N, Result_Type); 4116 return; 4117 end; 4118 4119 -- Not bignum case, but types don't match (this means we rewrote the 4120 -- left operand to be Long_Long_Integer). 4121 4122 else 4123 pragma Assert (Base_Type (Etype (Lop)) = LLIB); 4124 4125 -- We rewrite the membership test as (where T is the type with 4126 -- the predicate, i.e. the type of the right operand) 4127 4128 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last) 4129 -- and then T'Base (Lop) in T 4130 4131 declare 4132 T : constant Entity_Id := Etype (Rop); 4133 TB : constant Entity_Id := Base_Type (T); 4134 Nin : Node_Id; 4135 4136 begin 4137 -- The last membership test is marked to prevent recursion 4138 4139 Nin := 4140 Make_In (Loc, 4141 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)), 4142 Right_Opnd => New_Occurrence_Of (T, Loc)); 4143 Set_No_Minimize_Eliminate (Nin); 4144 4145 -- Now do the rewrite 4146 4147 Rewrite (N, 4148 Make_And_Then (Loc, 4149 Left_Opnd => 4150 Make_In (Loc, 4151 Left_Opnd => Lop, 4152 Right_Opnd => 4153 Make_Range (Loc, 4154 Low_Bound => 4155 Convert_To (LLIB, 4156 Make_Attribute_Reference (Loc, 4157 Attribute_Name => Name_First, 4158 Prefix => 4159 New_Occurrence_Of (TB, Loc))), 4160 High_Bound => 4161 Convert_To (LLIB, 4162 Make_Attribute_Reference (Loc, 4163 Attribute_Name => Name_Last, 4164 Prefix => 4165 New_Occurrence_Of (TB, Loc))))), 4166 Right_Opnd => Nin)); 4167 Set_Analyzed (N, False); 4168 Analyze_And_Resolve (N, Restype); 4169 end; 4170 end if; 4171 end if; 4172 end Expand_Membership_Minimize_Eliminate_Overflow; 4173 4174 --------------------------------- 4175 -- Expand_Nonbinary_Modular_Op -- 4176 --------------------------------- 4177 4178 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is 4179 Loc : constant Source_Ptr := Sloc (N); 4180 Typ : constant Entity_Id := Etype (N); 4181 4182 procedure Expand_Modular_Addition; 4183 -- Expand the modular addition, handling the special case of adding a 4184 -- constant. 4185 4186 procedure Expand_Modular_Op; 4187 -- Compute the general rule: (lhs OP rhs) mod Modulus 4188 4189 procedure Expand_Modular_Subtraction; 4190 -- Expand the modular addition, handling the special case of subtracting 4191 -- a constant. 4192 4193 ----------------------------- 4194 -- Expand_Modular_Addition -- 4195 ----------------------------- 4196 4197 procedure Expand_Modular_Addition is 4198 begin 4199 -- If this is not the addition of a constant then compute it using 4200 -- the general rule: (lhs + rhs) mod Modulus 4201 4202 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then 4203 Expand_Modular_Op; 4204 4205 -- If this is an addition of a constant, convert it to a subtraction 4206 -- plus a conditional expression since we can compute it faster than 4207 -- computing the modulus. 4208 4209 -- modMinusRhs = Modulus - rhs 4210 -- if lhs < modMinusRhs then lhs + rhs 4211 -- else lhs - modMinusRhs 4212 4213 else 4214 declare 4215 Mod_Minus_Right : constant Uint := 4216 Modulus (Typ) - Intval (Right_Opnd (N)); 4217 4218 Exprs : constant List_Id := New_List; 4219 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); 4220 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); 4221 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, 4222 Loc); 4223 begin 4224 -- To prevent spurious visibility issues, convert all 4225 -- operands to Standard.Unsigned. 4226 4227 Set_Left_Opnd (Cond_Expr, 4228 Unchecked_Convert_To (Standard_Unsigned, 4229 New_Copy_Tree (Left_Opnd (N)))); 4230 Set_Right_Opnd (Cond_Expr, 4231 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4232 Append_To (Exprs, Cond_Expr); 4233 4234 Set_Left_Opnd (Then_Expr, 4235 Unchecked_Convert_To (Standard_Unsigned, 4236 New_Copy_Tree (Left_Opnd (N)))); 4237 Set_Right_Opnd (Then_Expr, 4238 Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); 4239 Append_To (Exprs, Then_Expr); 4240 4241 Set_Left_Opnd (Else_Expr, 4242 Unchecked_Convert_To (Standard_Unsigned, 4243 New_Copy_Tree (Left_Opnd (N)))); 4244 Set_Right_Opnd (Else_Expr, 4245 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4246 Append_To (Exprs, Else_Expr); 4247 4248 Rewrite (N, 4249 Unchecked_Convert_To (Typ, 4250 Make_If_Expression (Loc, Expressions => Exprs))); 4251 end; 4252 end if; 4253 end Expand_Modular_Addition; 4254 4255 ----------------------- 4256 -- Expand_Modular_Op -- 4257 ----------------------- 4258 4259 procedure Expand_Modular_Op is 4260 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc); 4261 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc); 4262 4263 Target_Type : Entity_Id; 4264 4265 begin 4266 -- Convert nonbinary modular type operands into integer values. Thus 4267 -- we avoid never-ending loops expanding them, and we also ensure 4268 -- the back end never receives nonbinary modular type expressions. 4269 4270 if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then 4271 Set_Left_Opnd (Op_Expr, 4272 Unchecked_Convert_To (Standard_Unsigned, 4273 New_Copy_Tree (Left_Opnd (N)))); 4274 Set_Right_Opnd (Op_Expr, 4275 Unchecked_Convert_To (Standard_Unsigned, 4276 New_Copy_Tree (Right_Opnd (N)))); 4277 Set_Left_Opnd (Mod_Expr, 4278 Unchecked_Convert_To (Standard_Integer, Op_Expr)); 4279 4280 else 4281 -- If the modulus of the type is larger than Integer'Last use a 4282 -- larger type for the operands, to prevent spurious constraint 4283 -- errors on large legal literals of the type. 4284 4285 if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then 4286 Target_Type := Standard_Long_Long_Integer; 4287 else 4288 Target_Type := Standard_Integer; 4289 end if; 4290 4291 Set_Left_Opnd (Op_Expr, 4292 Unchecked_Convert_To (Target_Type, 4293 New_Copy_Tree (Left_Opnd (N)))); 4294 Set_Right_Opnd (Op_Expr, 4295 Unchecked_Convert_To (Target_Type, 4296 New_Copy_Tree (Right_Opnd (N)))); 4297 4298 -- Link this node to the tree to analyze it 4299 4300 -- If the parent node is an expression with actions we link it to 4301 -- N since otherwise Force_Evaluation cannot identify if this node 4302 -- comes from the Expression and rejects generating the temporary. 4303 4304 if Nkind (Parent (N)) = N_Expression_With_Actions then 4305 Set_Parent (Op_Expr, N); 4306 4307 -- Common case 4308 4309 else 4310 Set_Parent (Op_Expr, Parent (N)); 4311 end if; 4312 4313 Analyze (Op_Expr); 4314 4315 -- Force generating a temporary because in the expansion of this 4316 -- expression we may generate code that performs this computation 4317 -- several times. 4318 4319 Force_Evaluation (Op_Expr, Mode => Strict); 4320 4321 Set_Left_Opnd (Mod_Expr, Op_Expr); 4322 end if; 4323 4324 Set_Right_Opnd (Mod_Expr, 4325 Make_Integer_Literal (Loc, Modulus (Typ))); 4326 4327 Rewrite (N, 4328 Unchecked_Convert_To (Typ, Mod_Expr)); 4329 end Expand_Modular_Op; 4330 4331 -------------------------------- 4332 -- Expand_Modular_Subtraction -- 4333 -------------------------------- 4334 4335 procedure Expand_Modular_Subtraction is 4336 begin 4337 -- If this is not the addition of a constant then compute it using 4338 -- the general rule: (lhs + rhs) mod Modulus 4339 4340 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then 4341 Expand_Modular_Op; 4342 4343 -- If this is an addition of a constant, convert it to a subtraction 4344 -- plus a conditional expression since we can compute it faster than 4345 -- computing the modulus. 4346 4347 -- modMinusRhs = Modulus - rhs 4348 -- if lhs < rhs then lhs + modMinusRhs 4349 -- else lhs - rhs 4350 4351 else 4352 declare 4353 Mod_Minus_Right : constant Uint := 4354 Modulus (Typ) - Intval (Right_Opnd (N)); 4355 4356 Exprs : constant List_Id := New_List; 4357 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); 4358 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); 4359 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, 4360 Loc); 4361 begin 4362 Set_Left_Opnd (Cond_Expr, 4363 Unchecked_Convert_To (Standard_Unsigned, 4364 New_Copy_Tree (Left_Opnd (N)))); 4365 Set_Right_Opnd (Cond_Expr, 4366 Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); 4367 Append_To (Exprs, Cond_Expr); 4368 4369 Set_Left_Opnd (Then_Expr, 4370 Unchecked_Convert_To (Standard_Unsigned, 4371 New_Copy_Tree (Left_Opnd (N)))); 4372 Set_Right_Opnd (Then_Expr, 4373 Make_Integer_Literal (Loc, Mod_Minus_Right)); 4374 Append_To (Exprs, Then_Expr); 4375 4376 Set_Left_Opnd (Else_Expr, 4377 Unchecked_Convert_To (Standard_Unsigned, 4378 New_Copy_Tree (Left_Opnd (N)))); 4379 Set_Right_Opnd (Else_Expr, 4380 Unchecked_Convert_To (Standard_Unsigned, 4381 New_Copy_Tree (Right_Opnd (N)))); 4382 Append_To (Exprs, Else_Expr); 4383 4384 Rewrite (N, 4385 Unchecked_Convert_To (Typ, 4386 Make_If_Expression (Loc, Expressions => Exprs))); 4387 end; 4388 end if; 4389 end Expand_Modular_Subtraction; 4390 4391 -- Start of processing for Expand_Nonbinary_Modular_Op 4392 4393 begin 4394 -- No action needed if front-end expansion is not required or if we 4395 -- have a binary modular operand. 4396 4397 if not Expand_Nonbinary_Modular_Ops 4398 or else not Non_Binary_Modulus (Typ) 4399 then 4400 return; 4401 end if; 4402 4403 case Nkind (N) is 4404 when N_Op_Add => 4405 Expand_Modular_Addition; 4406 4407 when N_Op_Subtract => 4408 Expand_Modular_Subtraction; 4409 4410 when N_Op_Minus => 4411 4412 -- Expand -expr into (0 - expr) 4413 4414 Rewrite (N, 4415 Make_Op_Subtract (Loc, 4416 Left_Opnd => Make_Integer_Literal (Loc, 0), 4417 Right_Opnd => Right_Opnd (N))); 4418 Analyze_And_Resolve (N, Typ); 4419 4420 when others => 4421 Expand_Modular_Op; 4422 end case; 4423 4424 Analyze_And_Resolve (N, Typ); 4425 end Expand_Nonbinary_Modular_Op; 4426 4427 ------------------------ 4428 -- Expand_N_Allocator -- 4429 ------------------------ 4430 4431 procedure Expand_N_Allocator (N : Node_Id) is 4432 Etyp : constant Entity_Id := Etype (Expression (N)); 4433 Loc : constant Source_Ptr := Sloc (N); 4434 PtrT : constant Entity_Id := Etype (N); 4435 4436 procedure Rewrite_Coextension (N : Node_Id); 4437 -- Static coextensions have the same lifetime as the entity they 4438 -- constrain. Such occurrences can be rewritten as aliased objects 4439 -- and their unrestricted access used instead of the coextension. 4440 4441 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; 4442 -- Given a constrained array type E, returns a node representing the 4443 -- code to compute a close approximation of the size in storage elements 4444 -- for the given type; for indexes that are modular types we compute 4445 -- 'Last - First (instead of 'Length) because for large arrays computing 4446 -- 'Last -'First + 1 causes overflow. This is done without using the 4447 -- attribute 'Size_In_Storage_Elements (which malfunctions for large 4448 -- sizes ???). 4449 4450 ------------------------- 4451 -- Rewrite_Coextension -- 4452 ------------------------- 4453 4454 procedure Rewrite_Coextension (N : Node_Id) is 4455 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C'); 4456 Temp_Decl : Node_Id; 4457 4458 begin 4459 -- Generate: 4460 -- Cnn : aliased Etyp; 4461 4462 Temp_Decl := 4463 Make_Object_Declaration (Loc, 4464 Defining_Identifier => Temp_Id, 4465 Aliased_Present => True, 4466 Object_Definition => New_Occurrence_Of (Etyp, Loc)); 4467 4468 if Nkind (Expression (N)) = N_Qualified_Expression then 4469 Set_Expression (Temp_Decl, Expression (Expression (N))); 4470 end if; 4471 4472 Insert_Action (N, Temp_Decl); 4473 Rewrite (N, 4474 Make_Attribute_Reference (Loc, 4475 Prefix => New_Occurrence_Of (Temp_Id, Loc), 4476 Attribute_Name => Name_Unrestricted_Access)); 4477 4478 Analyze_And_Resolve (N, PtrT); 4479 end Rewrite_Coextension; 4480 4481 ------------------------------ 4482 -- Size_In_Storage_Elements -- 4483 ------------------------------ 4484 4485 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is 4486 begin 4487 -- Logically this just returns E'Max_Size_In_Storage_Elements. 4488 -- However, the reason for the existence of this function is 4489 -- to construct a test for sizes too large, which means near the 4490 -- 32-bit limit on a 32-bit machine, and precisely the trouble 4491 -- is that we get overflows when sizes are greater than 2**31. 4492 4493 -- So what we end up doing for array types is to use the expression: 4494 4495 -- number-of-elements * component_type'Max_Size_In_Storage_Elements 4496 4497 -- which avoids this problem. All this is a bit bogus, but it does 4498 -- mean we catch common cases of trying to allocate arrays that 4499 -- are too large, and which in the absence of a check results in 4500 -- undetected chaos ??? 4501 4502 -- Note in particular that this is a pessimistic estimate in the 4503 -- case of packed array types, where an array element might occupy 4504 -- just a fraction of a storage element??? 4505 4506 declare 4507 Idx : Node_Id := First_Index (E); 4508 Len : Node_Id; 4509 Res : Node_Id := Empty; 4510 4511 begin 4512 for J in 1 .. Number_Dimensions (E) loop 4513 4514 if not Is_Modular_Integer_Type (Etype (Idx)) then 4515 Len := 4516 Make_Attribute_Reference (Loc, 4517 Prefix => New_Occurrence_Of (E, Loc), 4518 Attribute_Name => Name_Length, 4519 Expressions => New_List 4520 (Make_Integer_Literal (Loc, J))); 4521 4522 -- For indexes that are modular types we cannot generate code 4523 -- to compute 'Length since for large arrays 'Last -'First + 1 4524 -- causes overflow; therefore we compute 'Last - 'First (which 4525 -- is not the exact number of components but it is valid for 4526 -- the purpose of this runtime check on 32-bit targets). 4527 4528 else 4529 declare 4530 Len_Minus_1_Expr : Node_Id; 4531 Test_Gt : Node_Id; 4532 4533 begin 4534 Test_Gt := 4535 Make_Op_Gt (Loc, 4536 Make_Attribute_Reference (Loc, 4537 Prefix => New_Occurrence_Of (E, Loc), 4538 Attribute_Name => Name_Last, 4539 Expressions => 4540 New_List (Make_Integer_Literal (Loc, J))), 4541 Make_Attribute_Reference (Loc, 4542 Prefix => New_Occurrence_Of (E, Loc), 4543 Attribute_Name => Name_First, 4544 Expressions => 4545 New_List (Make_Integer_Literal (Loc, J)))); 4546 4547 Len_Minus_1_Expr := 4548 Convert_To (Standard_Unsigned, 4549 Make_Op_Subtract (Loc, 4550 Make_Attribute_Reference (Loc, 4551 Prefix => New_Occurrence_Of (E, Loc), 4552 Attribute_Name => Name_Last, 4553 Expressions => 4554 New_List 4555 (Make_Integer_Literal (Loc, J))), 4556 Make_Attribute_Reference (Loc, 4557 Prefix => New_Occurrence_Of (E, Loc), 4558 Attribute_Name => Name_First, 4559 Expressions => 4560 New_List 4561 (Make_Integer_Literal (Loc, J))))); 4562 4563 -- Handle superflat arrays, i.e. arrays with such bounds 4564 -- as 4 .. 2, to ensure that the result is correct. 4565 4566 -- Generate: 4567 -- (if X'Last > X'First then X'Last - X'First else 0) 4568 4569 Len := 4570 Make_If_Expression (Loc, 4571 Expressions => New_List ( 4572 Test_Gt, 4573 Len_Minus_1_Expr, 4574 Make_Integer_Literal (Loc, Uint_0))); 4575 end; 4576 end if; 4577 4578 if J = 1 then 4579 Res := Len; 4580 4581 else 4582 pragma Assert (Present (Res)); 4583 Res := 4584 Make_Op_Multiply (Loc, 4585 Left_Opnd => Res, 4586 Right_Opnd => Len); 4587 end if; 4588 4589 Next_Index (Idx); 4590 end loop; 4591 4592 return 4593 Make_Op_Multiply (Loc, 4594 Left_Opnd => Len, 4595 Right_Opnd => 4596 Make_Attribute_Reference (Loc, 4597 Prefix => New_Occurrence_Of (Component_Type (E), Loc), 4598 Attribute_Name => Name_Max_Size_In_Storage_Elements)); 4599 end; 4600 end Size_In_Storage_Elements; 4601 4602 -- Local variables 4603 4604 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); 4605 Desig : Entity_Id; 4606 Nod : Node_Id; 4607 Pool : Entity_Id; 4608 Rel_Typ : Entity_Id; 4609 Temp : Entity_Id; 4610 4611 -- Start of processing for Expand_N_Allocator 4612 4613 begin 4614 -- Warn on the presence of an allocator of an anonymous access type when 4615 -- enabled, except when it's an object declaration at library level. 4616 4617 if Warn_On_Anonymous_Allocators 4618 and then Ekind (PtrT) = E_Anonymous_Access_Type 4619 and then not (Is_Library_Level_Entity (PtrT) 4620 and then Nkind (Associated_Node_For_Itype (PtrT)) = 4621 N_Object_Declaration) 4622 then 4623 Error_Msg_N ("??use of an anonymous access type allocator", N); 4624 end if; 4625 4626 -- RM E.2.2(17). We enforce that the expected type of an allocator 4627 -- shall not be a remote access-to-class-wide-limited-private type 4628 4629 -- Why is this being done at expansion time, seems clearly wrong ??? 4630 4631 Validate_Remote_Access_To_Class_Wide_Type (N); 4632 4633 -- Processing for anonymous access-to-controlled types. These access 4634 -- types receive a special finalization master which appears in the 4635 -- declarations of the enclosing semantic unit. This expansion is done 4636 -- now to ensure that any additional types generated by this routine or 4637 -- Expand_Allocator_Expression inherit the proper type attributes. 4638 4639 if (Ekind (PtrT) = E_Anonymous_Access_Type 4640 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT)))) 4641 and then Needs_Finalization (Dtyp) 4642 then 4643 -- Detect the allocation of an anonymous controlled object where the 4644 -- type of the context is named. For example: 4645 4646 -- procedure Proc (Ptr : Named_Access_Typ); 4647 -- Proc (new Designated_Typ); 4648 4649 -- Regardless of the anonymous-to-named access type conversion, the 4650 -- lifetime of the object must be associated with the named access 4651 -- type. Use the finalization-related attributes of this type. 4652 4653 if Nkind (Parent (N)) in N_Type_Conversion 4654 | N_Unchecked_Type_Conversion 4655 and then Ekind (Etype (Parent (N))) in E_Access_Subtype 4656 | E_Access_Type 4657 | E_General_Access_Type 4658 then 4659 Rel_Typ := Etype (Parent (N)); 4660 else 4661 Rel_Typ := Empty; 4662 end if; 4663 4664 -- Anonymous access-to-controlled types allocate on the global pool. 4665 -- Note that this is a "root type only" attribute. 4666 4667 if No (Associated_Storage_Pool (PtrT)) then 4668 if Present (Rel_Typ) then 4669 Set_Associated_Storage_Pool 4670 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ)); 4671 else 4672 Set_Associated_Storage_Pool 4673 (Root_Type (PtrT), RTE (RE_Global_Pool_Object)); 4674 end if; 4675 end if; 4676 4677 -- The finalization master must be inserted and analyzed as part of 4678 -- the current semantic unit. Note that the master is updated when 4679 -- analysis changes current units. Note that this is a "root type 4680 -- only" attribute. 4681 4682 if Present (Rel_Typ) then 4683 Set_Finalization_Master 4684 (Root_Type (PtrT), Finalization_Master (Rel_Typ)); 4685 else 4686 Build_Anonymous_Master (Root_Type (PtrT)); 4687 end if; 4688 end if; 4689 4690 -- Set the storage pool and find the appropriate version of Allocate to 4691 -- call. Do not overwrite the storage pool if it is already set, which 4692 -- can happen for build-in-place function returns (see 4693 -- Exp_Ch4.Expand_N_Extended_Return_Statement). 4694 4695 if No (Storage_Pool (N)) then 4696 Pool := Associated_Storage_Pool (Root_Type (PtrT)); 4697 4698 if Present (Pool) then 4699 Set_Storage_Pool (N, Pool); 4700 4701 if Is_RTE (Pool, RE_SS_Pool) then 4702 Check_Restriction (No_Secondary_Stack, N); 4703 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); 4704 4705 -- In the case of an allocator for a simple storage pool, locate 4706 -- and save a reference to the pool type's Allocate routine. 4707 4708 elsif Present (Get_Rep_Pragma 4709 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 4710 then 4711 declare 4712 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); 4713 Alloc_Op : Entity_Id; 4714 begin 4715 Alloc_Op := Get_Name_Entity_Id (Name_Allocate); 4716 while Present (Alloc_Op) loop 4717 if Scope (Alloc_Op) = Scope (Pool_Type) 4718 and then Present (First_Formal (Alloc_Op)) 4719 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 4720 then 4721 Set_Procedure_To_Call (N, Alloc_Op); 4722 exit; 4723 else 4724 Alloc_Op := Homonym (Alloc_Op); 4725 end if; 4726 end loop; 4727 end; 4728 4729 elsif Is_Class_Wide_Type (Etype (Pool)) then 4730 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); 4731 4732 else 4733 Set_Procedure_To_Call (N, 4734 Find_Prim_Op (Etype (Pool), Name_Allocate)); 4735 end if; 4736 end if; 4737 end if; 4738 4739 -- Under certain circumstances we can replace an allocator by an access 4740 -- to statically allocated storage. The conditions, as noted in AARM 4741 -- 3.10 (10c) are as follows: 4742 4743 -- Size and initial value is known at compile time 4744 -- Access type is access-to-constant 4745 4746 -- The allocator is not part of a constraint on a record component, 4747 -- because in that case the inserted actions are delayed until the 4748 -- record declaration is fully analyzed, which is too late for the 4749 -- analysis of the rewritten allocator. 4750 4751 if Is_Access_Constant (PtrT) 4752 and then Nkind (Expression (N)) = N_Qualified_Expression 4753 and then Compile_Time_Known_Value (Expression (Expression (N))) 4754 and then Size_Known_At_Compile_Time 4755 (Etype (Expression (Expression (N)))) 4756 and then not Is_Record_Type (Current_Scope) 4757 then 4758 -- Here we can do the optimization. For the allocator 4759 4760 -- new x'(y) 4761 4762 -- We insert an object declaration 4763 4764 -- Tnn : aliased x := y; 4765 4766 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is 4767 -- marked as requiring static allocation. 4768 4769 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); 4770 Desig := Subtype_Mark (Expression (N)); 4771 4772 -- If context is constrained, use constrained subtype directly, 4773 -- so that the constant is not labelled as having a nominally 4774 -- unconstrained subtype. 4775 4776 if Entity (Desig) = Base_Type (Dtyp) then 4777 Desig := New_Occurrence_Of (Dtyp, Loc); 4778 end if; 4779 4780 Insert_Action (N, 4781 Make_Object_Declaration (Loc, 4782 Defining_Identifier => Temp, 4783 Aliased_Present => True, 4784 Constant_Present => Is_Access_Constant (PtrT), 4785 Object_Definition => Desig, 4786 Expression => Expression (Expression (N)))); 4787 4788 Rewrite (N, 4789 Make_Attribute_Reference (Loc, 4790 Prefix => New_Occurrence_Of (Temp, Loc), 4791 Attribute_Name => Name_Unrestricted_Access)); 4792 4793 Analyze_And_Resolve (N, PtrT); 4794 4795 -- We set the variable as statically allocated, since we don't want 4796 -- it going on the stack of the current procedure. 4797 4798 Set_Is_Statically_Allocated (Temp); 4799 return; 4800 end if; 4801 4802 -- Same if the allocator is an access discriminant for a local object: 4803 -- instead of an allocator we create a local value and constrain the 4804 -- enclosing object with the corresponding access attribute. 4805 4806 if Is_Static_Coextension (N) then 4807 Rewrite_Coextension (N); 4808 return; 4809 end if; 4810 4811 -- Check for size too large, we do this because the back end misses 4812 -- proper checks here and can generate rubbish allocation calls when 4813 -- we are near the limit. We only do this for the 32-bit address case 4814 -- since that is from a practical point of view where we see a problem. 4815 4816 if System_Address_Size = 32 4817 and then not Storage_Checks_Suppressed (PtrT) 4818 and then not Storage_Checks_Suppressed (Dtyp) 4819 and then not Storage_Checks_Suppressed (Etyp) 4820 then 4821 -- The check we want to generate should look like 4822 4823 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then 4824 -- raise Storage_Error; 4825 -- end if; 4826 4827 -- where 3.5 gigabytes is a constant large enough to accommodate any 4828 -- reasonable request for. But we can't do it this way because at 4829 -- least at the moment we don't compute this attribute right, and 4830 -- can silently give wrong results when the result gets large. Since 4831 -- this is all about large results, that's bad, so instead we only 4832 -- apply the check for constrained arrays, and manually compute the 4833 -- value of the attribute ??? 4834 4835 -- The check on No_Initialization is used here to prevent generating 4836 -- this runtime check twice when the allocator is locally replaced by 4837 -- the expander with another one. 4838 4839 if Is_Array_Type (Etyp) and then not No_Initialization (N) then 4840 declare 4841 Cond : Node_Id; 4842 Ins_Nod : Node_Id := N; 4843 Siz_Typ : Entity_Id := Etyp; 4844 Expr : Node_Id; 4845 4846 begin 4847 -- For unconstrained array types initialized with a qualified 4848 -- expression we use its type to perform this check 4849 4850 if not Is_Constrained (Etyp) 4851 and then not No_Initialization (N) 4852 and then Nkind (Expression (N)) = N_Qualified_Expression 4853 then 4854 Expr := Expression (Expression (N)); 4855 Siz_Typ := Etype (Expression (Expression (N))); 4856 4857 -- If the qualified expression has been moved to an internal 4858 -- temporary (to remove side effects) then we must insert 4859 -- the runtime check before its declaration to ensure that 4860 -- the check is performed before the execution of the code 4861 -- computing the qualified expression. 4862 4863 if Nkind (Expr) = N_Identifier 4864 and then Is_Internal_Name (Chars (Expr)) 4865 and then 4866 Nkind (Parent (Entity (Expr))) = N_Object_Declaration 4867 then 4868 Ins_Nod := Parent (Entity (Expr)); 4869 else 4870 Ins_Nod := Expr; 4871 end if; 4872 end if; 4873 4874 if Is_Constrained (Siz_Typ) 4875 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype 4876 then 4877 -- For CCG targets, the largest array may have up to 2**31-1 4878 -- components (i.e. 2 gigabytes if each array component is 4879 -- one byte). This ensures that fat pointer fields do not 4880 -- overflow, since they are 32-bit integer types, and also 4881 -- ensures that 'Length can be computed at run time. 4882 4883 if Modify_Tree_For_C then 4884 Cond := 4885 Make_Op_Gt (Loc, 4886 Left_Opnd => Size_In_Storage_Elements (Siz_Typ), 4887 Right_Opnd => Make_Integer_Literal (Loc, 4888 Uint_2 ** 31 - Uint_1)); 4889 4890 -- For native targets the largest object is 3.5 gigabytes 4891 4892 else 4893 Cond := 4894 Make_Op_Gt (Loc, 4895 Left_Opnd => Size_In_Storage_Elements (Siz_Typ), 4896 Right_Opnd => Make_Integer_Literal (Loc, 4897 Uint_7 * (Uint_2 ** 29))); 4898 end if; 4899 4900 Insert_Action (Ins_Nod, 4901 Make_Raise_Storage_Error (Loc, 4902 Condition => Cond, 4903 Reason => SE_Object_Too_Large)); 4904 4905 if Entity (Cond) = Standard_True then 4906 Error_Msg_N 4907 ("object too large: Storage_Error will be raised at " 4908 & "run time??", N); 4909 end if; 4910 end if; 4911 end; 4912 end if; 4913 end if; 4914 4915 -- If no storage pool has been specified, or the storage pool 4916 -- is System.Pool_Global.Global_Pool_Object, and the restriction 4917 -- No_Standard_Allocators_After_Elaboration is present, then generate 4918 -- a call to Elaboration_Allocators.Check_Standard_Allocator. 4919 4920 if Nkind (N) = N_Allocator 4921 and then (No (Storage_Pool (N)) 4922 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object)) 4923 and then Restriction_Active (No_Standard_Allocators_After_Elaboration) 4924 then 4925 Insert_Action (N, 4926 Make_Procedure_Call_Statement (Loc, 4927 Name => 4928 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc))); 4929 end if; 4930 4931 -- Handle case of qualified expression (other than optimization above) 4932 4933 if Nkind (Expression (N)) = N_Qualified_Expression then 4934 Expand_Allocator_Expression (N); 4935 return; 4936 end if; 4937 4938 -- If the allocator is for a type which requires initialization, and 4939 -- there is no initial value (i.e. operand is a subtype indication 4940 -- rather than a qualified expression), then we must generate a call to 4941 -- the initialization routine using an expressions action node: 4942 4943 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] 4944 4945 -- Here ptr_T is the pointer type for the allocator, and T is the 4946 -- subtype of the allocator. A special case arises if the designated 4947 -- type of the access type is a task or contains tasks. In this case 4948 -- the call to Init (Temp.all ...) is replaced by code that ensures 4949 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block 4950 -- for details). In addition, if the type T is a task type, then the 4951 -- first argument to Init must be converted to the task record type. 4952 4953 declare 4954 T : constant Entity_Id := Etype (Expression (N)); 4955 Args : List_Id; 4956 Decls : List_Id; 4957 Decl : Node_Id; 4958 Discr : Elmt_Id; 4959 Init : Entity_Id; 4960 Init_Arg1 : Node_Id; 4961 Init_Call : Node_Id; 4962 Temp_Decl : Node_Id; 4963 Temp_Type : Entity_Id; 4964 4965 begin 4966 -- Apply constraint checks against designated subtype (RM 4.8(10/2)) 4967 -- but ignore the expression if the No_Initialization flag is set. 4968 -- Discriminant checks will be generated by the expansion below. 4969 4970 if Is_Array_Type (Dtyp) and then not No_Initialization (N) then 4971 Apply_Constraint_Check (Expression (N), Dtyp, No_Sliding => True); 4972 4973 Apply_Predicate_Check (Expression (N), Dtyp); 4974 4975 if Nkind (Expression (N)) = N_Raise_Constraint_Error then 4976 Rewrite (N, New_Copy (Expression (N))); 4977 Set_Etype (N, PtrT); 4978 return; 4979 end if; 4980 end if; 4981 4982 if No_Initialization (N) then 4983 4984 -- Even though this might be a simple allocation, create a custom 4985 -- Allocate if the context requires it. 4986 4987 if Present (Finalization_Master (PtrT)) then 4988 Build_Allocate_Deallocate_Proc 4989 (N => N, 4990 Is_Allocate => True); 4991 end if; 4992 4993 -- Optimize the default allocation of an array object when pragma 4994 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an 4995 -- in-place initialization aggregate which may be convert into a fast 4996 -- memset by the backend. 4997 4998 elsif Init_Or_Norm_Scalars 4999 and then Is_Array_Type (T) 5000 5001 -- The array must lack atomic components because they are treated 5002 -- as non-static, and as a result the backend will not initialize 5003 -- the memory in one go. 5004 5005 and then not Has_Atomic_Components (T) 5006 5007 -- The array must not be packed because the invalid values in 5008 -- System.Scalar_Values are multiples of Storage_Unit. 5009 5010 and then not Is_Packed (T) 5011 5012 -- The array must have static non-empty ranges, otherwise the 5013 -- backend cannot initialize the memory in one go. 5014 5015 and then Has_Static_Non_Empty_Array_Bounds (T) 5016 5017 -- The optimization is only relevant for arrays of scalar types 5018 5019 and then Is_Scalar_Type (Component_Type (T)) 5020 5021 -- Similar to regular array initialization using a type init proc, 5022 -- predicate checks are not performed because the initialization 5023 -- values are intentionally invalid, and may violate the predicate. 5024 5025 and then not Has_Predicates (Component_Type (T)) 5026 5027 -- The component type must have a single initialization value 5028 5029 and then Needs_Simple_Initialization 5030 (Typ => Component_Type (T), 5031 Consider_IS => True) 5032 then 5033 Set_Analyzed (N); 5034 Temp := Make_Temporary (Loc, 'P'); 5035 5036 -- Generate: 5037 -- Temp : Ptr_Typ := new ...; 5038 5039 Insert_Action 5040 (Assoc_Node => N, 5041 Ins_Action => 5042 Make_Object_Declaration (Loc, 5043 Defining_Identifier => Temp, 5044 Object_Definition => New_Occurrence_Of (PtrT, Loc), 5045 Expression => Relocate_Node (N)), 5046 Suppress => All_Checks); 5047 5048 -- Generate: 5049 -- Temp.all := (others => ...); 5050 5051 Insert_Action 5052 (Assoc_Node => N, 5053 Ins_Action => 5054 Make_Assignment_Statement (Loc, 5055 Name => 5056 Make_Explicit_Dereference (Loc, 5057 Prefix => New_Occurrence_Of (Temp, Loc)), 5058 Expression => 5059 Get_Simple_Init_Val 5060 (Typ => T, 5061 N => N, 5062 Size => Esize (Component_Type (T)))), 5063 Suppress => All_Checks); 5064 5065 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 5066 Analyze_And_Resolve (N, PtrT); 5067 5068 -- Case of no initialization procedure present 5069 5070 elsif not Has_Non_Null_Base_Init_Proc (T) then 5071 5072 -- Case of simple initialization required 5073 5074 if Needs_Simple_Initialization (T) then 5075 Check_Restriction (No_Default_Initialization, N); 5076 Rewrite (Expression (N), 5077 Make_Qualified_Expression (Loc, 5078 Subtype_Mark => New_Occurrence_Of (T, Loc), 5079 Expression => Get_Simple_Init_Val (T, N))); 5080 5081 Analyze_And_Resolve (Expression (Expression (N)), T); 5082 Analyze_And_Resolve (Expression (N), T); 5083 Set_Paren_Count (Expression (Expression (N)), 1); 5084 Expand_N_Allocator (N); 5085 5086 -- No initialization required 5087 5088 else 5089 Build_Allocate_Deallocate_Proc 5090 (N => N, 5091 Is_Allocate => True); 5092 end if; 5093 5094 -- Case of initialization procedure present, must be called 5095 5096 -- NOTE: There is a *huge* amount of code duplication here from 5097 -- Build_Initialization_Call. We should probably refactor??? 5098 5099 else 5100 Check_Restriction (No_Default_Initialization, N); 5101 5102 if not Restriction_Active (No_Default_Initialization) then 5103 Init := Base_Init_Proc (T); 5104 Nod := N; 5105 Temp := Make_Temporary (Loc, 'P'); 5106 5107 -- Construct argument list for the initialization routine call 5108 5109 Init_Arg1 := 5110 Make_Explicit_Dereference (Loc, 5111 Prefix => 5112 New_Occurrence_Of (Temp, Loc)); 5113 5114 Set_Assignment_OK (Init_Arg1); 5115 Temp_Type := PtrT; 5116 5117 -- The initialization procedure expects a specific type. if the 5118 -- context is access to class wide, indicate that the object 5119 -- being allocated has the right specific type. 5120 5121 if Is_Class_Wide_Type (Dtyp) then 5122 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1); 5123 end if; 5124 5125 -- If designated type is a concurrent type or if it is private 5126 -- type whose definition is a concurrent type, the first 5127 -- argument in the Init routine has to be unchecked conversion 5128 -- to the corresponding record type. If the designated type is 5129 -- a derived type, also convert the argument to its root type. 5130 5131 if Is_Concurrent_Type (T) then 5132 Init_Arg1 := 5133 Unchecked_Convert_To ( 5134 Corresponding_Record_Type (T), Init_Arg1); 5135 5136 elsif Is_Private_Type (T) 5137 and then Present (Full_View (T)) 5138 and then Is_Concurrent_Type (Full_View (T)) 5139 then 5140 Init_Arg1 := 5141 Unchecked_Convert_To 5142 (Corresponding_Record_Type (Full_View (T)), Init_Arg1); 5143 5144 elsif Etype (First_Formal (Init)) /= Base_Type (T) then 5145 declare 5146 Ftyp : constant Entity_Id := Etype (First_Formal (Init)); 5147 5148 begin 5149 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1); 5150 Set_Etype (Init_Arg1, Ftyp); 5151 end; 5152 end if; 5153 5154 Args := New_List (Init_Arg1); 5155 5156 -- For the task case, pass the Master_Id of the access type as 5157 -- the value of the _Master parameter, and _Chain as the value 5158 -- of the _Chain parameter (_Chain will be defined as part of 5159 -- the generated code for the allocator). 5160 5161 -- In Ada 2005, the context may be a function that returns an 5162 -- anonymous access type. In that case the Master_Id has been 5163 -- created when expanding the function declaration. 5164 5165 if Has_Task (T) then 5166 if No (Master_Id (Base_Type (PtrT))) then 5167 5168 -- The designated type was an incomplete type, and the 5169 -- access type did not get expanded. Salvage it now. 5170 5171 if Present (Parent (Base_Type (PtrT))) then 5172 Expand_N_Full_Type_Declaration 5173 (Parent (Base_Type (PtrT))); 5174 5175 -- The only other possibility is an itype. For this 5176 -- case, the master must exist in the context. This is 5177 -- the case when the allocator initializes an access 5178 -- component in an init-proc. 5179 5180 else 5181 pragma Assert (Is_Itype (PtrT)); 5182 Build_Master_Renaming (PtrT, N); 5183 end if; 5184 end if; 5185 5186 -- If the context of the allocator is a declaration or an 5187 -- assignment, we can generate a meaningful image for it, 5188 -- even though subsequent assignments might remove the 5189 -- connection between task and entity. We build this image 5190 -- when the left-hand side is a simple variable, a simple 5191 -- indexed assignment or a simple selected component. 5192 5193 if Nkind (Parent (N)) = N_Assignment_Statement then 5194 declare 5195 Nam : constant Node_Id := Name (Parent (N)); 5196 5197 begin 5198 if Is_Entity_Name (Nam) then 5199 Decls := 5200 Build_Task_Image_Decls 5201 (Loc, 5202 New_Occurrence_Of 5203 (Entity (Nam), Sloc (Nam)), T); 5204 5205 elsif Nkind (Nam) in N_Indexed_Component 5206 | N_Selected_Component 5207 and then Is_Entity_Name (Prefix (Nam)) 5208 then 5209 Decls := 5210 Build_Task_Image_Decls 5211 (Loc, Nam, Etype (Prefix (Nam))); 5212 else 5213 Decls := Build_Task_Image_Decls (Loc, T, T); 5214 end if; 5215 end; 5216 5217 elsif Nkind (Parent (N)) = N_Object_Declaration then 5218 Decls := 5219 Build_Task_Image_Decls 5220 (Loc, Defining_Identifier (Parent (N)), T); 5221 5222 else 5223 Decls := Build_Task_Image_Decls (Loc, T, T); 5224 end if; 5225 5226 if Restriction_Active (No_Task_Hierarchy) then 5227 Append_To (Args, 5228 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 5229 else 5230 Append_To (Args, 5231 New_Occurrence_Of 5232 (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); 5233 end if; 5234 5235 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 5236 5237 Decl := Last (Decls); 5238 Append_To (Args, 5239 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 5240 5241 -- Has_Task is false, Decls not used 5242 5243 else 5244 Decls := No_List; 5245 end if; 5246 5247 -- Add discriminants if discriminated type 5248 5249 declare 5250 Dis : Boolean := False; 5251 Typ : Entity_Id := Empty; 5252 5253 begin 5254 if Has_Discriminants (T) then 5255 Dis := True; 5256 Typ := T; 5257 5258 -- Type may be a private type with no visible discriminants 5259 -- in which case check full view if in scope, or the 5260 -- underlying_full_view if dealing with a type whose full 5261 -- view may be derived from a private type whose own full 5262 -- view has discriminants. 5263 5264 elsif Is_Private_Type (T) then 5265 if Present (Full_View (T)) 5266 and then Has_Discriminants (Full_View (T)) 5267 then 5268 Dis := True; 5269 Typ := Full_View (T); 5270 5271 elsif Present (Underlying_Full_View (T)) 5272 and then Has_Discriminants (Underlying_Full_View (T)) 5273 then 5274 Dis := True; 5275 Typ := Underlying_Full_View (T); 5276 end if; 5277 end if; 5278 5279 if Dis then 5280 5281 -- If the allocated object will be constrained by the 5282 -- default values for discriminants, then build a subtype 5283 -- with those defaults, and change the allocated subtype 5284 -- to that. Note that this happens in fewer cases in Ada 5285 -- 2005 (AI-363). 5286 5287 if not Is_Constrained (Typ) 5288 and then Present (Discriminant_Default_Value 5289 (First_Discriminant (Typ))) 5290 and then (Ada_Version < Ada_2005 5291 or else not 5292 Object_Type_Has_Constrained_Partial_View 5293 (Typ, Current_Scope)) 5294 then 5295 Typ := Build_Default_Subtype (Typ, N); 5296 Set_Expression (N, New_Occurrence_Of (Typ, Loc)); 5297 end if; 5298 5299 Discr := First_Elmt (Discriminant_Constraint (Typ)); 5300 while Present (Discr) loop 5301 Nod := Node (Discr); 5302 Append (New_Copy_Tree (Node (Discr)), Args); 5303 5304 -- AI-416: when the discriminant constraint is an 5305 -- anonymous access type make sure an accessibility 5306 -- check is inserted if necessary (3.10.2(22.q/2)) 5307 5308 if Ada_Version >= Ada_2005 5309 and then 5310 Ekind (Etype (Nod)) = E_Anonymous_Access_Type 5311 then 5312 Apply_Accessibility_Check 5313 (Nod, Typ, Insert_Node => Nod); 5314 end if; 5315 5316 Next_Elmt (Discr); 5317 end loop; 5318 end if; 5319 end; 5320 5321 -- We set the allocator as analyzed so that when we analyze 5322 -- the if expression node, we do not get an unwanted recursive 5323 -- expansion of the allocator expression. 5324 5325 Set_Analyzed (N, True); 5326 Nod := Relocate_Node (N); 5327 5328 -- Here is the transformation: 5329 -- input: new Ctrl_Typ 5330 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ; 5331 -- Ctrl_TypIP (Temp.all, ...); 5332 -- [Deep_]Initialize (Temp.all); 5333 5334 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and 5335 -- is the subtype of the allocator. 5336 5337 Temp_Decl := 5338 Make_Object_Declaration (Loc, 5339 Defining_Identifier => Temp, 5340 Constant_Present => True, 5341 Object_Definition => New_Occurrence_Of (Temp_Type, Loc), 5342 Expression => Nod); 5343 5344 Set_Assignment_OK (Temp_Decl); 5345 Insert_Action (N, Temp_Decl, Suppress => All_Checks); 5346 5347 Build_Allocate_Deallocate_Proc (Temp_Decl, True); 5348 5349 -- If the designated type is a task type or contains tasks, 5350 -- create block to activate created tasks, and insert 5351 -- declaration for Task_Image variable ahead of call. 5352 5353 if Has_Task (T) then 5354 declare 5355 L : constant List_Id := New_List; 5356 Blk : Node_Id; 5357 begin 5358 Build_Task_Allocate_Block (L, Nod, Args); 5359 Blk := Last (L); 5360 Insert_List_Before (First (Declarations (Blk)), Decls); 5361 Insert_Actions (N, L); 5362 end; 5363 5364 else 5365 Insert_Action (N, 5366 Make_Procedure_Call_Statement (Loc, 5367 Name => New_Occurrence_Of (Init, Loc), 5368 Parameter_Associations => Args)); 5369 end if; 5370 5371 if Needs_Finalization (T) then 5372 5373 -- Generate: 5374 -- [Deep_]Initialize (Init_Arg1); 5375 5376 Init_Call := 5377 Make_Init_Call 5378 (Obj_Ref => New_Copy_Tree (Init_Arg1), 5379 Typ => T); 5380 5381 -- Guard against a missing [Deep_]Initialize when the 5382 -- designated type was not properly frozen. 5383 5384 if Present (Init_Call) then 5385 Insert_Action (N, Init_Call); 5386 end if; 5387 end if; 5388 5389 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 5390 Analyze_And_Resolve (N, PtrT); 5391 5392 -- When designated type has Default_Initial_Condition aspects, 5393 -- make a call to the type's DIC procedure to perform the 5394 -- checks. Theoretically this might also be needed for cases 5395 -- where the type doesn't have an init proc, but those should 5396 -- be very uncommon, and for now we only support the init proc 5397 -- case. ??? 5398 5399 if Has_DIC (Dtyp) 5400 and then Present (DIC_Procedure (Dtyp)) 5401 and then not Has_Null_Body (DIC_Procedure (Dtyp)) 5402 then 5403 Insert_Action (N, 5404 Build_DIC_Call (Loc, 5405 Make_Explicit_Dereference (Loc, 5406 Prefix => New_Occurrence_Of (Temp, Loc)), 5407 Dtyp)); 5408 end if; 5409 end if; 5410 end if; 5411 end; 5412 5413 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface 5414 -- object that has been rewritten as a reference, we displace "this" 5415 -- to reference properly its secondary dispatch table. 5416 5417 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then 5418 Displace_Allocator_Pointer (N); 5419 end if; 5420 5421 exception 5422 when RE_Not_Available => 5423 return; 5424 end Expand_N_Allocator; 5425 5426 ----------------------- 5427 -- Expand_N_And_Then -- 5428 ----------------------- 5429 5430 procedure Expand_N_And_Then (N : Node_Id) 5431 renames Expand_Short_Circuit_Operator; 5432 5433 ------------------------------ 5434 -- Expand_N_Case_Expression -- 5435 ------------------------------ 5436 5437 procedure Expand_N_Case_Expression (N : Node_Id) is 5438 function Is_Copy_Type (Typ : Entity_Id) return Boolean; 5439 -- Return True if we can copy objects of this type when expanding a case 5440 -- expression. 5441 5442 ------------------ 5443 -- Is_Copy_Type -- 5444 ------------------ 5445 5446 function Is_Copy_Type (Typ : Entity_Id) return Boolean is 5447 begin 5448 -- If Minimize_Expression_With_Actions is True, we can afford to copy 5449 -- large objects, as long as they are constrained and not limited. 5450 5451 return 5452 Is_Elementary_Type (Underlying_Type (Typ)) 5453 or else 5454 (Minimize_Expression_With_Actions 5455 and then Is_Constrained (Underlying_Type (Typ)) 5456 and then not Is_Limited_Type (Underlying_Type (Typ))); 5457 end Is_Copy_Type; 5458 5459 -- Local variables 5460 5461 Loc : constant Source_Ptr := Sloc (N); 5462 Par : constant Node_Id := Parent (N); 5463 Typ : constant Entity_Id := Etype (N); 5464 5465 Acts : List_Id; 5466 Alt : Node_Id; 5467 Case_Stmt : Node_Id; 5468 Decl : Node_Id; 5469 Expr : Node_Id; 5470 Target : Entity_Id := Empty; 5471 Target_Typ : Entity_Id; 5472 5473 In_Predicate : Boolean := False; 5474 -- Flag set when the case expression appears within a predicate 5475 5476 Optimize_Return_Stmt : Boolean := False; 5477 -- Flag set when the case expression can be optimized in the context of 5478 -- a simple return statement. 5479 5480 -- Start of processing for Expand_N_Case_Expression 5481 5482 begin 5483 -- Check for MINIMIZED/ELIMINATED overflow mode 5484 5485 if Minimized_Eliminated_Overflow_Check (N) then 5486 Apply_Arithmetic_Overflow_Check (N); 5487 return; 5488 end if; 5489 5490 -- If the case expression is a predicate specification, and the type 5491 -- to which it applies has a static predicate aspect, do not expand, 5492 -- because it will be converted to the proper predicate form later. 5493 5494 if Ekind (Current_Scope) in E_Function | E_Procedure 5495 and then Is_Predicate_Function (Current_Scope) 5496 then 5497 In_Predicate := True; 5498 5499 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope))) 5500 then 5501 return; 5502 end if; 5503 end if; 5504 5505 -- When the type of the case expression is elementary, expand 5506 5507 -- (case X is when A => AX, when B => BX ...) 5508 5509 -- into 5510 5511 -- do 5512 -- Target : Typ; 5513 -- case X is 5514 -- when A => 5515 -- Target := AX; 5516 -- when B => 5517 -- Target := BX; 5518 -- ... 5519 -- end case; 5520 -- in Target end; 5521 5522 -- In all other cases expand into 5523 5524 -- do 5525 -- type Ptr_Typ is access all Typ; 5526 -- Target : Ptr_Typ; 5527 -- case X is 5528 -- when A => 5529 -- Target := AX'Unrestricted_Access; 5530 -- when B => 5531 -- Target := BX'Unrestricted_Access; 5532 -- ... 5533 -- end case; 5534 -- in Target.all end; 5535 5536 -- This approach avoids extra copies of potentially large objects. It 5537 -- also allows handling of values of limited or unconstrained types. 5538 -- Note that we do the copy also for constrained, nonlimited types 5539 -- when minimizing expressions with actions (e.g. when generating C 5540 -- code) since it allows us to do the optimization below in more cases. 5541 5542 -- Small optimization: when the case expression appears in the context 5543 -- of a simple return statement, expand into 5544 5545 -- case X is 5546 -- when A => 5547 -- return AX; 5548 -- when B => 5549 -- return BX; 5550 -- ... 5551 -- end case; 5552 5553 Case_Stmt := 5554 Make_Case_Statement (Loc, 5555 Expression => Expression (N), 5556 Alternatives => New_List); 5557 5558 -- Preserve the original context for which the case statement is being 5559 -- generated. This is needed by the finalization machinery to prevent 5560 -- the premature finalization of controlled objects found within the 5561 -- case statement. 5562 5563 Set_From_Conditional_Expression (Case_Stmt); 5564 Acts := New_List; 5565 5566 -- Scalar/Copy case 5567 5568 if Is_Copy_Type (Typ) then 5569 Target_Typ := Typ; 5570 5571 -- ??? Do not perform the optimization when the return statement is 5572 -- within a predicate function, as this causes spurious errors. Could 5573 -- this be a possible mismatch in handling this case somewhere else 5574 -- in semantic analysis? 5575 5576 Optimize_Return_Stmt := 5577 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; 5578 5579 -- Otherwise create an access type to handle the general case using 5580 -- 'Unrestricted_Access. 5581 5582 -- Generate: 5583 -- type Ptr_Typ is access all Typ; 5584 5585 else 5586 if Generate_C_Code then 5587 5588 -- We cannot ensure that correct C code will be generated if any 5589 -- temporary is created down the line (to e.g. handle checks or 5590 -- capture values) since we might end up with dangling references 5591 -- to local variables, so better be safe and reject the construct. 5592 5593 Error_Msg_N 5594 ("case expression too complex, use case statement instead", N); 5595 end if; 5596 5597 Target_Typ := Make_Temporary (Loc, 'P'); 5598 5599 Append_To (Acts, 5600 Make_Full_Type_Declaration (Loc, 5601 Defining_Identifier => Target_Typ, 5602 Type_Definition => 5603 Make_Access_To_Object_Definition (Loc, 5604 All_Present => True, 5605 Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); 5606 end if; 5607 5608 -- Create the declaration of the target which captures the value of the 5609 -- expression. 5610 5611 -- Generate: 5612 -- Target : [Ptr_]Typ; 5613 5614 if not Optimize_Return_Stmt then 5615 Target := Make_Temporary (Loc, 'T'); 5616 5617 Decl := 5618 Make_Object_Declaration (Loc, 5619 Defining_Identifier => Target, 5620 Object_Definition => New_Occurrence_Of (Target_Typ, Loc)); 5621 Set_No_Initialization (Decl); 5622 5623 Append_To (Acts, Decl); 5624 end if; 5625 5626 -- Process the alternatives 5627 5628 Alt := First (Alternatives (N)); 5629 while Present (Alt) loop 5630 declare 5631 Alt_Expr : Node_Id := Expression (Alt); 5632 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); 5633 LHS : Node_Id; 5634 Stmts : List_Id; 5635 5636 begin 5637 -- Take the unrestricted access of the expression value for non- 5638 -- scalar types. This approach avoids big copies and covers the 5639 -- limited and unconstrained cases. 5640 5641 -- Generate: 5642 -- AX'Unrestricted_Access 5643 5644 if not Is_Copy_Type (Typ) then 5645 Alt_Expr := 5646 Make_Attribute_Reference (Alt_Loc, 5647 Prefix => Relocate_Node (Alt_Expr), 5648 Attribute_Name => Name_Unrestricted_Access); 5649 end if; 5650 5651 -- Generate: 5652 -- return AX['Unrestricted_Access]; 5653 5654 if Optimize_Return_Stmt then 5655 Stmts := New_List ( 5656 Make_Simple_Return_Statement (Alt_Loc, 5657 Expression => Alt_Expr)); 5658 5659 -- Generate: 5660 -- Target := AX['Unrestricted_Access]; 5661 5662 else 5663 LHS := New_Occurrence_Of (Target, Loc); 5664 Set_Assignment_OK (LHS); 5665 5666 Stmts := New_List ( 5667 Make_Assignment_Statement (Alt_Loc, 5668 Name => LHS, 5669 Expression => Alt_Expr)); 5670 end if; 5671 5672 -- Propagate declarations inserted in the node by Insert_Actions 5673 -- (for example, temporaries generated to remove side effects). 5674 -- These actions must remain attached to the alternative, given 5675 -- that they are generated by the corresponding expression. 5676 5677 if Present (Actions (Alt)) then 5678 Prepend_List (Actions (Alt), Stmts); 5679 end if; 5680 5681 -- Finalize any transient objects on exit from the alternative. 5682 -- This is done only in the return optimization case because 5683 -- otherwise the case expression is converted into an expression 5684 -- with actions which already contains this form of processing. 5685 5686 if Optimize_Return_Stmt then 5687 Process_If_Case_Statements (N, Stmts); 5688 end if; 5689 5690 Append_To 5691 (Alternatives (Case_Stmt), 5692 Make_Case_Statement_Alternative (Sloc (Alt), 5693 Discrete_Choices => Discrete_Choices (Alt), 5694 Statements => Stmts)); 5695 end; 5696 5697 Next (Alt); 5698 end loop; 5699 5700 -- Rewrite the parent return statement as a case statement 5701 5702 if Optimize_Return_Stmt then 5703 Rewrite (Par, Case_Stmt); 5704 Analyze (Par); 5705 5706 -- Otherwise convert the case expression into an expression with actions 5707 5708 else 5709 Append_To (Acts, Case_Stmt); 5710 5711 if Is_Copy_Type (Typ) then 5712 Expr := New_Occurrence_Of (Target, Loc); 5713 5714 else 5715 Expr := 5716 Make_Explicit_Dereference (Loc, 5717 Prefix => New_Occurrence_Of (Target, Loc)); 5718 end if; 5719 5720 -- Generate: 5721 -- do 5722 -- ... 5723 -- in Target[.all] end; 5724 5725 Rewrite (N, 5726 Make_Expression_With_Actions (Loc, 5727 Expression => Expr, 5728 Actions => Acts)); 5729 5730 Analyze_And_Resolve (N, Typ); 5731 end if; 5732 end Expand_N_Case_Expression; 5733 5734 ----------------------------------- 5735 -- Expand_N_Explicit_Dereference -- 5736 ----------------------------------- 5737 5738 procedure Expand_N_Explicit_Dereference (N : Node_Id) is 5739 begin 5740 -- Insert explicit dereference call for the checked storage pool case 5741 5742 Insert_Dereference_Action (Prefix (N)); 5743 5744 -- If the type is an Atomic type for which Atomic_Sync is enabled, then 5745 -- we set the atomic sync flag. 5746 5747 if Is_Atomic (Etype (N)) 5748 and then not Atomic_Synchronization_Disabled (Etype (N)) 5749 then 5750 Activate_Atomic_Synchronization (N); 5751 end if; 5752 end Expand_N_Explicit_Dereference; 5753 5754 -------------------------------------- 5755 -- Expand_N_Expression_With_Actions -- 5756 -------------------------------------- 5757 5758 procedure Expand_N_Expression_With_Actions (N : Node_Id) is 5759 Acts : constant List_Id := Actions (N); 5760 5761 procedure Force_Boolean_Evaluation (Expr : Node_Id); 5762 -- Force the evaluation of Boolean expression Expr 5763 5764 function Process_Action (Act : Node_Id) return Traverse_Result; 5765 -- Inspect and process a single action of an expression_with_actions for 5766 -- transient objects. If such objects are found, the routine generates 5767 -- code to clean them up when the context of the expression is evaluated 5768 -- or elaborated. 5769 5770 ------------------------------ 5771 -- Force_Boolean_Evaluation -- 5772 ------------------------------ 5773 5774 procedure Force_Boolean_Evaluation (Expr : Node_Id) is 5775 Loc : constant Source_Ptr := Sloc (N); 5776 Flag_Decl : Node_Id; 5777 Flag_Id : Entity_Id; 5778 5779 begin 5780 -- Relocate the expression to the actions list by capturing its value 5781 -- in a Boolean flag. Generate: 5782 -- Flag : constant Boolean := Expr; 5783 5784 Flag_Id := Make_Temporary (Loc, 'F'); 5785 5786 Flag_Decl := 5787 Make_Object_Declaration (Loc, 5788 Defining_Identifier => Flag_Id, 5789 Constant_Present => True, 5790 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 5791 Expression => Relocate_Node (Expr)); 5792 5793 Append (Flag_Decl, Acts); 5794 Analyze (Flag_Decl); 5795 5796 -- Replace the expression with a reference to the flag 5797 5798 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc)); 5799 Analyze (Expression (N)); 5800 end Force_Boolean_Evaluation; 5801 5802 -------------------- 5803 -- Process_Action -- 5804 -------------------- 5805 5806 function Process_Action (Act : Node_Id) return Traverse_Result is 5807 begin 5808 if Nkind (Act) = N_Object_Declaration 5809 and then Is_Finalizable_Transient (Act, N) 5810 then 5811 Process_Transient_In_Expression (Act, N, Acts); 5812 return Skip; 5813 5814 -- Avoid processing temporary function results multiple times when 5815 -- dealing with nested expression_with_actions. 5816 5817 elsif Nkind (Act) = N_Expression_With_Actions then 5818 return Abandon; 5819 5820 -- Do not process temporary function results in loops. This is done 5821 -- by Expand_N_Loop_Statement and Build_Finalizer. 5822 5823 elsif Nkind (Act) = N_Loop_Statement then 5824 return Abandon; 5825 end if; 5826 5827 return OK; 5828 end Process_Action; 5829 5830 procedure Process_Single_Action is new Traverse_Proc (Process_Action); 5831 5832 -- Local variables 5833 5834 Act : Node_Id; 5835 5836 -- Start of processing for Expand_N_Expression_With_Actions 5837 5838 begin 5839 -- Do not evaluate the expression when it denotes an entity because the 5840 -- expression_with_actions node will be replaced by the reference. 5841 5842 if Is_Entity_Name (Expression (N)) then 5843 null; 5844 5845 -- Do not evaluate the expression when there are no actions because the 5846 -- expression_with_actions node will be replaced by the expression. 5847 5848 elsif No (Acts) or else Is_Empty_List (Acts) then 5849 null; 5850 5851 -- Force the evaluation of the expression by capturing its value in a 5852 -- temporary. This ensures that aliases of transient objects do not leak 5853 -- to the expression of the expression_with_actions node: 5854 5855 -- do 5856 -- Trans_Id : Ctrl_Typ := ...; 5857 -- Alias : ... := Trans_Id; 5858 -- in ... Alias ... end; 5859 5860 -- In the example above, Trans_Id cannot be finalized at the end of the 5861 -- actions list because this may affect the alias and the final value of 5862 -- the expression_with_actions. Forcing the evaluation encapsulates the 5863 -- reference to the Alias within the actions list: 5864 5865 -- do 5866 -- Trans_Id : Ctrl_Typ := ...; 5867 -- Alias : ... := Trans_Id; 5868 -- Val : constant Boolean := ... Alias ...; 5869 -- <finalize Trans_Id> 5870 -- in Val end; 5871 5872 -- Once this transformation is performed, it is safe to finalize the 5873 -- transient object at the end of the actions list. 5874 5875 -- Note that Force_Evaluation does not remove side effects in operators 5876 -- because it assumes that all operands are evaluated and side effect 5877 -- free. This is not the case when an operand depends implicitly on the 5878 -- transient object through the use of access types. 5879 5880 elsif Is_Boolean_Type (Etype (Expression (N))) then 5881 Force_Boolean_Evaluation (Expression (N)); 5882 5883 -- The expression of an expression_with_actions node may not necessarily 5884 -- be Boolean when the node appears in an if expression. In this case do 5885 -- the usual forced evaluation to encapsulate potential aliasing. 5886 5887 else 5888 Force_Evaluation (Expression (N)); 5889 end if; 5890 5891 -- Process all transient objects found within the actions of the EWA 5892 -- node. 5893 5894 Act := First (Acts); 5895 while Present (Act) loop 5896 Process_Single_Action (Act); 5897 Next (Act); 5898 end loop; 5899 5900 -- Deal with case where there are no actions. In this case we simply 5901 -- rewrite the node with its expression since we don't need the actions 5902 -- and the specification of this node does not allow a null action list. 5903 5904 -- Note: we use Rewrite instead of Replace, because Codepeer is using 5905 -- the expanded tree and relying on being able to retrieve the original 5906 -- tree in cases like this. This raises a whole lot of issues of whether 5907 -- we have problems elsewhere, which will be addressed in the future??? 5908 5909 if Is_Empty_List (Acts) then 5910 Rewrite (N, Relocate_Node (Expression (N))); 5911 end if; 5912 end Expand_N_Expression_With_Actions; 5913 5914 ---------------------------- 5915 -- Expand_N_If_Expression -- 5916 ---------------------------- 5917 5918 -- Deal with limited types and condition actions 5919 5920 procedure Expand_N_If_Expression (N : Node_Id) is 5921 Cond : constant Node_Id := First (Expressions (N)); 5922 Loc : constant Source_Ptr := Sloc (N); 5923 Thenx : constant Node_Id := Next (Cond); 5924 Elsex : constant Node_Id := Next (Thenx); 5925 Typ : constant Entity_Id := Etype (N); 5926 5927 Actions : List_Id; 5928 Decl : Node_Id; 5929 Expr : Node_Id; 5930 New_If : Node_Id; 5931 New_N : Node_Id; 5932 5933 -- Determine if we are dealing with a special case of a conditional 5934 -- expression used as an actual for an anonymous access type which 5935 -- forces us to transform the if expression into an expression with 5936 -- actions in order to create a temporary to capture the level of the 5937 -- expression in each branch. 5938 5939 Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N); 5940 5941 -- Start of processing for Expand_N_If_Expression 5942 5943 begin 5944 -- Check for MINIMIZED/ELIMINATED overflow mode 5945 5946 if Minimized_Eliminated_Overflow_Check (N) then 5947 Apply_Arithmetic_Overflow_Check (N); 5948 return; 5949 end if; 5950 5951 -- Fold at compile time if condition known. We have already folded 5952 -- static if expressions, but it is possible to fold any case in which 5953 -- the condition is known at compile time, even though the result is 5954 -- non-static. 5955 5956 -- Note that we don't do the fold of such cases in Sem_Elab because 5957 -- it can cause infinite loops with the expander adding a conditional 5958 -- expression, and Sem_Elab circuitry removing it repeatedly. 5959 5960 if Compile_Time_Known_Value (Cond) then 5961 declare 5962 function Fold_Known_Value (Cond : Node_Id) return Boolean; 5963 -- Fold at compile time. Assumes condition known. Return True if 5964 -- folding occurred, meaning we're done. 5965 5966 ---------------------- 5967 -- Fold_Known_Value -- 5968 ---------------------- 5969 5970 function Fold_Known_Value (Cond : Node_Id) return Boolean is 5971 begin 5972 if Is_True (Expr_Value (Cond)) then 5973 Expr := Thenx; 5974 Actions := Then_Actions (N); 5975 else 5976 Expr := Elsex; 5977 Actions := Else_Actions (N); 5978 end if; 5979 5980 Remove (Expr); 5981 5982 if Present (Actions) then 5983 5984 -- To minimize the use of Expression_With_Actions, just skip 5985 -- the optimization as it is not critical for correctness. 5986 5987 if Minimize_Expression_With_Actions then 5988 return False; 5989 end if; 5990 5991 Rewrite (N, 5992 Make_Expression_With_Actions (Loc, 5993 Expression => Relocate_Node (Expr), 5994 Actions => Actions)); 5995 Analyze_And_Resolve (N, Typ); 5996 5997 else 5998 Rewrite (N, Relocate_Node (Expr)); 5999 end if; 6000 6001 -- Note that the result is never static (legitimate cases of 6002 -- static if expressions were folded in Sem_Eval). 6003 6004 Set_Is_Static_Expression (N, False); 6005 return True; 6006 end Fold_Known_Value; 6007 6008 begin 6009 if Fold_Known_Value (Cond) then 6010 return; 6011 end if; 6012 end; 6013 end if; 6014 6015 -- If the type is limited, and the back end does not handle limited 6016 -- types, then we expand as follows to avoid the possibility of 6017 -- improper copying. 6018 6019 -- type Ptr is access all Typ; 6020 -- Cnn : Ptr; 6021 -- if cond then 6022 -- <<then actions>> 6023 -- Cnn := then-expr'Unrestricted_Access; 6024 -- else 6025 -- <<else actions>> 6026 -- Cnn := else-expr'Unrestricted_Access; 6027 -- end if; 6028 6029 -- and replace the if expression by a reference to Cnn.all. 6030 6031 -- This special case can be skipped if the back end handles limited 6032 -- types properly and ensures that no incorrect copies are made. 6033 6034 if Is_By_Reference_Type (Typ) 6035 and then not Back_End_Handles_Limited_Types 6036 then 6037 -- When the "then" or "else" expressions involve controlled function 6038 -- calls, generated temporaries are chained on the corresponding list 6039 -- of actions. These temporaries need to be finalized after the if 6040 -- expression is evaluated. 6041 6042 Process_If_Case_Statements (N, Then_Actions (N)); 6043 Process_If_Case_Statements (N, Else_Actions (N)); 6044 6045 declare 6046 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N); 6047 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); 6048 6049 begin 6050 -- Generate: 6051 -- type Ann is access all Typ; 6052 6053 Insert_Action (N, 6054 Make_Full_Type_Declaration (Loc, 6055 Defining_Identifier => Ptr_Typ, 6056 Type_Definition => 6057 Make_Access_To_Object_Definition (Loc, 6058 All_Present => True, 6059 Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); 6060 6061 -- Generate: 6062 -- Cnn : Ann; 6063 6064 Decl := 6065 Make_Object_Declaration (Loc, 6066 Defining_Identifier => Cnn, 6067 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); 6068 6069 -- Generate: 6070 -- if Cond then 6071 -- Cnn := <Thenx>'Unrestricted_Access; 6072 -- else 6073 -- Cnn := <Elsex>'Unrestricted_Access; 6074 -- end if; 6075 6076 New_If := 6077 Make_Implicit_If_Statement (N, 6078 Condition => Relocate_Node (Cond), 6079 Then_Statements => New_List ( 6080 Make_Assignment_Statement (Sloc (Thenx), 6081 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 6082 Expression => 6083 Make_Attribute_Reference (Loc, 6084 Prefix => Relocate_Node (Thenx), 6085 Attribute_Name => Name_Unrestricted_Access))), 6086 6087 Else_Statements => New_List ( 6088 Make_Assignment_Statement (Sloc (Elsex), 6089 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 6090 Expression => 6091 Make_Attribute_Reference (Loc, 6092 Prefix => Relocate_Node (Elsex), 6093 Attribute_Name => Name_Unrestricted_Access)))); 6094 6095 -- Preserve the original context for which the if statement is 6096 -- being generated. This is needed by the finalization machinery 6097 -- to prevent the premature finalization of controlled objects 6098 -- found within the if statement. 6099 6100 Set_From_Conditional_Expression (New_If); 6101 6102 New_N := 6103 Make_Explicit_Dereference (Loc, 6104 Prefix => New_Occurrence_Of (Cnn, Loc)); 6105 end; 6106 6107 -- If the result is an unconstrained array and the if expression is in a 6108 -- context other than the initializing expression of the declaration of 6109 -- an object, then we pull out the if expression as follows: 6110 6111 -- Cnn : constant typ := if-expression 6112 6113 -- and then replace the if expression with an occurrence of Cnn. This 6114 -- avoids the need in the back end to create on-the-fly variable length 6115 -- temporaries (which it cannot do!) 6116 6117 -- Note that the test for being in an object declaration avoids doing an 6118 -- unnecessary expansion, and also avoids infinite recursion. 6119 6120 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) 6121 and then (Nkind (Parent (N)) /= N_Object_Declaration 6122 or else Expression (Parent (N)) /= N) 6123 then 6124 declare 6125 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); 6126 6127 begin 6128 Insert_Action (N, 6129 Make_Object_Declaration (Loc, 6130 Defining_Identifier => Cnn, 6131 Constant_Present => True, 6132 Object_Definition => New_Occurrence_Of (Typ, Loc), 6133 Expression => Relocate_Node (N), 6134 Has_Init_Expression => True)); 6135 6136 Rewrite (N, New_Occurrence_Of (Cnn, Loc)); 6137 return; 6138 end; 6139 6140 -- For other types, we only need to expand if there are other actions 6141 -- associated with either branch or we need to force expansion to deal 6142 -- with if expressions used as an actual of an anonymous access type. 6143 6144 elsif Present (Then_Actions (N)) 6145 or else Present (Else_Actions (N)) 6146 or else Force_Expand 6147 then 6148 6149 -- We now wrap the actions into the appropriate expression 6150 6151 if Minimize_Expression_With_Actions 6152 and then (Is_Elementary_Type (Underlying_Type (Typ)) 6153 or else Is_Constrained (Underlying_Type (Typ))) 6154 then 6155 -- If we can't use N_Expression_With_Actions nodes, then we insert 6156 -- the following sequence of actions (using Insert_Actions): 6157 6158 -- Cnn : typ; 6159 -- if cond then 6160 -- <<then actions>> 6161 -- Cnn := then-expr; 6162 -- else 6163 -- <<else actions>> 6164 -- Cnn := else-expr 6165 -- end if; 6166 6167 -- and replace the if expression by a reference to Cnn 6168 6169 declare 6170 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); 6171 6172 begin 6173 Decl := 6174 Make_Object_Declaration (Loc, 6175 Defining_Identifier => Cnn, 6176 Object_Definition => New_Occurrence_Of (Typ, Loc)); 6177 6178 New_If := 6179 Make_Implicit_If_Statement (N, 6180 Condition => Relocate_Node (Cond), 6181 6182 Then_Statements => New_List ( 6183 Make_Assignment_Statement (Sloc (Thenx), 6184 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 6185 Expression => Relocate_Node (Thenx))), 6186 6187 Else_Statements => New_List ( 6188 Make_Assignment_Statement (Sloc (Elsex), 6189 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 6190 Expression => Relocate_Node (Elsex)))); 6191 6192 Set_Assignment_OK (Name (First (Then_Statements (New_If)))); 6193 Set_Assignment_OK (Name (First (Else_Statements (New_If)))); 6194 6195 New_N := New_Occurrence_Of (Cnn, Loc); 6196 end; 6197 6198 -- Regular path using Expression_With_Actions 6199 6200 else 6201 if Present (Then_Actions (N)) then 6202 Rewrite (Thenx, 6203 Make_Expression_With_Actions (Sloc (Thenx), 6204 Actions => Then_Actions (N), 6205 Expression => Relocate_Node (Thenx))); 6206 6207 Set_Then_Actions (N, No_List); 6208 Analyze_And_Resolve (Thenx, Typ); 6209 end if; 6210 6211 if Present (Else_Actions (N)) then 6212 Rewrite (Elsex, 6213 Make_Expression_With_Actions (Sloc (Elsex), 6214 Actions => Else_Actions (N), 6215 Expression => Relocate_Node (Elsex))); 6216 6217 Set_Else_Actions (N, No_List); 6218 Analyze_And_Resolve (Elsex, Typ); 6219 end if; 6220 6221 -- We must force expansion into an expression with actions when 6222 -- an if expression gets used directly as an actual for an 6223 -- anonymous access type. 6224 6225 if Force_Expand then 6226 declare 6227 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C'); 6228 Acts : List_Id; 6229 begin 6230 Acts := New_List; 6231 6232 -- Generate: 6233 -- Cnn : Ann; 6234 6235 Decl := 6236 Make_Object_Declaration (Loc, 6237 Defining_Identifier => Cnn, 6238 Object_Definition => New_Occurrence_Of (Typ, Loc)); 6239 Append_To (Acts, Decl); 6240 6241 Set_No_Initialization (Decl); 6242 6243 -- Generate: 6244 -- if Cond then 6245 -- Cnn := <Thenx>; 6246 -- else 6247 -- Cnn := <Elsex>; 6248 -- end if; 6249 6250 New_If := 6251 Make_Implicit_If_Statement (N, 6252 Condition => Relocate_Node (Cond), 6253 Then_Statements => New_List ( 6254 Make_Assignment_Statement (Sloc (Thenx), 6255 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), 6256 Expression => Relocate_Node (Thenx))), 6257 6258 Else_Statements => New_List ( 6259 Make_Assignment_Statement (Sloc (Elsex), 6260 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), 6261 Expression => Relocate_Node (Elsex)))); 6262 Append_To (Acts, New_If); 6263 6264 -- Generate: 6265 -- do 6266 -- ... 6267 -- in Cnn end; 6268 6269 Rewrite (N, 6270 Make_Expression_With_Actions (Loc, 6271 Expression => New_Occurrence_Of (Cnn, Loc), 6272 Actions => Acts)); 6273 Analyze_And_Resolve (N, Typ); 6274 end; 6275 end if; 6276 6277 return; 6278 end if; 6279 6280 -- If no actions then no expansion needed, gigi will handle it using the 6281 -- same approach as a C conditional expression. 6282 6283 else 6284 return; 6285 end if; 6286 6287 -- Fall through here for either the limited expansion, or the case of 6288 -- inserting actions for nonlimited types. In both these cases, we must 6289 -- move the SLOC of the parent If statement to the newly created one and 6290 -- change it to the SLOC of the expression which, after expansion, will 6291 -- correspond to what is being evaluated. 6292 6293 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then 6294 Set_Sloc (New_If, Sloc (Parent (N))); 6295 Set_Sloc (Parent (N), Loc); 6296 end if; 6297 6298 -- Make sure Then_Actions and Else_Actions are appropriately moved 6299 -- to the new if statement. 6300 6301 if Present (Then_Actions (N)) then 6302 Insert_List_Before 6303 (First (Then_Statements (New_If)), Then_Actions (N)); 6304 end if; 6305 6306 if Present (Else_Actions (N)) then 6307 Insert_List_Before 6308 (First (Else_Statements (New_If)), Else_Actions (N)); 6309 end if; 6310 6311 Insert_Action (N, Decl); 6312 Insert_Action (N, New_If); 6313 Rewrite (N, New_N); 6314 Analyze_And_Resolve (N, Typ); 6315 end Expand_N_If_Expression; 6316 6317 ----------------- 6318 -- Expand_N_In -- 6319 ----------------- 6320 6321 procedure Expand_N_In (N : Node_Id) is 6322 Loc : constant Source_Ptr := Sloc (N); 6323 Restyp : constant Entity_Id := Etype (N); 6324 Lop : constant Node_Id := Left_Opnd (N); 6325 Rop : constant Node_Id := Right_Opnd (N); 6326 Static : constant Boolean := Is_OK_Static_Expression (N); 6327 6328 procedure Substitute_Valid_Check; 6329 -- Replaces node N by Lop'Valid. This is done when we have an explicit 6330 -- test for the left operand being in range of its subtype. 6331 6332 ---------------------------- 6333 -- Substitute_Valid_Check -- 6334 ---------------------------- 6335 6336 procedure Substitute_Valid_Check is 6337 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean; 6338 -- Determine whether arbitrary node Nod denotes a source object that 6339 -- may safely act as prefix of attribute 'Valid. 6340 6341 ---------------------------- 6342 -- Is_OK_Object_Reference -- 6343 ---------------------------- 6344 6345 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is 6346 Obj_Ref : Node_Id; 6347 6348 begin 6349 -- Inspect the original operand 6350 6351 Obj_Ref := Original_Node (Nod); 6352 6353 -- The object reference must be a source construct, otherwise the 6354 -- codefix suggestion may refer to nonexistent code from a user 6355 -- perspective. 6356 6357 if Comes_From_Source (Obj_Ref) then 6358 6359 -- Recover the actual object reference. There may be more cases 6360 -- to consider??? 6361 6362 loop 6363 if Nkind (Obj_Ref) in 6364 N_Type_Conversion | N_Unchecked_Type_Conversion 6365 then 6366 Obj_Ref := Expression (Obj_Ref); 6367 else 6368 exit; 6369 end if; 6370 end loop; 6371 6372 return Is_Object_Reference (Obj_Ref); 6373 end if; 6374 6375 return False; 6376 end Is_OK_Object_Reference; 6377 6378 -- Start of processing for Substitute_Valid_Check 6379 6380 begin 6381 Rewrite (N, 6382 Make_Attribute_Reference (Loc, 6383 Prefix => Relocate_Node (Lop), 6384 Attribute_Name => Name_Valid)); 6385 6386 Analyze_And_Resolve (N, Restyp); 6387 6388 -- Emit a warning when the left-hand operand of the membership test 6389 -- is a source object, otherwise the use of attribute 'Valid would be 6390 -- illegal. The warning is not given when overflow checking is either 6391 -- MINIMIZED or ELIMINATED, as the danger of optimization has been 6392 -- eliminated above. 6393 6394 if Is_OK_Object_Reference (Lop) 6395 and then Overflow_Check_Mode not in Minimized_Or_Eliminated 6396 then 6397 Error_Msg_N 6398 ("??explicit membership test may be optimized away", N); 6399 Error_Msg_N -- CODEFIX 6400 ("\??use ''Valid attribute instead", N); 6401 end if; 6402 end Substitute_Valid_Check; 6403 6404 -- Local variables 6405 6406 Ltyp : Entity_Id; 6407 Rtyp : Entity_Id; 6408 6409 -- Start of processing for Expand_N_In 6410 6411 begin 6412 -- If set membership case, expand with separate procedure 6413 6414 if Present (Alternatives (N)) then 6415 Expand_Set_Membership (N); 6416 return; 6417 end if; 6418 6419 -- Not set membership, proceed with expansion 6420 6421 Ltyp := Etype (Left_Opnd (N)); 6422 Rtyp := Etype (Right_Opnd (N)); 6423 6424 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer 6425 -- type, then expand with a separate procedure. Note the use of the 6426 -- flag No_Minimize_Eliminate to prevent infinite recursion. 6427 6428 if Overflow_Check_Mode in Minimized_Or_Eliminated 6429 and then Is_Signed_Integer_Type (Ltyp) 6430 and then not No_Minimize_Eliminate (N) 6431 then 6432 Expand_Membership_Minimize_Eliminate_Overflow (N); 6433 return; 6434 end if; 6435 6436 -- Check case of explicit test for an expression in range of its 6437 -- subtype. This is suspicious usage and we replace it with a 'Valid 6438 -- test and give a warning for scalar types. 6439 6440 if Is_Scalar_Type (Ltyp) 6441 6442 -- Only relevant for source comparisons 6443 6444 and then Comes_From_Source (N) 6445 6446 -- In floating-point this is a standard way to check for finite values 6447 -- and using 'Valid would typically be a pessimization. 6448 6449 and then not Is_Floating_Point_Type (Ltyp) 6450 6451 -- Don't give the message unless right operand is a type entity and 6452 -- the type of the left operand matches this type. Note that this 6453 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow 6454 -- checks have changed the type of the left operand. 6455 6456 and then Nkind (Rop) in N_Has_Entity 6457 and then Ltyp = Entity (Rop) 6458 6459 -- Skip this for predicated types, where such expressions are a 6460 -- reasonable way of testing if something meets the predicate. 6461 6462 and then not Present (Predicate_Function (Ltyp)) 6463 then 6464 Substitute_Valid_Check; 6465 return; 6466 end if; 6467 6468 -- Do validity check on operands 6469 6470 if Validity_Checks_On and Validity_Check_Operands then 6471 Ensure_Valid (Left_Opnd (N)); 6472 Validity_Check_Range (Right_Opnd (N)); 6473 end if; 6474 6475 -- Case of explicit range 6476 6477 if Nkind (Rop) = N_Range then 6478 declare 6479 Lo : constant Node_Id := Low_Bound (Rop); 6480 Hi : constant Node_Id := High_Bound (Rop); 6481 6482 Lo_Orig : constant Node_Id := Original_Node (Lo); 6483 Hi_Orig : constant Node_Id := Original_Node (Hi); 6484 6485 Lcheck : Compare_Result; 6486 Ucheck : Compare_Result; 6487 6488 Warn1 : constant Boolean := 6489 Constant_Condition_Warnings 6490 and then Comes_From_Source (N) 6491 and then not In_Instance; 6492 -- This must be true for any of the optimization warnings, we 6493 -- clearly want to give them only for source with the flag on. We 6494 -- also skip these warnings in an instance since it may be the 6495 -- case that different instantiations have different ranges. 6496 6497 Warn2 : constant Boolean := 6498 Warn1 6499 and then Nkind (Original_Node (Rop)) = N_Range 6500 and then Is_Integer_Type (Etype (Lo)); 6501 -- For the case where only one bound warning is elided, we also 6502 -- insist on an explicit range and an integer type. The reason is 6503 -- that the use of enumeration ranges including an end point is 6504 -- common, as is the use of a subtype name, one of whose bounds is 6505 -- the same as the type of the expression. 6506 6507 begin 6508 -- If test is explicit x'First .. x'Last, replace by valid check 6509 6510 -- Could use some individual comments for this complex test ??? 6511 6512 if Is_Scalar_Type (Ltyp) 6513 6514 -- And left operand is X'First where X matches left operand 6515 -- type (this eliminates cases of type mismatch, including 6516 -- the cases where ELIMINATED/MINIMIZED mode has changed the 6517 -- type of the left operand. 6518 6519 and then Nkind (Lo_Orig) = N_Attribute_Reference 6520 and then Attribute_Name (Lo_Orig) = Name_First 6521 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity 6522 and then Entity (Prefix (Lo_Orig)) = Ltyp 6523 6524 -- Same tests for right operand 6525 6526 and then Nkind (Hi_Orig) = N_Attribute_Reference 6527 and then Attribute_Name (Hi_Orig) = Name_Last 6528 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity 6529 and then Entity (Prefix (Hi_Orig)) = Ltyp 6530 6531 -- Relevant only for source cases 6532 6533 and then Comes_From_Source (N) 6534 then 6535 Substitute_Valid_Check; 6536 goto Leave; 6537 end if; 6538 6539 -- If bounds of type are known at compile time, and the end points 6540 -- are known at compile time and identical, this is another case 6541 -- for substituting a valid test. We only do this for discrete 6542 -- types, since it won't arise in practice for float types. 6543 6544 if Comes_From_Source (N) 6545 and then Is_Discrete_Type (Ltyp) 6546 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) 6547 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) 6548 and then Compile_Time_Known_Value (Lo) 6549 and then Compile_Time_Known_Value (Hi) 6550 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) 6551 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) 6552 6553 -- Kill warnings in instances, since they may be cases where we 6554 -- have a test in the generic that makes sense with some types 6555 -- and not with other types. 6556 6557 -- Similarly, do not rewrite membership as a validity check if 6558 -- within the predicate function for the type. 6559 6560 -- Finally, if the original bounds are type conversions, even 6561 -- if they have been folded into constants, there are different 6562 -- types involved and 'Valid is not appropriate. 6563 6564 then 6565 if In_Instance 6566 or else (Ekind (Current_Scope) = E_Function 6567 and then Is_Predicate_Function (Current_Scope)) 6568 then 6569 null; 6570 6571 elsif Nkind (Lo_Orig) = N_Type_Conversion 6572 or else Nkind (Hi_Orig) = N_Type_Conversion 6573 then 6574 null; 6575 6576 else 6577 Substitute_Valid_Check; 6578 goto Leave; 6579 end if; 6580 end if; 6581 6582 -- If we have an explicit range, do a bit of optimization based on 6583 -- range analysis (we may be able to kill one or both checks). 6584 6585 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); 6586 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); 6587 6588 -- If either check is known to fail, replace result by False since 6589 -- the other check does not matter. Preserve the static flag for 6590 -- legality checks, because we are constant-folding beyond RM 4.9. 6591 6592 if Lcheck = LT or else Ucheck = GT then 6593 if Warn1 then 6594 Error_Msg_N ("?c?range test optimized away", N); 6595 Error_Msg_N ("\?c?value is known to be out of range", N); 6596 end if; 6597 6598 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6599 Analyze_And_Resolve (N, Restyp); 6600 Set_Is_Static_Expression (N, Static); 6601 goto Leave; 6602 6603 -- If both checks are known to succeed, replace result by True, 6604 -- since we know we are in range. 6605 6606 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 6607 if Warn1 then 6608 Error_Msg_N ("?c?range test optimized away", N); 6609 Error_Msg_N ("\?c?value is known to be in range", N); 6610 end if; 6611 6612 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6613 Analyze_And_Resolve (N, Restyp); 6614 Set_Is_Static_Expression (N, Static); 6615 goto Leave; 6616 6617 -- If lower bound check succeeds and upper bound check is not 6618 -- known to succeed or fail, then replace the range check with 6619 -- a comparison against the upper bound. 6620 6621 elsif Lcheck in Compare_GE then 6622 if Warn2 and then not In_Instance then 6623 Error_Msg_N ("??lower bound test optimized away", Lo); 6624 Error_Msg_N ("\??value is known to be in range", Lo); 6625 end if; 6626 6627 Rewrite (N, 6628 Make_Op_Le (Loc, 6629 Left_Opnd => Lop, 6630 Right_Opnd => High_Bound (Rop))); 6631 Analyze_And_Resolve (N, Restyp); 6632 goto Leave; 6633 6634 -- If upper bound check succeeds and lower bound check is not 6635 -- known to succeed or fail, then replace the range check with 6636 -- a comparison against the lower bound. 6637 6638 elsif Ucheck in Compare_LE then 6639 if Warn2 and then not In_Instance then 6640 Error_Msg_N ("??upper bound test optimized away", Hi); 6641 Error_Msg_N ("\??value is known to be in range", Hi); 6642 end if; 6643 6644 Rewrite (N, 6645 Make_Op_Ge (Loc, 6646 Left_Opnd => Lop, 6647 Right_Opnd => Low_Bound (Rop))); 6648 Analyze_And_Resolve (N, Restyp); 6649 goto Leave; 6650 end if; 6651 6652 -- We couldn't optimize away the range check, but there is one 6653 -- more issue. If we are checking constant conditionals, then we 6654 -- see if we can determine the outcome assuming everything is 6655 -- valid, and if so give an appropriate warning. 6656 6657 if Warn1 and then not Assume_No_Invalid_Values then 6658 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True); 6659 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True); 6660 6661 -- Result is out of range for valid value 6662 6663 if Lcheck = LT or else Ucheck = GT then 6664 Error_Msg_N 6665 ("?c?value can only be in range if it is invalid", N); 6666 6667 -- Result is in range for valid value 6668 6669 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 6670 Error_Msg_N 6671 ("?c?value can only be out of range if it is invalid", N); 6672 6673 -- Lower bound check succeeds if value is valid 6674 6675 elsif Warn2 and then Lcheck in Compare_GE then 6676 Error_Msg_N 6677 ("?c?lower bound check only fails if it is invalid", Lo); 6678 6679 -- Upper bound check succeeds if value is valid 6680 6681 elsif Warn2 and then Ucheck in Compare_LE then 6682 Error_Msg_N 6683 ("?c?upper bound check only fails for invalid values", Hi); 6684 end if; 6685 end if; 6686 end; 6687 6688 -- Try to narrow the operation 6689 6690 if Ltyp = Universal_Integer and then Nkind (N) = N_In then 6691 Narrow_Large_Operation (N); 6692 end if; 6693 6694 -- For all other cases of an explicit range, nothing to be done 6695 6696 goto Leave; 6697 6698 -- Here right operand is a subtype mark 6699 6700 else 6701 declare 6702 Typ : Entity_Id := Etype (Rop); 6703 Is_Acc : constant Boolean := Is_Access_Type (Typ); 6704 Check_Null_Exclusion : Boolean; 6705 Cond : Node_Id := Empty; 6706 New_N : Node_Id; 6707 Obj : Node_Id := Lop; 6708 SCIL_Node : Node_Id; 6709 6710 begin 6711 Remove_Side_Effects (Obj); 6712 6713 -- For tagged type, do tagged membership operation 6714 6715 if Is_Tagged_Type (Typ) then 6716 6717 -- No expansion will be performed for VM targets, as the VM 6718 -- back ends will handle the membership tests directly. 6719 6720 if Tagged_Type_Expansion then 6721 Tagged_Membership (N, SCIL_Node, New_N); 6722 Rewrite (N, New_N); 6723 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks); 6724 6725 -- Update decoration of relocated node referenced by the 6726 -- SCIL node. 6727 6728 if Generate_SCIL and then Present (SCIL_Node) then 6729 Set_SCIL_Node (N, SCIL_Node); 6730 end if; 6731 end if; 6732 6733 goto Leave; 6734 6735 -- If type is scalar type, rewrite as x in t'First .. t'Last. 6736 -- This reason we do this is that the bounds may have the wrong 6737 -- type if they come from the original type definition. Also this 6738 -- way we get all the processing above for an explicit range. 6739 6740 -- Don't do this for predicated types, since in this case we 6741 -- want to check the predicate. 6742 6743 elsif Is_Scalar_Type (Typ) then 6744 if No (Predicate_Function (Typ)) then 6745 Rewrite (Rop, 6746 Make_Range (Loc, 6747 Low_Bound => 6748 Make_Attribute_Reference (Loc, 6749 Attribute_Name => Name_First, 6750 Prefix => New_Occurrence_Of (Typ, Loc)), 6751 6752 High_Bound => 6753 Make_Attribute_Reference (Loc, 6754 Attribute_Name => Name_Last, 6755 Prefix => New_Occurrence_Of (Typ, Loc)))); 6756 Analyze_And_Resolve (N, Restyp); 6757 end if; 6758 6759 goto Leave; 6760 6761 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is 6762 -- raised when evaluating an individual membership test if the 6763 -- subtype mark denotes a constrained Unchecked_Union subtype 6764 -- and the expression lacks inferable discriminants. 6765 6766 elsif Is_Unchecked_Union (Base_Type (Typ)) 6767 and then Is_Constrained (Typ) 6768 and then not Has_Inferable_Discriminants (Lop) 6769 then 6770 Rewrite (N, 6771 Make_Expression_With_Actions (Loc, 6772 Actions => 6773 New_List (Make_Raise_Program_Error (Loc, 6774 Reason => PE_Unchecked_Union_Restriction)), 6775 Expression => 6776 New_Occurrence_Of (Standard_False, Loc))); 6777 Analyze_And_Resolve (N, Restyp); 6778 6779 goto Leave; 6780 end if; 6781 6782 -- Here we have a non-scalar type 6783 6784 if Is_Acc then 6785 6786 -- If the null exclusion checks are not compatible, need to 6787 -- perform further checks. In other words, we cannot have 6788 -- Ltyp including null and Typ excluding null. All other cases 6789 -- are OK. 6790 6791 Check_Null_Exclusion := 6792 Can_Never_Be_Null (Typ) and then not Can_Never_Be_Null (Ltyp); 6793 Typ := Designated_Type (Typ); 6794 end if; 6795 6796 if not Is_Constrained (Typ) then 6797 Cond := New_Occurrence_Of (Standard_True, Loc); 6798 6799 -- For the constrained array case, we have to check the subscripts 6800 -- for an exact match if the lengths are non-zero (the lengths 6801 -- must match in any case). 6802 6803 elsif Is_Array_Type (Typ) then 6804 Check_Subscripts : declare 6805 function Build_Attribute_Reference 6806 (E : Node_Id; 6807 Nam : Name_Id; 6808 Dim : Nat) return Node_Id; 6809 -- Build attribute reference E'Nam (Dim) 6810 6811 ------------------------------- 6812 -- Build_Attribute_Reference -- 6813 ------------------------------- 6814 6815 function Build_Attribute_Reference 6816 (E : Node_Id; 6817 Nam : Name_Id; 6818 Dim : Nat) return Node_Id 6819 is 6820 begin 6821 return 6822 Make_Attribute_Reference (Loc, 6823 Prefix => E, 6824 Attribute_Name => Nam, 6825 Expressions => New_List ( 6826 Make_Integer_Literal (Loc, Dim))); 6827 end Build_Attribute_Reference; 6828 6829 -- Start of processing for Check_Subscripts 6830 6831 begin 6832 for J in 1 .. Number_Dimensions (Typ) loop 6833 Evolve_And_Then (Cond, 6834 Make_Op_Eq (Loc, 6835 Left_Opnd => 6836 Build_Attribute_Reference 6837 (Duplicate_Subexpr_No_Checks (Obj), 6838 Name_First, J), 6839 Right_Opnd => 6840 Build_Attribute_Reference 6841 (New_Occurrence_Of (Typ, Loc), Name_First, J))); 6842 6843 Evolve_And_Then (Cond, 6844 Make_Op_Eq (Loc, 6845 Left_Opnd => 6846 Build_Attribute_Reference 6847 (Duplicate_Subexpr_No_Checks (Obj), 6848 Name_Last, J), 6849 Right_Opnd => 6850 Build_Attribute_Reference 6851 (New_Occurrence_Of (Typ, Loc), Name_Last, J))); 6852 end loop; 6853 end Check_Subscripts; 6854 6855 -- These are the cases where constraint checks may be required, 6856 -- e.g. records with possible discriminants 6857 6858 else 6859 -- Expand the test into a series of discriminant comparisons. 6860 -- The expression that is built is the negation of the one that 6861 -- is used for checking discriminant constraints. 6862 6863 Obj := Relocate_Node (Left_Opnd (N)); 6864 6865 if Has_Discriminants (Typ) then 6866 Cond := Make_Op_Not (Loc, 6867 Right_Opnd => Build_Discriminant_Checks (Obj, Typ)); 6868 else 6869 Cond := New_Occurrence_Of (Standard_True, Loc); 6870 end if; 6871 end if; 6872 6873 if Is_Acc then 6874 if Check_Null_Exclusion then 6875 Cond := Make_And_Then (Loc, 6876 Left_Opnd => 6877 Make_Op_Ne (Loc, 6878 Left_Opnd => Obj, 6879 Right_Opnd => Make_Null (Loc)), 6880 Right_Opnd => Cond); 6881 else 6882 Cond := Make_Or_Else (Loc, 6883 Left_Opnd => 6884 Make_Op_Eq (Loc, 6885 Left_Opnd => Obj, 6886 Right_Opnd => Make_Null (Loc)), 6887 Right_Opnd => Cond); 6888 end if; 6889 end if; 6890 6891 Rewrite (N, Cond); 6892 Analyze_And_Resolve (N, Restyp); 6893 6894 -- Ada 2012 (AI05-0149): Handle membership tests applied to an 6895 -- expression of an anonymous access type. This can involve an 6896 -- accessibility test and a tagged type membership test in the 6897 -- case of tagged designated types. 6898 6899 if Ada_Version >= Ada_2012 6900 and then Is_Acc 6901 and then Ekind (Ltyp) = E_Anonymous_Access_Type 6902 then 6903 declare 6904 Expr_Entity : Entity_Id := Empty; 6905 New_N : Node_Id; 6906 Param_Level : Node_Id; 6907 Type_Level : Node_Id; 6908 6909 begin 6910 if Is_Entity_Name (Lop) then 6911 Expr_Entity := Param_Entity (Lop); 6912 6913 if not Present (Expr_Entity) then 6914 Expr_Entity := Entity (Lop); 6915 end if; 6916 end if; 6917 6918 -- If a conversion of the anonymous access value to the 6919 -- tested type would be illegal, then the result is False. 6920 6921 if not Valid_Conversion 6922 (Lop, Rtyp, Lop, Report_Errs => False) 6923 then 6924 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 6925 Analyze_And_Resolve (N, Restyp); 6926 6927 -- Apply an accessibility check if the access object has an 6928 -- associated access level and when the level of the type is 6929 -- less deep than the level of the access parameter. This 6930 -- can only occur for access parameters and stand-alone 6931 -- objects of an anonymous access type. 6932 6933 else 6934 Param_Level := Accessibility_Level 6935 (Expr_Entity, Dynamic_Level); 6936 6937 Type_Level := 6938 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); 6939 6940 -- Return True only if the accessibility level of the 6941 -- expression entity is not deeper than the level of 6942 -- the tested access type. 6943 6944 Rewrite (N, 6945 Make_And_Then (Loc, 6946 Left_Opnd => Relocate_Node (N), 6947 Right_Opnd => Make_Op_Le (Loc, 6948 Left_Opnd => Param_Level, 6949 Right_Opnd => Type_Level))); 6950 6951 Analyze_And_Resolve (N); 6952 6953 -- If the designated type is tagged, do tagged membership 6954 -- operation. 6955 6956 if Is_Tagged_Type (Typ) then 6957 6958 -- No expansion will be performed for VM targets, as 6959 -- the VM back ends will handle the membership tests 6960 -- directly. 6961 6962 if Tagged_Type_Expansion then 6963 6964 -- Note that we have to pass Original_Node, because 6965 -- the membership test might already have been 6966 -- rewritten by earlier parts of membership test. 6967 6968 Tagged_Membership 6969 (Original_Node (N), SCIL_Node, New_N); 6970 6971 -- Update decoration of relocated node referenced 6972 -- by the SCIL node. 6973 6974 if Generate_SCIL and then Present (SCIL_Node) then 6975 Set_SCIL_Node (New_N, SCIL_Node); 6976 end if; 6977 6978 Rewrite (N, 6979 Make_And_Then (Loc, 6980 Left_Opnd => Relocate_Node (N), 6981 Right_Opnd => New_N)); 6982 6983 Analyze_And_Resolve (N, Restyp); 6984 end if; 6985 end if; 6986 end if; 6987 end; 6988 end if; 6989 end; 6990 end if; 6991 6992 -- At this point, we have done the processing required for the basic 6993 -- membership test, but not yet dealt with the predicate. 6994 6995 <<Leave>> 6996 6997 -- If a predicate is present, then we do the predicate test, but we 6998 -- most certainly want to omit this if we are within the predicate 6999 -- function itself, since otherwise we have an infinite recursion. 7000 -- The check should also not be emitted when testing against a range 7001 -- (the check is only done when the right operand is a subtype; see 7002 -- RM12-4.5.2 (28.1/3-30/3)). 7003 7004 Predicate_Check : declare 7005 function In_Range_Check return Boolean; 7006 -- Within an expanded range check that may raise Constraint_Error do 7007 -- not generate a predicate check as well. It is redundant because 7008 -- the context will add an explicit predicate check, and it will 7009 -- raise the wrong exception if it fails. 7010 7011 -------------------- 7012 -- In_Range_Check -- 7013 -------------------- 7014 7015 function In_Range_Check return Boolean is 7016 P : Node_Id; 7017 begin 7018 P := Parent (N); 7019 while Present (P) loop 7020 if Nkind (P) = N_Raise_Constraint_Error then 7021 return True; 7022 7023 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call 7024 or else Nkind (P) = N_Procedure_Call_Statement 7025 or else Nkind (P) in N_Declaration 7026 then 7027 return False; 7028 end if; 7029 7030 P := Parent (P); 7031 end loop; 7032 7033 return False; 7034 end In_Range_Check; 7035 7036 -- Local variables 7037 7038 PFunc : constant Entity_Id := Predicate_Function (Rtyp); 7039 R_Op : Node_Id; 7040 7041 -- Start of processing for Predicate_Check 7042 7043 begin 7044 if Present (PFunc) 7045 and then Current_Scope /= PFunc 7046 and then Nkind (Rop) /= N_Range 7047 then 7048 if not In_Range_Check then 7049 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True); 7050 else 7051 R_Op := New_Occurrence_Of (Standard_True, Loc); 7052 end if; 7053 7054 Rewrite (N, 7055 Make_And_Then (Loc, 7056 Left_Opnd => Relocate_Node (N), 7057 Right_Opnd => R_Op)); 7058 7059 -- Analyze new expression, mark left operand as analyzed to 7060 -- avoid infinite recursion adding predicate calls. Similarly, 7061 -- suppress further range checks on the call. 7062 7063 Set_Analyzed (Left_Opnd (N)); 7064 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 7065 7066 -- All done, skip attempt at compile time determination of result 7067 7068 return; 7069 end if; 7070 end Predicate_Check; 7071 end Expand_N_In; 7072 7073 -------------------------------- 7074 -- Expand_N_Indexed_Component -- 7075 -------------------------------- 7076 7077 procedure Expand_N_Indexed_Component (N : Node_Id) is 7078 Loc : constant Source_Ptr := Sloc (N); 7079 Typ : constant Entity_Id := Etype (N); 7080 P : constant Node_Id := Prefix (N); 7081 T : constant Entity_Id := Etype (P); 7082 7083 begin 7084 -- A special optimization, if we have an indexed component that is 7085 -- selecting from a slice, then we can eliminate the slice, since, for 7086 -- example, x (i .. j)(k) is identical to x(k). The only difference is 7087 -- the range check required by the slice. The range check for the slice 7088 -- itself has already been generated. The range check for the 7089 -- subscripting operation is ensured by converting the subject to 7090 -- the subtype of the slice. 7091 7092 -- This optimization not only generates better code, avoiding slice 7093 -- messing especially in the packed case, but more importantly bypasses 7094 -- some problems in handling this peculiar case, for example, the issue 7095 -- of dealing specially with object renamings. 7096 7097 if Nkind (P) = N_Slice 7098 7099 -- This optimization is disabled for CodePeer because it can transform 7100 -- an index-check constraint_error into a range-check constraint_error 7101 -- and CodePeer cares about that distinction. 7102 7103 and then not CodePeer_Mode 7104 then 7105 Rewrite (N, 7106 Make_Indexed_Component (Loc, 7107 Prefix => Prefix (P), 7108 Expressions => New_List ( 7109 Convert_To 7110 (Etype (First_Index (Etype (P))), 7111 First (Expressions (N)))))); 7112 Analyze_And_Resolve (N, Typ); 7113 return; 7114 end if; 7115 7116 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 7117 -- function, then additional actuals must be passed. 7118 7119 if Is_Build_In_Place_Function_Call (P) then 7120 Make_Build_In_Place_Call_In_Anonymous_Context (P); 7121 7122 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 7123 -- containing build-in-place function calls whose returned object covers 7124 -- interface types. 7125 7126 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then 7127 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); 7128 end if; 7129 7130 -- Generate index and validity checks 7131 7132 Generate_Index_Checks (N); 7133 7134 if Validity_Checks_On and then Validity_Check_Subscripts then 7135 Apply_Subscript_Validity_Checks (N); 7136 end if; 7137 7138 -- If selecting from an array with atomic components, and atomic sync 7139 -- is not suppressed for this array type, set atomic sync flag. 7140 7141 if (Has_Atomic_Components (T) 7142 and then not Atomic_Synchronization_Disabled (T)) 7143 or else (Is_Atomic (Typ) 7144 and then not Atomic_Synchronization_Disabled (Typ)) 7145 or else (Is_Entity_Name (P) 7146 and then Has_Atomic_Components (Entity (P)) 7147 and then not Atomic_Synchronization_Disabled (Entity (P))) 7148 then 7149 Activate_Atomic_Synchronization (N); 7150 end if; 7151 7152 -- All done if the prefix is not a packed array implemented specially 7153 7154 if not (Is_Packed (Etype (Prefix (N))) 7155 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N))))) 7156 then 7157 return; 7158 end if; 7159 7160 -- For packed arrays that are not bit-packed (i.e. the case of an array 7161 -- with one or more index types with a non-contiguous enumeration type), 7162 -- we can always use the normal packed element get circuit. 7163 7164 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then 7165 Expand_Packed_Element_Reference (N); 7166 return; 7167 end if; 7168 7169 -- For a reference to a component of a bit packed array, we convert it 7170 -- to a reference to the corresponding Packed_Array_Impl_Type. We only 7171 -- want to do this for simple references, and not for: 7172 7173 -- Left side of assignment, or prefix of left side of assignment, or 7174 -- prefix of the prefix, to handle packed arrays of packed arrays, 7175 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement 7176 7177 -- Renaming objects in renaming associations 7178 -- This case is handled when a use of the renamed variable occurs 7179 7180 -- Actual parameters for a subprogram call 7181 -- This case is handled in Exp_Ch6.Expand_Actuals 7182 7183 -- The second expression in a 'Read attribute reference 7184 7185 -- The prefix of an address or bit or size attribute reference 7186 7187 -- The following circuit detects these exceptions. Note that we need to 7188 -- deal with implicit dereferences when climbing up the parent chain, 7189 -- with the additional difficulty that the type of parents may have yet 7190 -- to be resolved since prefixes are usually resolved first. 7191 7192 declare 7193 Child : Node_Id := N; 7194 Parnt : Node_Id := Parent (N); 7195 7196 begin 7197 loop 7198 if Nkind (Parnt) = N_Unchecked_Expression then 7199 null; 7200 7201 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then 7202 return; 7203 7204 elsif Nkind (Parnt) in N_Subprogram_Call 7205 or else (Nkind (Parnt) = N_Parameter_Association 7206 and then Nkind (Parent (Parnt)) in N_Subprogram_Call) 7207 then 7208 return; 7209 7210 elsif Nkind (Parnt) = N_Attribute_Reference 7211 and then Attribute_Name (Parnt) in Name_Address 7212 | Name_Bit 7213 | Name_Size 7214 and then Prefix (Parnt) = Child 7215 then 7216 return; 7217 7218 elsif Nkind (Parnt) = N_Assignment_Statement 7219 and then Name (Parnt) = Child 7220 then 7221 return; 7222 7223 -- If the expression is an index of an indexed component, it must 7224 -- be expanded regardless of context. 7225 7226 elsif Nkind (Parnt) = N_Indexed_Component 7227 and then Child /= Prefix (Parnt) 7228 then 7229 Expand_Packed_Element_Reference (N); 7230 return; 7231 7232 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement 7233 and then Name (Parent (Parnt)) = Parnt 7234 then 7235 return; 7236 7237 elsif Nkind (Parnt) = N_Attribute_Reference 7238 and then Attribute_Name (Parnt) = Name_Read 7239 and then Next (First (Expressions (Parnt))) = Child 7240 then 7241 return; 7242 7243 elsif Nkind (Parnt) = N_Indexed_Component 7244 and then Prefix (Parnt) = Child 7245 then 7246 null; 7247 7248 elsif Nkind (Parnt) = N_Selected_Component 7249 and then Prefix (Parnt) = Child 7250 and then not (Present (Etype (Selector_Name (Parnt))) 7251 and then 7252 Is_Access_Type (Etype (Selector_Name (Parnt)))) 7253 then 7254 null; 7255 7256 -- If the parent is a dereference, either implicit or explicit, 7257 -- then the packed reference needs to be expanded. 7258 7259 else 7260 Expand_Packed_Element_Reference (N); 7261 return; 7262 end if; 7263 7264 -- Keep looking up tree for unchecked expression, or if we are the 7265 -- prefix of a possible assignment left side. 7266 7267 Child := Parnt; 7268 Parnt := Parent (Child); 7269 end loop; 7270 end; 7271 end Expand_N_Indexed_Component; 7272 7273 --------------------- 7274 -- Expand_N_Not_In -- 7275 --------------------- 7276 7277 -- Replace a not in b by not (a in b) so that the expansions for (a in b) 7278 -- can be done. This avoids needing to duplicate this expansion code. 7279 7280 procedure Expand_N_Not_In (N : Node_Id) is 7281 Loc : constant Source_Ptr := Sloc (N); 7282 Typ : constant Entity_Id := Etype (N); 7283 Cfs : constant Boolean := Comes_From_Source (N); 7284 7285 begin 7286 Rewrite (N, 7287 Make_Op_Not (Loc, 7288 Right_Opnd => 7289 Make_In (Loc, 7290 Left_Opnd => Left_Opnd (N), 7291 Right_Opnd => Right_Opnd (N)))); 7292 7293 -- If this is a set membership, preserve list of alternatives 7294 7295 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); 7296 7297 -- We want this to appear as coming from source if original does (see 7298 -- transformations in Expand_N_In). 7299 7300 Set_Comes_From_Source (N, Cfs); 7301 Set_Comes_From_Source (Right_Opnd (N), Cfs); 7302 7303 -- Now analyze transformed node 7304 7305 Analyze_And_Resolve (N, Typ); 7306 end Expand_N_Not_In; 7307 7308 ------------------- 7309 -- Expand_N_Null -- 7310 ------------------- 7311 7312 -- The only replacement required is for the case of a null of a type that 7313 -- is an access to protected subprogram, or a subtype thereof. We represent 7314 -- such access values as a record, and so we must replace the occurrence of 7315 -- null by the equivalent record (with a null address and a null pointer in 7316 -- it), so that the back end creates the proper value. 7317 7318 procedure Expand_N_Null (N : Node_Id) is 7319 Loc : constant Source_Ptr := Sloc (N); 7320 Typ : constant Entity_Id := Base_Type (Etype (N)); 7321 Agg : Node_Id; 7322 7323 begin 7324 if Is_Access_Protected_Subprogram_Type (Typ) then 7325 Agg := 7326 Make_Aggregate (Loc, 7327 Expressions => New_List ( 7328 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 7329 Make_Null (Loc))); 7330 7331 Rewrite (N, Agg); 7332 Analyze_And_Resolve (N, Equivalent_Type (Typ)); 7333 7334 -- For subsequent semantic analysis, the node must retain its type. 7335 -- Gigi in any case replaces this type by the corresponding record 7336 -- type before processing the node. 7337 7338 Set_Etype (N, Typ); 7339 end if; 7340 7341 exception 7342 when RE_Not_Available => 7343 return; 7344 end Expand_N_Null; 7345 7346 --------------------- 7347 -- Expand_N_Op_Abs -- 7348 --------------------- 7349 7350 procedure Expand_N_Op_Abs (N : Node_Id) is 7351 Loc : constant Source_Ptr := Sloc (N); 7352 Expr : constant Node_Id := Right_Opnd (N); 7353 Typ : constant Entity_Id := Etype (N); 7354 7355 begin 7356 Unary_Op_Validity_Checks (N); 7357 7358 -- Check for MINIMIZED/ELIMINATED overflow mode 7359 7360 if Minimized_Eliminated_Overflow_Check (N) then 7361 Apply_Arithmetic_Overflow_Check (N); 7362 return; 7363 end if; 7364 7365 -- Try to narrow the operation 7366 7367 if Typ = Universal_Integer then 7368 Narrow_Large_Operation (N); 7369 7370 if Nkind (N) /= N_Op_Abs then 7371 return; 7372 end if; 7373 end if; 7374 7375 -- Deal with software overflow checking 7376 7377 if Is_Signed_Integer_Type (Typ) 7378 and then Do_Overflow_Check (N) 7379 then 7380 -- The only case to worry about is when the argument is equal to the 7381 -- largest negative number, so what we do is to insert the check: 7382 7383 -- [constraint_error when Expr = typ'Base'First] 7384 7385 -- with the usual Duplicate_Subexpr use coding for expr 7386 7387 Insert_Action (N, 7388 Make_Raise_Constraint_Error (Loc, 7389 Condition => 7390 Make_Op_Eq (Loc, 7391 Left_Opnd => Duplicate_Subexpr (Expr), 7392 Right_Opnd => 7393 Make_Attribute_Reference (Loc, 7394 Prefix => 7395 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), 7396 Attribute_Name => Name_First)), 7397 Reason => CE_Overflow_Check_Failed)); 7398 7399 Set_Do_Overflow_Check (N, False); 7400 end if; 7401 end Expand_N_Op_Abs; 7402 7403 --------------------- 7404 -- Expand_N_Op_Add -- 7405 --------------------- 7406 7407 procedure Expand_N_Op_Add (N : Node_Id) is 7408 Typ : constant Entity_Id := Etype (N); 7409 7410 begin 7411 Binary_Op_Validity_Checks (N); 7412 7413 -- Check for MINIMIZED/ELIMINATED overflow mode 7414 7415 if Minimized_Eliminated_Overflow_Check (N) then 7416 Apply_Arithmetic_Overflow_Check (N); 7417 return; 7418 end if; 7419 7420 -- N + 0 = 0 + N = N for integer types 7421 7422 if Is_Integer_Type (Typ) then 7423 if Compile_Time_Known_Value (Right_Opnd (N)) 7424 and then Expr_Value (Right_Opnd (N)) = Uint_0 7425 then 7426 Rewrite (N, Left_Opnd (N)); 7427 return; 7428 7429 elsif Compile_Time_Known_Value (Left_Opnd (N)) 7430 and then Expr_Value (Left_Opnd (N)) = Uint_0 7431 then 7432 Rewrite (N, Right_Opnd (N)); 7433 return; 7434 end if; 7435 end if; 7436 7437 -- Try to narrow the operation 7438 7439 if Typ = Universal_Integer then 7440 Narrow_Large_Operation (N); 7441 7442 if Nkind (N) /= N_Op_Add then 7443 return; 7444 end if; 7445 end if; 7446 7447 -- Arithmetic overflow checks for signed integer/fixed point types 7448 7449 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then 7450 Apply_Arithmetic_Overflow_Check (N); 7451 return; 7452 end if; 7453 7454 -- Overflow checks for floating-point if -gnateF mode active 7455 7456 Check_Float_Op_Overflow (N); 7457 7458 Expand_Nonbinary_Modular_Op (N); 7459 end Expand_N_Op_Add; 7460 7461 --------------------- 7462 -- Expand_N_Op_And -- 7463 --------------------- 7464 7465 procedure Expand_N_Op_And (N : Node_Id) is 7466 Typ : constant Entity_Id := Etype (N); 7467 7468 begin 7469 Binary_Op_Validity_Checks (N); 7470 7471 if Is_Array_Type (Etype (N)) then 7472 Expand_Boolean_Operator (N); 7473 7474 elsif Is_Boolean_Type (Etype (N)) then 7475 Adjust_Condition (Left_Opnd (N)); 7476 Adjust_Condition (Right_Opnd (N)); 7477 Set_Etype (N, Standard_Boolean); 7478 Adjust_Result_Type (N, Typ); 7479 7480 elsif Is_Intrinsic_Subprogram (Entity (N)) then 7481 Expand_Intrinsic_Call (N, Entity (N)); 7482 end if; 7483 7484 Expand_Nonbinary_Modular_Op (N); 7485 end Expand_N_Op_And; 7486 7487 ------------------------ 7488 -- Expand_N_Op_Concat -- 7489 ------------------------ 7490 7491 procedure Expand_N_Op_Concat (N : Node_Id) is 7492 Opnds : List_Id; 7493 -- List of operands to be concatenated 7494 7495 Cnode : Node_Id; 7496 -- Node which is to be replaced by the result of concatenating the nodes 7497 -- in the list Opnds. 7498 7499 begin 7500 -- Ensure validity of both operands 7501 7502 Binary_Op_Validity_Checks (N); 7503 7504 -- If we are the left operand of a concatenation higher up the tree, 7505 -- then do nothing for now, since we want to deal with a series of 7506 -- concatenations as a unit. 7507 7508 if Nkind (Parent (N)) = N_Op_Concat 7509 and then N = Left_Opnd (Parent (N)) 7510 then 7511 return; 7512 end if; 7513 7514 -- We get here with a concatenation whose left operand may be a 7515 -- concatenation itself with a consistent type. We need to process 7516 -- these concatenation operands from left to right, which means 7517 -- from the deepest node in the tree to the highest node. 7518 7519 Cnode := N; 7520 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop 7521 Cnode := Left_Opnd (Cnode); 7522 end loop; 7523 7524 -- Now Cnode is the deepest concatenation, and its parents are the 7525 -- concatenation nodes above, so now we process bottom up, doing the 7526 -- operands. 7527 7528 -- The outer loop runs more than once if more than one concatenation 7529 -- type is involved. 7530 7531 Outer : loop 7532 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); 7533 Set_Parent (Opnds, N); 7534 7535 -- The inner loop gathers concatenation operands 7536 7537 Inner : while Cnode /= N 7538 and then Base_Type (Etype (Cnode)) = 7539 Base_Type (Etype (Parent (Cnode))) 7540 loop 7541 Cnode := Parent (Cnode); 7542 Append (Right_Opnd (Cnode), Opnds); 7543 end loop Inner; 7544 7545 -- Note: The following code is a temporary workaround for N731-034 7546 -- and N829-028 and will be kept until the general issue of internal 7547 -- symbol serialization is addressed. The workaround is kept under a 7548 -- debug switch to avoid permiating into the general case. 7549 7550 -- Wrap the node to concatenate into an expression actions node to 7551 -- keep it nicely packaged. This is useful in the case of an assert 7552 -- pragma with a concatenation where we want to be able to delete 7553 -- the concatenation and all its expansion stuff. 7554 7555 if Debug_Flag_Dot_H then 7556 declare 7557 Cnod : constant Node_Id := New_Copy_Tree (Cnode); 7558 Typ : constant Entity_Id := Base_Type (Etype (Cnode)); 7559 7560 begin 7561 -- Note: use Rewrite rather than Replace here, so that for 7562 -- example Why_Not_Static can find the original concatenation 7563 -- node OK! 7564 7565 Rewrite (Cnode, 7566 Make_Expression_With_Actions (Sloc (Cnode), 7567 Actions => New_List (Make_Null_Statement (Sloc (Cnode))), 7568 Expression => Cnod)); 7569 7570 Expand_Concatenate (Cnod, Opnds); 7571 Analyze_And_Resolve (Cnode, Typ); 7572 end; 7573 7574 -- Default case 7575 7576 else 7577 Expand_Concatenate (Cnode, Opnds); 7578 end if; 7579 7580 exit Outer when Cnode = N; 7581 Cnode := Parent (Cnode); 7582 end loop Outer; 7583 end Expand_N_Op_Concat; 7584 7585 ------------------------ 7586 -- Expand_N_Op_Divide -- 7587 ------------------------ 7588 7589 procedure Expand_N_Op_Divide (N : Node_Id) is 7590 Loc : constant Source_Ptr := Sloc (N); 7591 Lopnd : constant Node_Id := Left_Opnd (N); 7592 Ropnd : constant Node_Id := Right_Opnd (N); 7593 Ltyp : constant Entity_Id := Etype (Lopnd); 7594 Rtyp : constant Entity_Id := Etype (Ropnd); 7595 Typ : Entity_Id := Etype (N); 7596 Rknow : constant Boolean := Is_Integer_Type (Typ) 7597 and then 7598 Compile_Time_Known_Value (Ropnd); 7599 Rval : Uint; 7600 7601 begin 7602 Binary_Op_Validity_Checks (N); 7603 7604 -- Check for MINIMIZED/ELIMINATED overflow mode 7605 7606 if Minimized_Eliminated_Overflow_Check (N) then 7607 Apply_Arithmetic_Overflow_Check (N); 7608 return; 7609 end if; 7610 7611 -- Otherwise proceed with expansion of division 7612 7613 if Rknow then 7614 Rval := Expr_Value (Ropnd); 7615 end if; 7616 7617 -- N / 1 = N for integer types 7618 7619 if Rknow and then Rval = Uint_1 then 7620 Rewrite (N, Lopnd); 7621 return; 7622 end if; 7623 7624 -- Try to narrow the operation 7625 7626 if Typ = Universal_Integer then 7627 Narrow_Large_Operation (N); 7628 7629 if Nkind (N) /= N_Op_Divide then 7630 return; 7631 end if; 7632 end if; 7633 7634 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that 7635 -- Is_Power_Of_2_For_Shift is set means that we know that our left 7636 -- operand is an unsigned integer, as required for this to work. 7637 7638 if Nkind (Ropnd) = N_Op_Expon 7639 and then Is_Power_Of_2_For_Shift (Ropnd) 7640 7641 -- We cannot do this transformation in configurable run time mode if we 7642 -- have 64-bit integers and long shifts are not available. 7643 7644 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target) 7645 then 7646 Rewrite (N, 7647 Make_Op_Shift_Right (Loc, 7648 Left_Opnd => Lopnd, 7649 Right_Opnd => 7650 Convert_To (Standard_Natural, Right_Opnd (Ropnd)))); 7651 Analyze_And_Resolve (N, Typ); 7652 return; 7653 end if; 7654 7655 -- Do required fixup of universal fixed operation 7656 7657 if Typ = Universal_Fixed then 7658 Fixup_Universal_Fixed_Operation (N); 7659 Typ := Etype (N); 7660 end if; 7661 7662 -- Divisions with fixed-point results 7663 7664 if Is_Fixed_Point_Type (Typ) then 7665 7666 if Is_Integer_Type (Rtyp) then 7667 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N); 7668 else 7669 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N); 7670 end if; 7671 7672 -- Deal with divide-by-zero check if back end cannot handle them 7673 -- and the flag is set indicating that we need such a check. Note 7674 -- that we don't need to bother here with the case of mixed-mode 7675 -- (Right operand an integer type), since these will be rewritten 7676 -- with conversions to a divide with a fixed-point right operand. 7677 7678 if Nkind (N) = N_Op_Divide 7679 and then Do_Division_Check (N) 7680 and then not Backend_Divide_Checks_On_Target 7681 and then not Is_Integer_Type (Rtyp) 7682 then 7683 Set_Do_Division_Check (N, False); 7684 Insert_Action (N, 7685 Make_Raise_Constraint_Error (Loc, 7686 Condition => 7687 Make_Op_Eq (Loc, 7688 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd), 7689 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 7690 Reason => CE_Divide_By_Zero)); 7691 end if; 7692 7693 -- Other cases of division of fixed-point operands 7694 7695 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then 7696 if Is_Integer_Type (Typ) then 7697 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N); 7698 else 7699 pragma Assert (Is_Floating_Point_Type (Typ)); 7700 Expand_Divide_Fixed_By_Fixed_Giving_Float (N); 7701 end if; 7702 7703 -- Mixed-mode operations can appear in a non-static universal context, 7704 -- in which case the integer argument must be converted explicitly. 7705 7706 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then 7707 Rewrite (Ropnd, 7708 Convert_To (Universal_Real, Relocate_Node (Ropnd))); 7709 7710 Analyze_And_Resolve (Ropnd, Universal_Real); 7711 7712 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then 7713 Rewrite (Lopnd, 7714 Convert_To (Universal_Real, Relocate_Node (Lopnd))); 7715 7716 Analyze_And_Resolve (Lopnd, Universal_Real); 7717 7718 -- Non-fixed point cases, do integer zero divide and overflow checks 7719 7720 elsif Is_Integer_Type (Typ) then 7721 Apply_Divide_Checks (N); 7722 end if; 7723 7724 -- Overflow checks for floating-point if -gnateF mode active 7725 7726 Check_Float_Op_Overflow (N); 7727 7728 Expand_Nonbinary_Modular_Op (N); 7729 end Expand_N_Op_Divide; 7730 7731 -------------------- 7732 -- Expand_N_Op_Eq -- 7733 -------------------- 7734 7735 procedure Expand_N_Op_Eq (N : Node_Id) is 7736 Loc : constant Source_Ptr := Sloc (N); 7737 Typ : constant Entity_Id := Etype (N); 7738 Lhs : constant Node_Id := Left_Opnd (N); 7739 Rhs : constant Node_Id := Right_Opnd (N); 7740 Bodies : constant List_Id := New_List; 7741 A_Typ : constant Entity_Id := Etype (Lhs); 7742 7743 procedure Build_Equality_Call (Eq : Entity_Id); 7744 -- If a constructed equality exists for the type or for its parent, 7745 -- build and analyze call, adding conversions if the operation is 7746 -- inherited. 7747 7748 function Is_Equality (Subp : Entity_Id; 7749 Typ : Entity_Id := Empty) return Boolean; 7750 -- Determine whether arbitrary Entity_Id denotes a function with the 7751 -- right name and profile for an equality op, specifically for the 7752 -- base type Typ if Typ is nonempty. 7753 7754 function Find_Equality (Prims : Elist_Id) return Entity_Id; 7755 -- Find a primitive equality function within primitive operation list 7756 -- Prims. 7757 7758 function User_Defined_Primitive_Equality_Op 7759 (Typ : Entity_Id) return Entity_Id; 7760 -- Find a user-defined primitive equality function for a given untagged 7761 -- record type, ignoring visibility. Return Empty if no such op found. 7762 7763 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; 7764 -- Determines whether a type has a subcomponent of an unconstrained 7765 -- Unchecked_Union subtype. Typ is a record type. 7766 7767 ------------------------- 7768 -- Build_Equality_Call -- 7769 ------------------------- 7770 7771 procedure Build_Equality_Call (Eq : Entity_Id) is 7772 Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); 7773 L_Exp : Node_Id := Relocate_Node (Lhs); 7774 R_Exp : Node_Id := Relocate_Node (Rhs); 7775 7776 begin 7777 -- Adjust operands if necessary to comparison type 7778 7779 if Base_Type (Op_Type) /= Base_Type (A_Typ) 7780 and then not Is_Class_Wide_Type (A_Typ) 7781 then 7782 L_Exp := OK_Convert_To (Op_Type, L_Exp); 7783 R_Exp := OK_Convert_To (Op_Type, R_Exp); 7784 end if; 7785 7786 -- If we have an Unchecked_Union, we need to add the inferred 7787 -- discriminant values as actuals in the function call. At this 7788 -- point, the expansion has determined that both operands have 7789 -- inferable discriminants. 7790 7791 if Is_Unchecked_Union (Op_Type) then 7792 declare 7793 Lhs_Type : constant Node_Id := Etype (L_Exp); 7794 Rhs_Type : constant Node_Id := Etype (R_Exp); 7795 7796 Lhs_Discr_Vals : Elist_Id; 7797 -- List of inferred discriminant values for left operand. 7798 7799 Rhs_Discr_Vals : Elist_Id; 7800 -- List of inferred discriminant values for right operand. 7801 7802 Discr : Entity_Id; 7803 7804 begin 7805 Lhs_Discr_Vals := New_Elmt_List; 7806 Rhs_Discr_Vals := New_Elmt_List; 7807 7808 -- Per-object constrained selected components require special 7809 -- attention. If the enclosing scope of the component is an 7810 -- Unchecked_Union, we cannot reference its discriminants 7811 -- directly. This is why we use the extra parameters of the 7812 -- equality function of the enclosing Unchecked_Union. 7813 7814 -- type UU_Type (Discr : Integer := 0) is 7815 -- . . . 7816 -- end record; 7817 -- pragma Unchecked_Union (UU_Type); 7818 7819 -- 1. Unchecked_Union enclosing record: 7820 7821 -- type Enclosing_UU_Type (Discr : Integer := 0) is record 7822 -- . . . 7823 -- Comp : UU_Type (Discr); 7824 -- . . . 7825 -- end Enclosing_UU_Type; 7826 -- pragma Unchecked_Union (Enclosing_UU_Type); 7827 7828 -- Obj1 : Enclosing_UU_Type; 7829 -- Obj2 : Enclosing_UU_Type (1); 7830 7831 -- [. . .] Obj1 = Obj2 [. . .] 7832 7833 -- Generated code: 7834 7835 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then 7836 7837 -- A and B are the formal parameters of the equality function 7838 -- of Enclosing_UU_Type. The function always has two extra 7839 -- formals to capture the inferred discriminant values for 7840 -- each discriminant of the type. 7841 7842 -- 2. Non-Unchecked_Union enclosing record: 7843 7844 -- type 7845 -- Enclosing_Non_UU_Type (Discr : Integer := 0) 7846 -- is record 7847 -- . . . 7848 -- Comp : UU_Type (Discr); 7849 -- . . . 7850 -- end Enclosing_Non_UU_Type; 7851 7852 -- Obj1 : Enclosing_Non_UU_Type; 7853 -- Obj2 : Enclosing_Non_UU_Type (1); 7854 7855 -- ... Obj1 = Obj2 ... 7856 7857 -- Generated code: 7858 7859 -- if not (uu_typeEQ (obj1.comp, obj2.comp, 7860 -- obj1.discr, obj2.discr)) then 7861 7862 -- In this case we can directly reference the discriminants of 7863 -- the enclosing record. 7864 7865 -- Process left operand of equality 7866 7867 if Nkind (Lhs) = N_Selected_Component 7868 and then 7869 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs))) 7870 then 7871 -- If enclosing record is an Unchecked_Union, use formals 7872 -- corresponding to each discriminant. The name of the 7873 -- formal is that of the discriminant, with added suffix, 7874 -- see Exp_Ch3.Build_Record_Equality for details. 7875 7876 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs)))) 7877 then 7878 Discr := 7879 First_Discriminant 7880 (Scope (Entity (Selector_Name (Lhs)))); 7881 while Present (Discr) loop 7882 Append_Elmt 7883 (Make_Identifier (Loc, 7884 Chars => New_External_Name (Chars (Discr), 'A')), 7885 To => Lhs_Discr_Vals); 7886 Next_Discriminant (Discr); 7887 end loop; 7888 7889 -- If enclosing record is of a non-Unchecked_Union type, it 7890 -- is possible to reference its discriminants directly. 7891 7892 else 7893 Discr := First_Discriminant (Lhs_Type); 7894 while Present (Discr) loop 7895 Append_Elmt 7896 (Make_Selected_Component (Loc, 7897 Prefix => Prefix (Lhs), 7898 Selector_Name => 7899 New_Copy 7900 (Get_Discriminant_Value (Discr, 7901 Lhs_Type, 7902 Stored_Constraint (Lhs_Type)))), 7903 To => Lhs_Discr_Vals); 7904 Next_Discriminant (Discr); 7905 end loop; 7906 end if; 7907 7908 -- Otherwise operand is on object with a constrained type. 7909 -- Infer the discriminant values from the constraint. 7910 7911 else 7912 Discr := First_Discriminant (Lhs_Type); 7913 while Present (Discr) loop 7914 Append_Elmt 7915 (New_Copy 7916 (Get_Discriminant_Value (Discr, 7917 Lhs_Type, 7918 Stored_Constraint (Lhs_Type))), 7919 To => Lhs_Discr_Vals); 7920 Next_Discriminant (Discr); 7921 end loop; 7922 end if; 7923 7924 -- Similar processing for right operand of equality 7925 7926 if Nkind (Rhs) = N_Selected_Component 7927 and then 7928 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs))) 7929 then 7930 if Is_Unchecked_Union 7931 (Scope (Entity (Selector_Name (Rhs)))) 7932 then 7933 Discr := 7934 First_Discriminant 7935 (Scope (Entity (Selector_Name (Rhs)))); 7936 while Present (Discr) loop 7937 Append_Elmt 7938 (Make_Identifier (Loc, 7939 Chars => New_External_Name (Chars (Discr), 'B')), 7940 To => Rhs_Discr_Vals); 7941 Next_Discriminant (Discr); 7942 end loop; 7943 7944 else 7945 Discr := First_Discriminant (Rhs_Type); 7946 while Present (Discr) loop 7947 Append_Elmt 7948 (Make_Selected_Component (Loc, 7949 Prefix => Prefix (Rhs), 7950 Selector_Name => 7951 New_Copy (Get_Discriminant_Value 7952 (Discr, 7953 Rhs_Type, 7954 Stored_Constraint (Rhs_Type)))), 7955 To => Rhs_Discr_Vals); 7956 Next_Discriminant (Discr); 7957 end loop; 7958 end if; 7959 7960 else 7961 Discr := First_Discriminant (Rhs_Type); 7962 while Present (Discr) loop 7963 Append_Elmt 7964 (New_Copy (Get_Discriminant_Value 7965 (Discr, 7966 Rhs_Type, 7967 Stored_Constraint (Rhs_Type))), 7968 To => Rhs_Discr_Vals); 7969 Next_Discriminant (Discr); 7970 end loop; 7971 end if; 7972 7973 -- Now merge the list of discriminant values so that values 7974 -- of corresponding discriminants are adjacent. 7975 7976 declare 7977 Params : List_Id; 7978 L_Elmt : Elmt_Id; 7979 R_Elmt : Elmt_Id; 7980 7981 begin 7982 Params := New_List (L_Exp, R_Exp); 7983 L_Elmt := First_Elmt (Lhs_Discr_Vals); 7984 R_Elmt := First_Elmt (Rhs_Discr_Vals); 7985 while Present (L_Elmt) loop 7986 Append_To (Params, Node (L_Elmt)); 7987 Append_To (Params, Node (R_Elmt)); 7988 Next_Elmt (L_Elmt); 7989 Next_Elmt (R_Elmt); 7990 end loop; 7991 7992 Rewrite (N, 7993 Make_Function_Call (Loc, 7994 Name => New_Occurrence_Of (Eq, Loc), 7995 Parameter_Associations => Params)); 7996 end; 7997 end; 7998 7999 -- Normal case, not an unchecked union 8000 8001 else 8002 Rewrite (N, 8003 Make_Function_Call (Loc, 8004 Name => New_Occurrence_Of (Eq, Loc), 8005 Parameter_Associations => New_List (L_Exp, R_Exp))); 8006 end if; 8007 8008 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8009 end Build_Equality_Call; 8010 8011 ----------------- 8012 -- Is_Equality -- 8013 ----------------- 8014 8015 function Is_Equality (Subp : Entity_Id; 8016 Typ : Entity_Id := Empty) return Boolean is 8017 Formal_1 : Entity_Id; 8018 Formal_2 : Entity_Id; 8019 begin 8020 -- The equality function carries name "=", returns Boolean, and has 8021 -- exactly two formal parameters of an identical type. 8022 8023 if Ekind (Subp) = E_Function 8024 and then Chars (Subp) = Name_Op_Eq 8025 and then Base_Type (Etype (Subp)) = Standard_Boolean 8026 then 8027 Formal_1 := First_Formal (Subp); 8028 Formal_2 := Empty; 8029 8030 if Present (Formal_1) then 8031 Formal_2 := Next_Formal (Formal_1); 8032 end if; 8033 8034 return 8035 Present (Formal_1) 8036 and then Present (Formal_2) 8037 and then No (Next_Formal (Formal_2)) 8038 and then Base_Type (Etype (Formal_1)) = 8039 Base_Type (Etype (Formal_2)) 8040 and then 8041 (not Present (Typ) 8042 or else Implementation_Base_Type (Etype (Formal_1)) = Typ); 8043 end if; 8044 8045 return False; 8046 end Is_Equality; 8047 8048 ------------------- 8049 -- Find_Equality -- 8050 ------------------- 8051 8052 function Find_Equality (Prims : Elist_Id) return Entity_Id is 8053 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id; 8054 -- Find an equality in a possible alias chain starting from primitive 8055 -- operation Prim. 8056 8057 --------------------------- 8058 -- Find_Aliased_Equality -- 8059 --------------------------- 8060 8061 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is 8062 Candid : Entity_Id; 8063 8064 begin 8065 -- Inspect each candidate in the alias chain, checking whether it 8066 -- denotes an equality. 8067 8068 Candid := Prim; 8069 while Present (Candid) loop 8070 if Is_Equality (Candid) then 8071 return Candid; 8072 end if; 8073 8074 Candid := Alias (Candid); 8075 end loop; 8076 8077 return Empty; 8078 end Find_Aliased_Equality; 8079 8080 -- Local variables 8081 8082 Eq_Prim : Entity_Id; 8083 Prim_Elmt : Elmt_Id; 8084 8085 -- Start of processing for Find_Equality 8086 8087 begin 8088 -- Assume that the tagged type lacks an equality 8089 8090 Eq_Prim := Empty; 8091 8092 -- Inspect the list of primitives looking for a suitable equality 8093 -- within a possible chain of aliases. 8094 8095 Prim_Elmt := First_Elmt (Prims); 8096 while Present (Prim_Elmt) and then No (Eq_Prim) loop 8097 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt)); 8098 8099 Next_Elmt (Prim_Elmt); 8100 end loop; 8101 8102 -- A tagged type should always have an equality 8103 8104 pragma Assert (Present (Eq_Prim)); 8105 8106 return Eq_Prim; 8107 end Find_Equality; 8108 8109 ---------------------------------------- 8110 -- User_Defined_Primitive_Equality_Op -- 8111 ---------------------------------------- 8112 8113 function User_Defined_Primitive_Equality_Op 8114 (Typ : Entity_Id) return Entity_Id 8115 is 8116 Enclosing_Scope : constant Node_Id := Scope (Typ); 8117 E : Entity_Id; 8118 begin 8119 -- Prune this search by somehow not looking at decls that precede 8120 -- the declaration of the first view of Typ (which might be a partial 8121 -- view)??? 8122 8123 for Private_Entities in Boolean loop 8124 if Private_Entities then 8125 if Ekind (Enclosing_Scope) /= E_Package then 8126 exit; 8127 end if; 8128 E := First_Private_Entity (Enclosing_Scope); 8129 8130 else 8131 E := First_Entity (Enclosing_Scope); 8132 end if; 8133 8134 while Present (E) loop 8135 if Is_Equality (E, Typ) then 8136 return E; 8137 end if; 8138 Next_Entity (E); 8139 end loop; 8140 end loop; 8141 8142 if Is_Derived_Type (Typ) then 8143 return User_Defined_Primitive_Equality_Op 8144 (Implementation_Base_Type (Etype (Typ))); 8145 end if; 8146 8147 return Empty; 8148 end User_Defined_Primitive_Equality_Op; 8149 8150 ------------------------------------ 8151 -- Has_Unconstrained_UU_Component -- 8152 ------------------------------------ 8153 8154 function Has_Unconstrained_UU_Component 8155 (Typ : Entity_Id) return Boolean 8156 is 8157 Tdef : constant Node_Id := 8158 Type_Definition (Declaration_Node (Base_Type (Typ))); 8159 Clist : Node_Id; 8160 Vpart : Node_Id; 8161 8162 function Component_Is_Unconstrained_UU 8163 (Comp : Node_Id) return Boolean; 8164 -- Determines whether the subtype of the component is an 8165 -- unconstrained Unchecked_Union. 8166 8167 function Variant_Is_Unconstrained_UU 8168 (Variant : Node_Id) return Boolean; 8169 -- Determines whether a component of the variant has an unconstrained 8170 -- Unchecked_Union subtype. 8171 8172 ----------------------------------- 8173 -- Component_Is_Unconstrained_UU -- 8174 ----------------------------------- 8175 8176 function Component_Is_Unconstrained_UU 8177 (Comp : Node_Id) return Boolean 8178 is 8179 begin 8180 if Nkind (Comp) /= N_Component_Declaration then 8181 return False; 8182 end if; 8183 8184 declare 8185 Sindic : constant Node_Id := 8186 Subtype_Indication (Component_Definition (Comp)); 8187 8188 begin 8189 -- Unconstrained nominal type. In the case of a constraint 8190 -- present, the node kind would have been N_Subtype_Indication. 8191 8192 if Nkind (Sindic) = N_Identifier then 8193 return Is_Unchecked_Union (Base_Type (Etype (Sindic))); 8194 end if; 8195 8196 return False; 8197 end; 8198 end Component_Is_Unconstrained_UU; 8199 8200 --------------------------------- 8201 -- Variant_Is_Unconstrained_UU -- 8202 --------------------------------- 8203 8204 function Variant_Is_Unconstrained_UU 8205 (Variant : Node_Id) return Boolean 8206 is 8207 Clist : constant Node_Id := Component_List (Variant); 8208 8209 begin 8210 if Is_Empty_List (Component_Items (Clist)) then 8211 return False; 8212 end if; 8213 8214 -- We only need to test one component 8215 8216 declare 8217 Comp : Node_Id := First (Component_Items (Clist)); 8218 8219 begin 8220 while Present (Comp) loop 8221 if Component_Is_Unconstrained_UU (Comp) then 8222 return True; 8223 end if; 8224 8225 Next (Comp); 8226 end loop; 8227 end; 8228 8229 -- None of the components withing the variant were of 8230 -- unconstrained Unchecked_Union type. 8231 8232 return False; 8233 end Variant_Is_Unconstrained_UU; 8234 8235 -- Start of processing for Has_Unconstrained_UU_Component 8236 8237 begin 8238 if Null_Present (Tdef) then 8239 return False; 8240 end if; 8241 8242 Clist := Component_List (Tdef); 8243 Vpart := Variant_Part (Clist); 8244 8245 -- Inspect available components 8246 8247 if Present (Component_Items (Clist)) then 8248 declare 8249 Comp : Node_Id := First (Component_Items (Clist)); 8250 8251 begin 8252 while Present (Comp) loop 8253 8254 -- One component is sufficient 8255 8256 if Component_Is_Unconstrained_UU (Comp) then 8257 return True; 8258 end if; 8259 8260 Next (Comp); 8261 end loop; 8262 end; 8263 end if; 8264 8265 -- Inspect available components withing variants 8266 8267 if Present (Vpart) then 8268 declare 8269 Variant : Node_Id := First (Variants (Vpart)); 8270 8271 begin 8272 while Present (Variant) loop 8273 8274 -- One component within a variant is sufficient 8275 8276 if Variant_Is_Unconstrained_UU (Variant) then 8277 return True; 8278 end if; 8279 8280 Next (Variant); 8281 end loop; 8282 end; 8283 end if; 8284 8285 -- Neither the available components, nor the components inside the 8286 -- variant parts were of an unconstrained Unchecked_Union subtype. 8287 8288 return False; 8289 end Has_Unconstrained_UU_Component; 8290 8291 -- Local variables 8292 8293 Typl : Entity_Id; 8294 8295 -- Start of processing for Expand_N_Op_Eq 8296 8297 begin 8298 Binary_Op_Validity_Checks (N); 8299 8300 -- Deal with private types 8301 8302 Typl := A_Typ; 8303 8304 if Ekind (Typl) = E_Private_Type then 8305 Typl := Underlying_Type (Typl); 8306 8307 elsif Ekind (Typl) = E_Private_Subtype then 8308 Typl := Underlying_Type (Base_Type (Typl)); 8309 end if; 8310 8311 -- It may happen in error situations that the underlying type is not 8312 -- set. The error will be detected later, here we just defend the 8313 -- expander code. 8314 8315 if No (Typl) then 8316 return; 8317 end if; 8318 8319 -- Now get the implementation base type (note that plain Base_Type here 8320 -- might lead us back to the private type, which is not what we want!) 8321 8322 Typl := Implementation_Base_Type (Typl); 8323 8324 -- Equality between variant records results in a call to a routine 8325 -- that has conditional tests of the discriminant value(s), and hence 8326 -- violates the No_Implicit_Conditionals restriction. 8327 8328 if Has_Variant_Part (Typl) then 8329 declare 8330 Msg : Boolean; 8331 8332 begin 8333 Check_Restriction (Msg, No_Implicit_Conditionals, N); 8334 8335 if Msg then 8336 Error_Msg_N 8337 ("\comparison of variant records tests discriminants", N); 8338 return; 8339 end if; 8340 end; 8341 end if; 8342 8343 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 8344 -- means we no longer have a comparison operation, we are all done. 8345 8346 Expand_Compare_Minimize_Eliminate_Overflow (N); 8347 8348 if Nkind (N) /= N_Op_Eq then 8349 return; 8350 end if; 8351 8352 -- Boolean types (requiring handling of non-standard case) 8353 8354 if Is_Boolean_Type (Typl) then 8355 Adjust_Condition (Left_Opnd (N)); 8356 Adjust_Condition (Right_Opnd (N)); 8357 Set_Etype (N, Standard_Boolean); 8358 Adjust_Result_Type (N, Typ); 8359 8360 -- Array types 8361 8362 elsif Is_Array_Type (Typl) then 8363 8364 -- If we are doing full validity checking, and it is possible for the 8365 -- array elements to be invalid then expand out array comparisons to 8366 -- make sure that we check the array elements. 8367 8368 if Validity_Check_Operands 8369 and then not Is_Known_Valid (Component_Type (Typl)) 8370 then 8371 declare 8372 Save_Force_Validity_Checks : constant Boolean := 8373 Force_Validity_Checks; 8374 begin 8375 Force_Validity_Checks := True; 8376 Rewrite (N, 8377 Expand_Array_Equality 8378 (N, 8379 Relocate_Node (Lhs), 8380 Relocate_Node (Rhs), 8381 Bodies, 8382 Typl)); 8383 Insert_Actions (N, Bodies); 8384 Analyze_And_Resolve (N, Standard_Boolean); 8385 Force_Validity_Checks := Save_Force_Validity_Checks; 8386 end; 8387 8388 -- Packed case where both operands are known aligned 8389 8390 elsif Is_Bit_Packed_Array (Typl) 8391 and then not Is_Possibly_Unaligned_Object (Lhs) 8392 and then not Is_Possibly_Unaligned_Object (Rhs) 8393 then 8394 Expand_Packed_Eq (N); 8395 8396 -- Where the component type is elementary we can use a block bit 8397 -- comparison (if supported on the target) exception in the case 8398 -- of floating-point (negative zero issues require element by 8399 -- element comparison), and full access types (where we must be sure 8400 -- to load elements independently) and possibly unaligned arrays. 8401 8402 elsif Is_Elementary_Type (Component_Type (Typl)) 8403 and then not Is_Floating_Point_Type (Component_Type (Typl)) 8404 and then not Is_Full_Access (Component_Type (Typl)) 8405 and then not Is_Possibly_Unaligned_Object (Lhs) 8406 and then not Is_Possibly_Unaligned_Slice (Lhs) 8407 and then not Is_Possibly_Unaligned_Object (Rhs) 8408 and then not Is_Possibly_Unaligned_Slice (Rhs) 8409 and then Support_Composite_Compare_On_Target 8410 then 8411 null; 8412 8413 -- For composite and floating-point cases, expand equality loop to 8414 -- make sure of using proper comparisons for tagged types, and 8415 -- correctly handling the floating-point case. 8416 8417 else 8418 Rewrite (N, 8419 Expand_Array_Equality 8420 (N, 8421 Relocate_Node (Lhs), 8422 Relocate_Node (Rhs), 8423 Bodies, 8424 Typl)); 8425 Insert_Actions (N, Bodies, Suppress => All_Checks); 8426 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8427 end if; 8428 8429 -- Record Types 8430 8431 elsif Is_Record_Type (Typl) then 8432 8433 -- For tagged types, use the primitive "=" 8434 8435 if Is_Tagged_Type (Typl) then 8436 8437 -- No need to do anything else compiling under restriction 8438 -- No_Dispatching_Calls. During the semantic analysis we 8439 -- already notified such violation. 8440 8441 if Restriction_Active (No_Dispatching_Calls) then 8442 return; 8443 end if; 8444 8445 -- If this is an untagged private type completed with a derivation 8446 -- of an untagged private type whose full view is a tagged type, 8447 -- we use the primitive operations of the private type (since it 8448 -- does not have a full view, and also because its equality 8449 -- primitive may have been overridden in its untagged full view). 8450 8451 if Inherits_From_Tagged_Full_View (A_Typ) then 8452 Build_Equality_Call 8453 (Find_Equality (Collect_Primitive_Operations (A_Typ))); 8454 8455 -- Find the type's predefined equality or an overriding 8456 -- user-defined equality. The reason for not simply calling 8457 -- Find_Prim_Op here is that there may be a user-defined 8458 -- overloaded equality op that precedes the equality that we 8459 -- want, so we have to explicitly search (e.g., there could be 8460 -- an equality with two different parameter types). 8461 8462 else 8463 if Is_Class_Wide_Type (Typl) then 8464 Typl := Find_Specific_Type (Typl); 8465 end if; 8466 8467 Build_Equality_Call 8468 (Find_Equality (Primitive_Operations (Typl))); 8469 end if; 8470 8471 -- See AI12-0101 (which only removes a legality rule) and then 8472 -- AI05-0123 (which then applies in the previously illegal case). 8473 -- AI12-0101 is a binding interpretation. 8474 8475 elsif Ada_Version >= Ada_2012 8476 and then Present (User_Defined_Primitive_Equality_Op (Typl)) 8477 then 8478 Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl)); 8479 8480 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the 8481 -- predefined equality operator for a type which has a subcomponent 8482 -- of an Unchecked_Union type whose nominal subtype is unconstrained. 8483 8484 elsif Has_Unconstrained_UU_Component (Typl) then 8485 Insert_Action (N, 8486 Make_Raise_Program_Error (Loc, 8487 Reason => PE_Unchecked_Union_Restriction)); 8488 8489 -- Prevent Gigi from generating incorrect code by rewriting the 8490 -- equality as a standard False. (is this documented somewhere???) 8491 8492 Rewrite (N, 8493 New_Occurrence_Of (Standard_False, Loc)); 8494 8495 elsif Is_Unchecked_Union (Typl) then 8496 8497 -- If we can infer the discriminants of the operands, we make a 8498 -- call to the TSS equality function. 8499 8500 if Has_Inferable_Discriminants (Lhs) 8501 and then 8502 Has_Inferable_Discriminants (Rhs) 8503 then 8504 Build_Equality_Call 8505 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 8506 8507 else 8508 -- Ada 2005 (AI-216): Program_Error is raised when evaluating 8509 -- the predefined equality operator for an Unchecked_Union type 8510 -- if either of the operands lack inferable discriminants. 8511 8512 Insert_Action (N, 8513 Make_Raise_Program_Error (Loc, 8514 Reason => PE_Unchecked_Union_Restriction)); 8515 8516 -- Emit a warning on source equalities only, otherwise the 8517 -- message may appear out of place due to internal use. The 8518 -- warning is unconditional because it is required by the 8519 -- language. 8520 8521 if Comes_From_Source (N) then 8522 Error_Msg_N 8523 ("Unchecked_Union discriminants cannot be determined??", 8524 N); 8525 Error_Msg_N 8526 ("\Program_Error will be raised for equality operation??", 8527 N); 8528 end if; 8529 8530 -- Prevent Gigi from generating incorrect code by rewriting 8531 -- the equality as a standard False (documented where???). 8532 8533 Rewrite (N, 8534 New_Occurrence_Of (Standard_False, Loc)); 8535 end if; 8536 8537 -- If a type support function is present (for complex cases), use it 8538 8539 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then 8540 Build_Equality_Call 8541 (TSS (Root_Type (Typl), TSS_Composite_Equality)); 8542 8543 -- When comparing two Bounded_Strings, use the primitive equality of 8544 -- the root Super_String type. 8545 8546 elsif Is_Bounded_String (Typl) then 8547 Build_Equality_Call 8548 (Find_Equality 8549 (Collect_Primitive_Operations (Root_Type (Typl)))); 8550 8551 -- Otherwise expand the component by component equality. Note that 8552 -- we never use block-bit comparisons for records, because of the 8553 -- problems with gaps. The back end will often be able to recombine 8554 -- the separate comparisons that we generate here. 8555 8556 else 8557 Remove_Side_Effects (Lhs); 8558 Remove_Side_Effects (Rhs); 8559 Rewrite (N, 8560 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies)); 8561 8562 Insert_Actions (N, Bodies, Suppress => All_Checks); 8563 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8564 end if; 8565 8566 -- If unnesting, handle elementary types whose Equivalent_Types are 8567 -- records because there may be padding or undefined fields. 8568 8569 elsif Unnest_Subprogram_Mode 8570 and then Ekind (Typl) in E_Class_Wide_Type 8571 | E_Class_Wide_Subtype 8572 | E_Access_Subprogram_Type 8573 | E_Access_Protected_Subprogram_Type 8574 | E_Anonymous_Access_Protected_Subprogram_Type 8575 | E_Exception_Type 8576 and then Present (Equivalent_Type (Typl)) 8577 and then Is_Record_Type (Equivalent_Type (Typl)) 8578 then 8579 Typl := Equivalent_Type (Typl); 8580 Remove_Side_Effects (Lhs); 8581 Remove_Side_Effects (Rhs); 8582 Rewrite (N, 8583 Expand_Record_Equality (N, Typl, 8584 Unchecked_Convert_To (Typl, Lhs), 8585 Unchecked_Convert_To (Typl, Rhs), 8586 Bodies)); 8587 8588 Insert_Actions (N, Bodies, Suppress => All_Checks); 8589 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 8590 end if; 8591 8592 -- Test if result is known at compile time 8593 8594 Rewrite_Comparison (N); 8595 8596 -- Try to narrow the operation 8597 8598 if Typl = Universal_Integer and then Nkind (N) = N_Op_Eq then 8599 Narrow_Large_Operation (N); 8600 end if; 8601 8602 -- Special optimization of length comparison 8603 8604 Optimize_Length_Comparison (N); 8605 8606 -- One more special case: if we have a comparison of X'Result = expr 8607 -- in floating-point, then if not already there, change expr to be 8608 -- f'Machine (expr) to eliminate surprise from extra precision. 8609 8610 if Is_Floating_Point_Type (Typl) 8611 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference 8612 and then Attribute_Name (Original_Node (Lhs)) = Name_Result 8613 then 8614 -- Stick in the Typ'Machine call if not already there 8615 8616 if Nkind (Rhs) /= N_Attribute_Reference 8617 or else Attribute_Name (Rhs) /= Name_Machine 8618 then 8619 Rewrite (Rhs, 8620 Make_Attribute_Reference (Loc, 8621 Prefix => New_Occurrence_Of (Typl, Loc), 8622 Attribute_Name => Name_Machine, 8623 Expressions => New_List (Relocate_Node (Rhs)))); 8624 Analyze_And_Resolve (Rhs, Typl); 8625 end if; 8626 end if; 8627 end Expand_N_Op_Eq; 8628 8629 ----------------------- 8630 -- Expand_N_Op_Expon -- 8631 ----------------------- 8632 8633 procedure Expand_N_Op_Expon (N : Node_Id) is 8634 Loc : constant Source_Ptr := Sloc (N); 8635 Ovflo : constant Boolean := Do_Overflow_Check (N); 8636 Typ : constant Entity_Id := Etype (N); 8637 Rtyp : constant Entity_Id := Root_Type (Typ); 8638 8639 Bastyp : Entity_Id; 8640 8641 function Wrap_MA (Exp : Node_Id) return Node_Id; 8642 -- Given an expression Exp, if the root type is Float or Long_Float, 8643 -- then wrap the expression in a call of Bastyp'Machine, to stop any 8644 -- extra precision. This is done to ensure that X**A = X**B when A is 8645 -- a static constant and B is a variable with the same value. For any 8646 -- other type, the node Exp is returned unchanged. 8647 8648 ------------- 8649 -- Wrap_MA -- 8650 ------------- 8651 8652 function Wrap_MA (Exp : Node_Id) return Node_Id is 8653 Loc : constant Source_Ptr := Sloc (Exp); 8654 8655 begin 8656 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then 8657 return 8658 Make_Attribute_Reference (Loc, 8659 Attribute_Name => Name_Machine, 8660 Prefix => New_Occurrence_Of (Bastyp, Loc), 8661 Expressions => New_List (Relocate_Node (Exp))); 8662 else 8663 return Exp; 8664 end if; 8665 end Wrap_MA; 8666 8667 -- Local variables 8668 8669 Base : Node_Id; 8670 Ent : Entity_Id; 8671 Etyp : Entity_Id; 8672 Exp : Node_Id; 8673 Exptyp : Entity_Id; 8674 Expv : Uint; 8675 Rent : RE_Id; 8676 Temp : Node_Id; 8677 Xnode : Node_Id; 8678 8679 -- Start of processing for Expand_N_Op_Expon 8680 8681 begin 8682 Binary_Op_Validity_Checks (N); 8683 8684 -- CodePeer wants to see the unexpanded N_Op_Expon node 8685 8686 if CodePeer_Mode then 8687 return; 8688 end if; 8689 8690 -- Relocation of left and right operands must be done after performing 8691 -- the validity checks since the generation of validation checks may 8692 -- remove side effects. 8693 8694 Base := Relocate_Node (Left_Opnd (N)); 8695 Bastyp := Etype (Base); 8696 Exp := Relocate_Node (Right_Opnd (N)); 8697 Exptyp := Etype (Exp); 8698 8699 -- If either operand is of a private type, then we have the use of an 8700 -- intrinsic operator, and we get rid of the privateness, by using root 8701 -- types of underlying types for the actual operation. Otherwise the 8702 -- private types will cause trouble if we expand multiplications or 8703 -- shifts etc. We also do this transformation if the result type is 8704 -- different from the base type. 8705 8706 if Is_Private_Type (Etype (Base)) 8707 or else Is_Private_Type (Typ) 8708 or else Is_Private_Type (Exptyp) 8709 or else Rtyp /= Root_Type (Bastyp) 8710 then 8711 declare 8712 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); 8713 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); 8714 begin 8715 Rewrite (N, 8716 Unchecked_Convert_To (Typ, 8717 Make_Op_Expon (Loc, 8718 Left_Opnd => Unchecked_Convert_To (Bt, Base), 8719 Right_Opnd => Unchecked_Convert_To (Et, Exp)))); 8720 Analyze_And_Resolve (N, Typ); 8721 return; 8722 end; 8723 end if; 8724 8725 -- Check for MINIMIZED/ELIMINATED overflow mode 8726 8727 if Minimized_Eliminated_Overflow_Check (N) then 8728 Apply_Arithmetic_Overflow_Check (N); 8729 return; 8730 end if; 8731 8732 -- Test for case of known right argument where we can replace the 8733 -- exponentiation by an equivalent expression using multiplication. 8734 8735 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in 8736 -- configurable run-time mode, we may not have the exponentiation 8737 -- routine available, and we don't want the legality of the program 8738 -- to depend on how clever the compiler is in knowing values. 8739 8740 if CRT_Safe_Compile_Time_Known_Value (Exp) then 8741 Expv := Expr_Value (Exp); 8742 8743 -- We only fold small non-negative exponents. You might think we 8744 -- could fold small negative exponents for the real case, but we 8745 -- can't because we are required to raise Constraint_Error for 8746 -- the case of 0.0 ** (negative) even if Machine_Overflows = False. 8747 -- See ACVC test C4A012B, and it is not worth generating the test. 8748 8749 -- For small negative exponents, we return the reciprocal of 8750 -- the folding of the exponentiation for the opposite (positive) 8751 -- exponent, as required by Ada RM 4.5.6(11/3). 8752 8753 if abs Expv <= 4 then 8754 8755 -- X ** 0 = 1 (or 1.0) 8756 8757 if Expv = 0 then 8758 8759 -- Call Remove_Side_Effects to ensure that any side effects 8760 -- in the ignored left operand (in particular function calls 8761 -- to user defined functions) are properly executed. 8762 8763 Remove_Side_Effects (Base); 8764 8765 if Ekind (Typ) in Integer_Kind then 8766 Xnode := Make_Integer_Literal (Loc, Intval => 1); 8767 else 8768 Xnode := Make_Real_Literal (Loc, Ureal_1); 8769 end if; 8770 8771 -- X ** 1 = X 8772 8773 elsif Expv = 1 then 8774 Xnode := Base; 8775 8776 -- X ** 2 = X * X 8777 8778 elsif Expv = 2 then 8779 Xnode := 8780 Wrap_MA ( 8781 Make_Op_Multiply (Loc, 8782 Left_Opnd => Duplicate_Subexpr (Base), 8783 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))); 8784 8785 -- X ** 3 = X * X * X 8786 8787 elsif Expv = 3 then 8788 Xnode := 8789 Wrap_MA ( 8790 Make_Op_Multiply (Loc, 8791 Left_Opnd => 8792 Make_Op_Multiply (Loc, 8793 Left_Opnd => Duplicate_Subexpr (Base), 8794 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)), 8795 Right_Opnd => Duplicate_Subexpr_No_Checks (Base))); 8796 8797 -- X ** 4 -> 8798 8799 -- do 8800 -- En : constant base'type := base * base; 8801 -- in 8802 -- En * En 8803 8804 elsif Expv = 4 then 8805 Temp := Make_Temporary (Loc, 'E', Base); 8806 8807 Xnode := 8808 Make_Expression_With_Actions (Loc, 8809 Actions => New_List ( 8810 Make_Object_Declaration (Loc, 8811 Defining_Identifier => Temp, 8812 Constant_Present => True, 8813 Object_Definition => New_Occurrence_Of (Typ, Loc), 8814 Expression => 8815 Wrap_MA ( 8816 Make_Op_Multiply (Loc, 8817 Left_Opnd => 8818 Duplicate_Subexpr (Base), 8819 Right_Opnd => 8820 Duplicate_Subexpr_No_Checks (Base))))), 8821 8822 Expression => 8823 Wrap_MA ( 8824 Make_Op_Multiply (Loc, 8825 Left_Opnd => New_Occurrence_Of (Temp, Loc), 8826 Right_Opnd => New_Occurrence_Of (Temp, Loc)))); 8827 8828 -- X ** N = 1.0 / X ** (-N) 8829 -- N in -4 .. -1 8830 8831 else 8832 pragma Assert 8833 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4); 8834 8835 Xnode := 8836 Make_Op_Divide (Loc, 8837 Left_Opnd => 8838 Make_Float_Literal (Loc, 8839 Radix => Uint_1, 8840 Significand => Uint_1, 8841 Exponent => Uint_0), 8842 Right_Opnd => 8843 Make_Op_Expon (Loc, 8844 Left_Opnd => Duplicate_Subexpr (Base), 8845 Right_Opnd => 8846 Make_Integer_Literal (Loc, 8847 Intval => -Expv))); 8848 end if; 8849 8850 Rewrite (N, Xnode); 8851 Analyze_And_Resolve (N, Typ); 8852 return; 8853 end if; 8854 end if; 8855 8856 -- Deal with optimizing 2 ** expression to shift where possible 8857 8858 -- Note: we used to check that Exptyp was an unsigned type. But that is 8859 -- an unnecessary check, since if Exp is negative, we have a run-time 8860 -- error that is either caught (so we get the right result) or we have 8861 -- suppressed the check, in which case the code is erroneous anyway. 8862 8863 if Is_Integer_Type (Rtyp) 8864 8865 -- The base value must be "safe compile-time known", and exactly 2 8866 8867 and then Nkind (Base) = N_Integer_Literal 8868 and then CRT_Safe_Compile_Time_Known_Value (Base) 8869 and then Expr_Value (Base) = Uint_2 8870 8871 -- We only handle cases where the right type is a integer 8872 8873 and then Is_Integer_Type (Root_Type (Exptyp)) 8874 and then Esize (Root_Type (Exptyp)) <= Standard_Integer_Size 8875 8876 -- This transformation is not applicable for a modular type with a 8877 -- nonbinary modulus because we do not handle modular reduction in 8878 -- a correct manner if we attempt this transformation in this case. 8879 8880 and then not Non_Binary_Modulus (Typ) 8881 then 8882 -- Handle the cases where our parent is a division or multiplication 8883 -- specially. In these cases we can convert to using a shift at the 8884 -- parent level if we are not doing overflow checking, since it is 8885 -- too tricky to combine the overflow check at the parent level. 8886 8887 if not Ovflo 8888 and then Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply 8889 then 8890 declare 8891 P : constant Node_Id := Parent (N); 8892 L : constant Node_Id := Left_Opnd (P); 8893 R : constant Node_Id := Right_Opnd (P); 8894 8895 begin 8896 if (Nkind (P) = N_Op_Multiply 8897 and then 8898 ((Is_Integer_Type (Etype (L)) and then R = N) 8899 or else 8900 (Is_Integer_Type (Etype (R)) and then L = N)) 8901 and then not Do_Overflow_Check (P)) 8902 8903 or else 8904 (Nkind (P) = N_Op_Divide 8905 and then Is_Integer_Type (Etype (L)) 8906 and then Is_Unsigned_Type (Etype (L)) 8907 and then R = N 8908 and then not Do_Overflow_Check (P)) 8909 then 8910 Set_Is_Power_Of_2_For_Shift (N); 8911 return; 8912 end if; 8913 end; 8914 8915 -- Here we just have 2 ** N on its own, so we can convert this to a 8916 -- shift node. We are prepared to deal with overflow here, and we 8917 -- also have to handle proper modular reduction for binary modular. 8918 8919 else 8920 declare 8921 OK : Boolean; 8922 Lo : Uint; 8923 Hi : Uint; 8924 8925 MaxS : Uint; 8926 -- Maximum shift count with no overflow 8927 8928 TestS : Boolean; 8929 -- Set True if we must test the shift count 8930 8931 Test_Gt : Node_Id; 8932 -- Node for test against TestS 8933 8934 begin 8935 -- Compute maximum shift based on the underlying size. For a 8936 -- modular type this is one less than the size. 8937 8938 if Is_Modular_Integer_Type (Typ) then 8939 8940 -- For modular integer types, this is the size of the value 8941 -- being shifted minus one. Any larger values will cause 8942 -- modular reduction to a result of zero. Note that we do 8943 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result 8944 -- of 6, since 2**7 should be reduced to zero). 8945 8946 MaxS := RM_Size (Rtyp) - 1; 8947 8948 -- For signed integer types, we use the size of the value 8949 -- being shifted minus 2. Larger values cause overflow. 8950 8951 else 8952 MaxS := Esize (Rtyp) - 2; 8953 end if; 8954 8955 -- Determine range to see if it can be larger than MaxS 8956 8957 Determine_Range (Exp, OK, Lo, Hi, Assume_Valid => True); 8958 TestS := (not OK) or else Hi > MaxS; 8959 8960 -- Signed integer case 8961 8962 if Is_Signed_Integer_Type (Typ) then 8963 8964 -- Generate overflow check if overflow is active. Note that 8965 -- we can simply ignore the possibility of overflow if the 8966 -- flag is not set (means that overflow cannot happen or 8967 -- that overflow checks are suppressed). 8968 8969 if Ovflo and TestS then 8970 Insert_Action (N, 8971 Make_Raise_Constraint_Error (Loc, 8972 Condition => 8973 Make_Op_Gt (Loc, 8974 Left_Opnd => Duplicate_Subexpr (Exp), 8975 Right_Opnd => Make_Integer_Literal (Loc, MaxS)), 8976 Reason => CE_Overflow_Check_Failed)); 8977 end if; 8978 8979 -- Now rewrite node as Shift_Left (1, right-operand) 8980 8981 Rewrite (N, 8982 Make_Op_Shift_Left (Loc, 8983 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 8984 Right_Opnd => Exp)); 8985 8986 -- Modular integer case 8987 8988 else pragma Assert (Is_Modular_Integer_Type (Typ)); 8989 8990 -- If shift count can be greater than MaxS, we need to wrap 8991 -- the shift in a test that will reduce the result value to 8992 -- zero if this shift count is exceeded. 8993 8994 if TestS then 8995 8996 -- Note: build node for the comparison first, before we 8997 -- reuse the Right_Opnd, so that we have proper parents 8998 -- in place for the Duplicate_Subexpr call. 8999 9000 Test_Gt := 9001 Make_Op_Gt (Loc, 9002 Left_Opnd => Duplicate_Subexpr (Exp), 9003 Right_Opnd => Make_Integer_Literal (Loc, MaxS)); 9004 9005 Rewrite (N, 9006 Make_If_Expression (Loc, 9007 Expressions => New_List ( 9008 Test_Gt, 9009 Make_Integer_Literal (Loc, Uint_0), 9010 Make_Op_Shift_Left (Loc, 9011 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 9012 Right_Opnd => Exp)))); 9013 9014 -- If we know shift count cannot be greater than MaxS, then 9015 -- it is safe to just rewrite as a shift with no test. 9016 9017 else 9018 Rewrite (N, 9019 Make_Op_Shift_Left (Loc, 9020 Left_Opnd => Make_Integer_Literal (Loc, Uint_1), 9021 Right_Opnd => Exp)); 9022 end if; 9023 end if; 9024 9025 Analyze_And_Resolve (N, Typ); 9026 return; 9027 end; 9028 end if; 9029 end if; 9030 9031 -- Fall through if exponentiation must be done using a runtime routine 9032 9033 -- First deal with modular case 9034 9035 if Is_Modular_Integer_Type (Rtyp) then 9036 9037 -- Nonbinary modular case, we call the special exponentiation 9038 -- routine for the nonbinary case, converting the argument to 9039 -- Long_Long_Integer and passing the modulus value. Then the 9040 -- result is converted back to the base type. 9041 9042 if Non_Binary_Modulus (Rtyp) then 9043 Rewrite (N, 9044 Convert_To (Typ, 9045 Make_Function_Call (Loc, 9046 Name => 9047 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc), 9048 Parameter_Associations => New_List ( 9049 Convert_To (RTE (RE_Unsigned), Base), 9050 Make_Integer_Literal (Loc, Modulus (Rtyp)), 9051 Exp)))); 9052 9053 -- Binary modular case, in this case, we call one of three routines, 9054 -- either the unsigned integer case, or the unsigned long long 9055 -- integer case, or the unsigned long long long integer case, with a 9056 -- final "and" operation to do the required mod. 9057 9058 else 9059 if Esize (Rtyp) <= Standard_Integer_Size then 9060 Ent := RTE (RE_Exp_Unsigned); 9061 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then 9062 Ent := RTE (RE_Exp_Long_Long_Unsigned); 9063 else 9064 Ent := RTE (RE_Exp_Long_Long_Long_Unsigned); 9065 end if; 9066 9067 Rewrite (N, 9068 Convert_To (Typ, 9069 Make_Op_And (Loc, 9070 Left_Opnd => 9071 Make_Function_Call (Loc, 9072 Name => New_Occurrence_Of (Ent, Loc), 9073 Parameter_Associations => New_List ( 9074 Convert_To (Etype (First_Formal (Ent)), Base), 9075 Exp)), 9076 Right_Opnd => 9077 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1)))); 9078 9079 end if; 9080 9081 -- Common exit point for modular type case 9082 9083 Analyze_And_Resolve (N, Typ); 9084 return; 9085 9086 -- Signed integer cases, using either Integer, Long_Long_Integer or 9087 -- Long_Long_Long_Integer. It is not worth also having routines for 9088 -- Short_[Short_]Integer, since for most machines it would not help, 9089 -- and it would generate more code that might need certification when 9090 -- a certified run time is required. 9091 9092 -- In the integer cases, we have two routines, one for when overflow 9093 -- checks are required, and one when they are not required, since there 9094 -- is a real gain in omitting checks on many machines. 9095 9096 elsif Is_Signed_Integer_Type (Rtyp) then 9097 if Esize (Rtyp) <= Standard_Integer_Size then 9098 Etyp := Standard_Integer; 9099 9100 if Ovflo then 9101 Rent := RE_Exp_Integer; 9102 else 9103 Rent := RE_Exn_Integer; 9104 end if; 9105 9106 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then 9107 Etyp := Standard_Long_Long_Integer; 9108 9109 if Ovflo then 9110 Rent := RE_Exp_Long_Long_Integer; 9111 else 9112 Rent := RE_Exn_Long_Long_Integer; 9113 end if; 9114 9115 else 9116 Etyp := Standard_Long_Long_Long_Integer; 9117 9118 if Ovflo then 9119 Rent := RE_Exp_Long_Long_Long_Integer; 9120 else 9121 Rent := RE_Exn_Long_Long_Long_Integer; 9122 end if; 9123 end if; 9124 9125 -- Floating-point cases. We do not need separate routines for the 9126 -- overflow case here, since in the case of floating-point, we generate 9127 -- infinities anyway as a rule (either that or we automatically trap 9128 -- overflow), and if there is an infinity generated and a range check 9129 -- is required, the check will fail anyway. 9130 9131 -- Historical note: we used to convert everything to Long_Long_Float 9132 -- and call a single common routine, but this had the undesirable effect 9133 -- of giving different results for small static exponent values and the 9134 -- same dynamic values. 9135 9136 else 9137 pragma Assert (Is_Floating_Point_Type (Rtyp)); 9138 9139 if Rtyp = Standard_Float then 9140 Etyp := Standard_Float; 9141 Rent := RE_Exn_Float; 9142 9143 elsif Rtyp = Standard_Long_Float then 9144 Etyp := Standard_Long_Float; 9145 Rent := RE_Exn_Long_Float; 9146 9147 else 9148 Etyp := Standard_Long_Long_Float; 9149 Rent := RE_Exn_Long_Long_Float; 9150 end if; 9151 end if; 9152 9153 -- Common processing for integer cases and floating-point cases. 9154 -- If we are in the right type, we can call runtime routine directly 9155 9156 if Typ = Etyp 9157 and then Rtyp /= Universal_Integer 9158 and then Rtyp /= Universal_Real 9159 then 9160 Rewrite (N, 9161 Wrap_MA ( 9162 Make_Function_Call (Loc, 9163 Name => New_Occurrence_Of (RTE (Rent), Loc), 9164 Parameter_Associations => New_List (Base, Exp)))); 9165 9166 -- Otherwise we have to introduce conversions (conversions are also 9167 -- required in the universal cases, since the runtime routine is 9168 -- typed using one of the standard types). 9169 9170 else 9171 Rewrite (N, 9172 Convert_To (Typ, 9173 Make_Function_Call (Loc, 9174 Name => New_Occurrence_Of (RTE (Rent), Loc), 9175 Parameter_Associations => New_List ( 9176 Convert_To (Etyp, Base), 9177 Exp)))); 9178 end if; 9179 9180 Analyze_And_Resolve (N, Typ); 9181 return; 9182 9183 exception 9184 when RE_Not_Available => 9185 return; 9186 end Expand_N_Op_Expon; 9187 9188 -------------------- 9189 -- Expand_N_Op_Ge -- 9190 -------------------- 9191 9192 procedure Expand_N_Op_Ge (N : Node_Id) is 9193 Typ : constant Entity_Id := Etype (N); 9194 Op1 : constant Node_Id := Left_Opnd (N); 9195 Op2 : constant Node_Id := Right_Opnd (N); 9196 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9197 9198 begin 9199 Binary_Op_Validity_Checks (N); 9200 9201 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9202 -- means we no longer have a comparison operation, we are all done. 9203 9204 Expand_Compare_Minimize_Eliminate_Overflow (N); 9205 9206 if Nkind (N) /= N_Op_Ge then 9207 return; 9208 end if; 9209 9210 -- Array type case 9211 9212 if Is_Array_Type (Typ1) then 9213 Expand_Array_Comparison (N); 9214 return; 9215 end if; 9216 9217 -- Deal with boolean operands 9218 9219 if Is_Boolean_Type (Typ1) then 9220 Adjust_Condition (Op1); 9221 Adjust_Condition (Op2); 9222 Set_Etype (N, Standard_Boolean); 9223 Adjust_Result_Type (N, Typ); 9224 end if; 9225 9226 Rewrite_Comparison (N); 9227 9228 -- Try to narrow the operation 9229 9230 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Ge then 9231 Narrow_Large_Operation (N); 9232 end if; 9233 9234 Optimize_Length_Comparison (N); 9235 end Expand_N_Op_Ge; 9236 9237 -------------------- 9238 -- Expand_N_Op_Gt -- 9239 -------------------- 9240 9241 procedure Expand_N_Op_Gt (N : Node_Id) is 9242 Typ : constant Entity_Id := Etype (N); 9243 Op1 : constant Node_Id := Left_Opnd (N); 9244 Op2 : constant Node_Id := Right_Opnd (N); 9245 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9246 9247 begin 9248 Binary_Op_Validity_Checks (N); 9249 9250 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9251 -- means we no longer have a comparison operation, we are all done. 9252 9253 Expand_Compare_Minimize_Eliminate_Overflow (N); 9254 9255 if Nkind (N) /= N_Op_Gt then 9256 return; 9257 end if; 9258 9259 -- Deal with array type operands 9260 9261 if Is_Array_Type (Typ1) then 9262 Expand_Array_Comparison (N); 9263 return; 9264 end if; 9265 9266 -- Deal with boolean type operands 9267 9268 if Is_Boolean_Type (Typ1) then 9269 Adjust_Condition (Op1); 9270 Adjust_Condition (Op2); 9271 Set_Etype (N, Standard_Boolean); 9272 Adjust_Result_Type (N, Typ); 9273 end if; 9274 9275 Rewrite_Comparison (N); 9276 9277 -- Try to narrow the operation 9278 9279 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Gt then 9280 Narrow_Large_Operation (N); 9281 end if; 9282 9283 Optimize_Length_Comparison (N); 9284 end Expand_N_Op_Gt; 9285 9286 -------------------- 9287 -- Expand_N_Op_Le -- 9288 -------------------- 9289 9290 procedure Expand_N_Op_Le (N : Node_Id) is 9291 Typ : constant Entity_Id := Etype (N); 9292 Op1 : constant Node_Id := Left_Opnd (N); 9293 Op2 : constant Node_Id := Right_Opnd (N); 9294 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9295 9296 begin 9297 Binary_Op_Validity_Checks (N); 9298 9299 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9300 -- means we no longer have a comparison operation, we are all done. 9301 9302 Expand_Compare_Minimize_Eliminate_Overflow (N); 9303 9304 if Nkind (N) /= N_Op_Le then 9305 return; 9306 end if; 9307 9308 -- Deal with array type operands 9309 9310 if Is_Array_Type (Typ1) then 9311 Expand_Array_Comparison (N); 9312 return; 9313 end if; 9314 9315 -- Deal with Boolean type operands 9316 9317 if Is_Boolean_Type (Typ1) then 9318 Adjust_Condition (Op1); 9319 Adjust_Condition (Op2); 9320 Set_Etype (N, Standard_Boolean); 9321 Adjust_Result_Type (N, Typ); 9322 end if; 9323 9324 Rewrite_Comparison (N); 9325 9326 -- Try to narrow the operation 9327 9328 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Le then 9329 Narrow_Large_Operation (N); 9330 end if; 9331 9332 Optimize_Length_Comparison (N); 9333 end Expand_N_Op_Le; 9334 9335 -------------------- 9336 -- Expand_N_Op_Lt -- 9337 -------------------- 9338 9339 procedure Expand_N_Op_Lt (N : Node_Id) is 9340 Typ : constant Entity_Id := Etype (N); 9341 Op1 : constant Node_Id := Left_Opnd (N); 9342 Op2 : constant Node_Id := Right_Opnd (N); 9343 Typ1 : constant Entity_Id := Base_Type (Etype (Op1)); 9344 9345 begin 9346 Binary_Op_Validity_Checks (N); 9347 9348 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that 9349 -- means we no longer have a comparison operation, we are all done. 9350 9351 Expand_Compare_Minimize_Eliminate_Overflow (N); 9352 9353 if Nkind (N) /= N_Op_Lt then 9354 return; 9355 end if; 9356 9357 -- Deal with array type operands 9358 9359 if Is_Array_Type (Typ1) then 9360 Expand_Array_Comparison (N); 9361 return; 9362 end if; 9363 9364 -- Deal with Boolean type operands 9365 9366 if Is_Boolean_Type (Typ1) then 9367 Adjust_Condition (Op1); 9368 Adjust_Condition (Op2); 9369 Set_Etype (N, Standard_Boolean); 9370 Adjust_Result_Type (N, Typ); 9371 end if; 9372 9373 Rewrite_Comparison (N); 9374 9375 -- Try to narrow the operation 9376 9377 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Lt then 9378 Narrow_Large_Operation (N); 9379 end if; 9380 9381 Optimize_Length_Comparison (N); 9382 end Expand_N_Op_Lt; 9383 9384 ----------------------- 9385 -- Expand_N_Op_Minus -- 9386 ----------------------- 9387 9388 procedure Expand_N_Op_Minus (N : Node_Id) is 9389 Loc : constant Source_Ptr := Sloc (N); 9390 Typ : constant Entity_Id := Etype (N); 9391 9392 begin 9393 Unary_Op_Validity_Checks (N); 9394 9395 -- Check for MINIMIZED/ELIMINATED overflow mode 9396 9397 if Minimized_Eliminated_Overflow_Check (N) then 9398 Apply_Arithmetic_Overflow_Check (N); 9399 return; 9400 end if; 9401 9402 -- Try to narrow the operation 9403 9404 if Typ = Universal_Integer then 9405 Narrow_Large_Operation (N); 9406 9407 if Nkind (N) /= N_Op_Minus then 9408 return; 9409 end if; 9410 end if; 9411 9412 if not Backend_Overflow_Checks_On_Target 9413 and then Is_Signed_Integer_Type (Typ) 9414 and then Do_Overflow_Check (N) 9415 then 9416 -- Software overflow checking expands -expr into (0 - expr) 9417 9418 Rewrite (N, 9419 Make_Op_Subtract (Loc, 9420 Left_Opnd => Make_Integer_Literal (Loc, 0), 9421 Right_Opnd => Right_Opnd (N))); 9422 9423 Analyze_And_Resolve (N, Typ); 9424 end if; 9425 9426 Expand_Nonbinary_Modular_Op (N); 9427 end Expand_N_Op_Minus; 9428 9429 --------------------- 9430 -- Expand_N_Op_Mod -- 9431 --------------------- 9432 9433 procedure Expand_N_Op_Mod (N : Node_Id) is 9434 Loc : constant Source_Ptr := Sloc (N); 9435 Typ : constant Entity_Id := Etype (N); 9436 DDC : constant Boolean := Do_Division_Check (N); 9437 9438 Left : Node_Id; 9439 Right : Node_Id; 9440 9441 LLB : Uint; 9442 Llo : Uint; 9443 Lhi : Uint; 9444 LOK : Boolean; 9445 Rlo : Uint; 9446 Rhi : Uint; 9447 ROK : Boolean; 9448 9449 pragma Warnings (Off, Lhi); 9450 9451 begin 9452 Binary_Op_Validity_Checks (N); 9453 9454 -- Check for MINIMIZED/ELIMINATED overflow mode 9455 9456 if Minimized_Eliminated_Overflow_Check (N) then 9457 Apply_Arithmetic_Overflow_Check (N); 9458 return; 9459 end if; 9460 9461 -- Try to narrow the operation 9462 9463 if Typ = Universal_Integer then 9464 Narrow_Large_Operation (N); 9465 9466 if Nkind (N) /= N_Op_Mod then 9467 return; 9468 end if; 9469 end if; 9470 9471 if Is_Integer_Type (Typ) then 9472 Apply_Divide_Checks (N); 9473 9474 -- All done if we don't have a MOD any more, which can happen as a 9475 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 9476 9477 if Nkind (N) /= N_Op_Mod then 9478 return; 9479 end if; 9480 end if; 9481 9482 -- Proceed with expansion of mod operator 9483 9484 Left := Left_Opnd (N); 9485 Right := Right_Opnd (N); 9486 9487 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); 9488 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); 9489 9490 -- Convert mod to rem if operands are both known to be non-negative, or 9491 -- both known to be non-positive (these are the cases in which rem and 9492 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite 9493 -- likely that this will improve the quality of code, (the operation now 9494 -- corresponds to the hardware remainder), and it does not seem likely 9495 -- that it could be harmful. It also avoids some cases of the elaborate 9496 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %). 9497 9498 if (LOK and ROK) 9499 and then ((Llo >= 0 and then Rlo >= 0) 9500 or else 9501 (Lhi <= 0 and then Rhi <= 0)) 9502 then 9503 Rewrite (N, 9504 Make_Op_Rem (Sloc (N), 9505 Left_Opnd => Left_Opnd (N), 9506 Right_Opnd => Right_Opnd (N))); 9507 9508 -- Instead of reanalyzing the node we do the analysis manually. This 9509 -- avoids anomalies when the replacement is done in an instance and 9510 -- is epsilon more efficient. 9511 9512 Set_Entity (N, Standard_Entity (S_Op_Rem)); 9513 Set_Etype (N, Typ); 9514 Set_Do_Division_Check (N, DDC); 9515 Expand_N_Op_Rem (N); 9516 Set_Analyzed (N); 9517 return; 9518 9519 -- Otherwise, normal mod processing 9520 9521 else 9522 -- Apply optimization x mod 1 = 0. We don't really need that with 9523 -- gcc, but it is useful with other back ends and is certainly 9524 -- harmless. 9525 9526 if Is_Integer_Type (Etype (N)) 9527 and then Compile_Time_Known_Value (Right) 9528 and then Expr_Value (Right) = Uint_1 9529 then 9530 -- Call Remove_Side_Effects to ensure that any side effects in 9531 -- the ignored left operand (in particular function calls to 9532 -- user defined functions) are properly executed. 9533 9534 Remove_Side_Effects (Left); 9535 9536 Rewrite (N, Make_Integer_Literal (Loc, 0)); 9537 Analyze_And_Resolve (N, Typ); 9538 return; 9539 end if; 9540 9541 -- If we still have a mod operator and we are in Modify_Tree_For_C 9542 -- mode, and we have a signed integer type, then here is where we do 9543 -- the rewrite in terms of Rem. Note this rewrite bypasses the need 9544 -- for the special handling of the annoying case of largest negative 9545 -- number mod minus one. 9546 9547 if Nkind (N) = N_Op_Mod 9548 and then Is_Signed_Integer_Type (Typ) 9549 and then Modify_Tree_For_C 9550 then 9551 -- In the general case, we expand A mod B as 9552 9553 -- Tnn : constant typ := A rem B; 9554 -- .. 9555 -- (if (A >= 0) = (B >= 0) then Tnn 9556 -- elsif Tnn = 0 then 0 9557 -- else Tnn + B) 9558 9559 -- The comparison can be written simply as A >= 0 if we know that 9560 -- B >= 0 which is a very common case. 9561 9562 -- An important optimization is when B is known at compile time 9563 -- to be 2**K for some constant. In this case we can simply AND 9564 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits) 9565 -- and that works for both the positive and negative cases. 9566 9567 declare 9568 P2 : constant Nat := Power_Of_Two (Right); 9569 9570 begin 9571 if P2 /= 0 then 9572 Rewrite (N, 9573 Unchecked_Convert_To (Typ, 9574 Make_Op_And (Loc, 9575 Left_Opnd => 9576 Unchecked_Convert_To 9577 (Corresponding_Unsigned_Type (Typ), Left), 9578 Right_Opnd => 9579 Make_Integer_Literal (Loc, 2 ** P2 - 1)))); 9580 Analyze_And_Resolve (N, Typ); 9581 return; 9582 end if; 9583 end; 9584 9585 -- Here for the full rewrite 9586 9587 declare 9588 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N); 9589 Cmp : Node_Id; 9590 9591 begin 9592 Cmp := 9593 Make_Op_Ge (Loc, 9594 Left_Opnd => Duplicate_Subexpr_No_Checks (Left), 9595 Right_Opnd => Make_Integer_Literal (Loc, 0)); 9596 9597 if not LOK or else Rlo < 0 then 9598 Cmp := 9599 Make_Op_Eq (Loc, 9600 Left_Opnd => Cmp, 9601 Right_Opnd => 9602 Make_Op_Ge (Loc, 9603 Left_Opnd => Duplicate_Subexpr_No_Checks (Right), 9604 Right_Opnd => Make_Integer_Literal (Loc, 0))); 9605 end if; 9606 9607 Insert_Action (N, 9608 Make_Object_Declaration (Loc, 9609 Defining_Identifier => Tnn, 9610 Constant_Present => True, 9611 Object_Definition => New_Occurrence_Of (Typ, Loc), 9612 Expression => 9613 Make_Op_Rem (Loc, 9614 Left_Opnd => Left, 9615 Right_Opnd => Right))); 9616 9617 Rewrite (N, 9618 Make_If_Expression (Loc, 9619 Expressions => New_List ( 9620 Cmp, 9621 New_Occurrence_Of (Tnn, Loc), 9622 Make_If_Expression (Loc, 9623 Is_Elsif => True, 9624 Expressions => New_List ( 9625 Make_Op_Eq (Loc, 9626 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 9627 Right_Opnd => Make_Integer_Literal (Loc, 0)), 9628 Make_Integer_Literal (Loc, 0), 9629 Make_Op_Add (Loc, 9630 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 9631 Right_Opnd => 9632 Duplicate_Subexpr_No_Checks (Right))))))); 9633 9634 Analyze_And_Resolve (N, Typ); 9635 return; 9636 end; 9637 end if; 9638 9639 -- Deal with annoying case of largest negative number mod minus one. 9640 -- Gigi may not handle this case correctly, because on some targets, 9641 -- the mod value is computed using a divide instruction which gives 9642 -- an overflow trap for this case. 9643 9644 -- It would be a bit more efficient to figure out which targets 9645 -- this is really needed for, but in practice it is reasonable 9646 -- to do the following special check in all cases, since it means 9647 -- we get a clearer message, and also the overhead is minimal given 9648 -- that division is expensive in any case. 9649 9650 -- In fact the check is quite easy, if the right operand is -1, then 9651 -- the mod value is always 0, and we can just ignore the left operand 9652 -- completely in this case. 9653 9654 -- This only applies if we still have a mod operator. Skip if we 9655 -- have already rewritten this (e.g. in the case of eliminated 9656 -- overflow checks which have driven us into bignum mode). 9657 9658 if Nkind (N) = N_Op_Mod then 9659 9660 -- The operand type may be private (e.g. in the expansion of an 9661 -- intrinsic operation) so we must use the underlying type to get 9662 -- the bounds, and convert the literals explicitly. 9663 9664 LLB := 9665 Expr_Value 9666 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); 9667 9668 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 9669 and then ((not LOK) or else (Llo = LLB)) 9670 then 9671 Rewrite (N, 9672 Make_If_Expression (Loc, 9673 Expressions => New_List ( 9674 Make_Op_Eq (Loc, 9675 Left_Opnd => Duplicate_Subexpr (Right), 9676 Right_Opnd => 9677 Unchecked_Convert_To (Typ, 9678 Make_Integer_Literal (Loc, -1))), 9679 Unchecked_Convert_To (Typ, 9680 Make_Integer_Literal (Loc, Uint_0)), 9681 Relocate_Node (N)))); 9682 9683 Set_Analyzed (Next (Next (First (Expressions (N))))); 9684 Analyze_And_Resolve (N, Typ); 9685 end if; 9686 end if; 9687 end if; 9688 end Expand_N_Op_Mod; 9689 9690 -------------------------- 9691 -- Expand_N_Op_Multiply -- 9692 -------------------------- 9693 9694 procedure Expand_N_Op_Multiply (N : Node_Id) is 9695 Loc : constant Source_Ptr := Sloc (N); 9696 Lop : constant Node_Id := Left_Opnd (N); 9697 Rop : constant Node_Id := Right_Opnd (N); 9698 9699 Lp2 : constant Boolean := 9700 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop); 9701 Rp2 : constant Boolean := 9702 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop); 9703 9704 Ltyp : constant Entity_Id := Etype (Lop); 9705 Rtyp : constant Entity_Id := Etype (Rop); 9706 Typ : Entity_Id := Etype (N); 9707 9708 begin 9709 Binary_Op_Validity_Checks (N); 9710 9711 -- Check for MINIMIZED/ELIMINATED overflow mode 9712 9713 if Minimized_Eliminated_Overflow_Check (N) then 9714 Apply_Arithmetic_Overflow_Check (N); 9715 return; 9716 end if; 9717 9718 -- Special optimizations for integer types 9719 9720 if Is_Integer_Type (Typ) then 9721 9722 -- N * 0 = 0 for integer types 9723 9724 if Compile_Time_Known_Value (Rop) 9725 and then Expr_Value (Rop) = Uint_0 9726 then 9727 -- Call Remove_Side_Effects to ensure that any side effects in 9728 -- the ignored left operand (in particular function calls to 9729 -- user defined functions) are properly executed. 9730 9731 Remove_Side_Effects (Lop); 9732 9733 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 9734 Analyze_And_Resolve (N, Typ); 9735 return; 9736 end if; 9737 9738 -- Similar handling for 0 * N = 0 9739 9740 if Compile_Time_Known_Value (Lop) 9741 and then Expr_Value (Lop) = Uint_0 9742 then 9743 Remove_Side_Effects (Rop); 9744 Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); 9745 Analyze_And_Resolve (N, Typ); 9746 return; 9747 end if; 9748 9749 -- N * 1 = 1 * N = N for integer types 9750 9751 -- This optimisation is not done if we are going to 9752 -- rewrite the product 1 * 2 ** N to a shift. 9753 9754 if Compile_Time_Known_Value (Rop) 9755 and then Expr_Value (Rop) = Uint_1 9756 and then not Lp2 9757 then 9758 Rewrite (N, Lop); 9759 return; 9760 9761 elsif Compile_Time_Known_Value (Lop) 9762 and then Expr_Value (Lop) = Uint_1 9763 and then not Rp2 9764 then 9765 Rewrite (N, Rop); 9766 return; 9767 end if; 9768 end if; 9769 9770 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that 9771 -- Is_Power_Of_2_For_Shift is set means that we know that our left 9772 -- operand is an integer, as required for this to work. 9773 9774 if Rp2 then 9775 if Lp2 then 9776 9777 -- Convert 2 ** A * 2 ** B into 2 ** (A + B) 9778 9779 Rewrite (N, 9780 Make_Op_Expon (Loc, 9781 Left_Opnd => Make_Integer_Literal (Loc, 2), 9782 Right_Opnd => 9783 Make_Op_Add (Loc, 9784 Left_Opnd => Right_Opnd (Lop), 9785 Right_Opnd => Right_Opnd (Rop)))); 9786 Analyze_And_Resolve (N, Typ); 9787 return; 9788 9789 else 9790 -- If the result is modular, perform the reduction of the result 9791 -- appropriately. 9792 9793 if Is_Modular_Integer_Type (Typ) 9794 and then not Non_Binary_Modulus (Typ) 9795 then 9796 Rewrite (N, 9797 Make_Op_And (Loc, 9798 Left_Opnd => 9799 Make_Op_Shift_Left (Loc, 9800 Left_Opnd => Lop, 9801 Right_Opnd => 9802 Convert_To (Standard_Natural, Right_Opnd (Rop))), 9803 Right_Opnd => 9804 Make_Integer_Literal (Loc, Modulus (Typ) - 1))); 9805 9806 else 9807 Rewrite (N, 9808 Make_Op_Shift_Left (Loc, 9809 Left_Opnd => Lop, 9810 Right_Opnd => 9811 Convert_To (Standard_Natural, Right_Opnd (Rop)))); 9812 end if; 9813 9814 Analyze_And_Resolve (N, Typ); 9815 return; 9816 end if; 9817 9818 -- Same processing for the operands the other way round 9819 9820 elsif Lp2 then 9821 if Is_Modular_Integer_Type (Typ) 9822 and then not Non_Binary_Modulus (Typ) 9823 then 9824 Rewrite (N, 9825 Make_Op_And (Loc, 9826 Left_Opnd => 9827 Make_Op_Shift_Left (Loc, 9828 Left_Opnd => Rop, 9829 Right_Opnd => 9830 Convert_To (Standard_Natural, Right_Opnd (Lop))), 9831 Right_Opnd => 9832 Make_Integer_Literal (Loc, Modulus (Typ) - 1))); 9833 9834 else 9835 Rewrite (N, 9836 Make_Op_Shift_Left (Loc, 9837 Left_Opnd => Rop, 9838 Right_Opnd => 9839 Convert_To (Standard_Natural, Right_Opnd (Lop)))); 9840 end if; 9841 9842 Analyze_And_Resolve (N, Typ); 9843 return; 9844 end if; 9845 9846 -- Try to narrow the operation 9847 9848 if Typ = Universal_Integer then 9849 Narrow_Large_Operation (N); 9850 9851 if Nkind (N) /= N_Op_Multiply then 9852 return; 9853 end if; 9854 end if; 9855 9856 -- Do required fixup of universal fixed operation 9857 9858 if Typ = Universal_Fixed then 9859 Fixup_Universal_Fixed_Operation (N); 9860 Typ := Etype (N); 9861 end if; 9862 9863 -- Multiplications with fixed-point results 9864 9865 if Is_Fixed_Point_Type (Typ) then 9866 9867 -- Case of fixed * integer => fixed 9868 9869 if Is_Integer_Type (Rtyp) then 9870 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N); 9871 9872 -- Case of integer * fixed => fixed 9873 9874 elsif Is_Integer_Type (Ltyp) then 9875 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N); 9876 9877 -- Case of fixed * fixed => fixed 9878 9879 else 9880 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N); 9881 end if; 9882 9883 -- Other cases of multiplication of fixed-point operands 9884 9885 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then 9886 if Is_Integer_Type (Typ) then 9887 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N); 9888 else 9889 pragma Assert (Is_Floating_Point_Type (Typ)); 9890 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); 9891 end if; 9892 9893 -- Mixed-mode operations can appear in a non-static universal context, 9894 -- in which case the integer argument must be converted explicitly. 9895 9896 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then 9897 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); 9898 Analyze_And_Resolve (Rop, Universal_Real); 9899 9900 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then 9901 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); 9902 Analyze_And_Resolve (Lop, Universal_Real); 9903 9904 -- Non-fixed point cases, check software overflow checking required 9905 9906 elsif Is_Signed_Integer_Type (Etype (N)) then 9907 Apply_Arithmetic_Overflow_Check (N); 9908 end if; 9909 9910 -- Overflow checks for floating-point if -gnateF mode active 9911 9912 Check_Float_Op_Overflow (N); 9913 9914 Expand_Nonbinary_Modular_Op (N); 9915 end Expand_N_Op_Multiply; 9916 9917 -------------------- 9918 -- Expand_N_Op_Ne -- 9919 -------------------- 9920 9921 procedure Expand_N_Op_Ne (N : Node_Id) is 9922 Typ : constant Entity_Id := Etype (Left_Opnd (N)); 9923 9924 begin 9925 -- Case of elementary type with standard operator. But if unnesting, 9926 -- handle elementary types whose Equivalent_Types are records because 9927 -- there may be padding or undefined fields. 9928 9929 if Is_Elementary_Type (Typ) 9930 and then Sloc (Entity (N)) = Standard_Location 9931 and then not (Ekind (Typ) in E_Class_Wide_Type 9932 | E_Class_Wide_Subtype 9933 | E_Access_Subprogram_Type 9934 | E_Access_Protected_Subprogram_Type 9935 | E_Anonymous_Access_Protected_Subprogram_Type 9936 | E_Exception_Type 9937 and then Present (Equivalent_Type (Typ)) 9938 and then Is_Record_Type (Equivalent_Type (Typ))) 9939 then 9940 Binary_Op_Validity_Checks (N); 9941 9942 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if 9943 -- means we no longer have a /= operation, we are all done. 9944 9945 Expand_Compare_Minimize_Eliminate_Overflow (N); 9946 9947 if Nkind (N) /= N_Op_Ne then 9948 return; 9949 end if; 9950 9951 -- Boolean types (requiring handling of non-standard case) 9952 9953 if Is_Boolean_Type (Typ) then 9954 Adjust_Condition (Left_Opnd (N)); 9955 Adjust_Condition (Right_Opnd (N)); 9956 Set_Etype (N, Standard_Boolean); 9957 Adjust_Result_Type (N, Typ); 9958 end if; 9959 9960 Rewrite_Comparison (N); 9961 9962 -- Try to narrow the operation 9963 9964 if Typ = Universal_Integer and then Nkind (N) = N_Op_Ne then 9965 Narrow_Large_Operation (N); 9966 end if; 9967 9968 -- For all cases other than elementary types, we rewrite node as the 9969 -- negation of an equality operation, and reanalyze. The equality to be 9970 -- used is defined in the same scope and has the same signature. This 9971 -- signature must be set explicitly since in an instance it may not have 9972 -- the same visibility as in the generic unit. This avoids duplicating 9973 -- or factoring the complex code for record/array equality tests etc. 9974 9975 -- This case is also used for the minimal expansion performed in 9976 -- GNATprove mode. 9977 9978 else 9979 declare 9980 Loc : constant Source_Ptr := Sloc (N); 9981 Neg : Node_Id; 9982 Ne : constant Entity_Id := Entity (N); 9983 9984 begin 9985 Binary_Op_Validity_Checks (N); 9986 9987 Neg := 9988 Make_Op_Not (Loc, 9989 Right_Opnd => 9990 Make_Op_Eq (Loc, 9991 Left_Opnd => Left_Opnd (N), 9992 Right_Opnd => Right_Opnd (N))); 9993 9994 -- The level of parentheses is useless in GNATprove mode, and 9995 -- bumping its level here leads to wrong columns being used in 9996 -- check messages, hence skip it in this mode. 9997 9998 if not GNATprove_Mode then 9999 Set_Paren_Count (Right_Opnd (Neg), 1); 10000 end if; 10001 10002 if Scope (Ne) /= Standard_Standard then 10003 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); 10004 end if; 10005 10006 -- For navigation purposes, we want to treat the inequality as an 10007 -- implicit reference to the corresponding equality. Preserve the 10008 -- Comes_From_ source flag to generate proper Xref entries. 10009 10010 Preserve_Comes_From_Source (Neg, N); 10011 Preserve_Comes_From_Source (Right_Opnd (Neg), N); 10012 Rewrite (N, Neg); 10013 Analyze_And_Resolve (N, Standard_Boolean); 10014 end; 10015 end if; 10016 10017 -- No need for optimization in GNATprove mode, where we would rather see 10018 -- the original source expression. 10019 10020 if not GNATprove_Mode then 10021 Optimize_Length_Comparison (N); 10022 end if; 10023 end Expand_N_Op_Ne; 10024 10025 --------------------- 10026 -- Expand_N_Op_Not -- 10027 --------------------- 10028 10029 -- If the argument is other than a Boolean array type, there is no special 10030 -- expansion required, except for dealing with validity checks, and non- 10031 -- standard boolean representations. 10032 10033 -- For the packed array case, we call the special routine in Exp_Pakd, 10034 -- except that if the component size is greater than one, we use the 10035 -- standard routine generating a gruesome loop (it is so peculiar to have 10036 -- packed arrays with non-standard Boolean representations anyway, so it 10037 -- does not matter that we do not handle this case efficiently). 10038 10039 -- For the unpacked array case (and for the special packed case where we 10040 -- have non standard Booleans, as discussed above), we generate and insert 10041 -- into the tree the following function definition: 10042 10043 -- function Nnnn (A : arr) is 10044 -- B : arr; 10045 -- begin 10046 -- for J in a'range loop 10047 -- B (J) := not A (J); 10048 -- end loop; 10049 -- return B; 10050 -- end Nnnn; 10051 10052 -- or in the case of Transform_Function_Array: 10053 10054 -- procedure Nnnn (A : arr; RESULT : out arr) is 10055 -- begin 10056 -- for J in a'range loop 10057 -- RESULT (J) := not A (J); 10058 -- end loop; 10059 -- end Nnnn; 10060 10061 -- Here arr is the actual subtype of the parameter (and hence always 10062 -- constrained). Then we replace the not with a call to this subprogram. 10063 10064 procedure Expand_N_Op_Not (N : Node_Id) is 10065 Loc : constant Source_Ptr := Sloc (N); 10066 Typ : constant Entity_Id := Etype (Right_Opnd (N)); 10067 Opnd : Node_Id; 10068 Arr : Entity_Id; 10069 A : Entity_Id; 10070 B : Entity_Id; 10071 J : Entity_Id; 10072 A_J : Node_Id; 10073 B_J : Node_Id; 10074 10075 Func_Name : Entity_Id; 10076 Loop_Statement : Node_Id; 10077 10078 begin 10079 Unary_Op_Validity_Checks (N); 10080 10081 -- For boolean operand, deal with non-standard booleans 10082 10083 if Is_Boolean_Type (Typ) then 10084 Adjust_Condition (Right_Opnd (N)); 10085 Set_Etype (N, Standard_Boolean); 10086 Adjust_Result_Type (N, Typ); 10087 return; 10088 end if; 10089 10090 -- Only array types need any other processing 10091 10092 if not Is_Array_Type (Typ) then 10093 return; 10094 end if; 10095 10096 -- Case of array operand. If bit packed with a component size of 1, 10097 -- handle it in Exp_Pakd if the operand is known to be aligned. 10098 10099 if Is_Bit_Packed_Array (Typ) 10100 and then Component_Size (Typ) = 1 10101 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) 10102 then 10103 Expand_Packed_Not (N); 10104 return; 10105 end if; 10106 10107 -- Case of array operand which is not bit-packed. If the context is 10108 -- a safe assignment, call in-place operation, If context is a larger 10109 -- boolean expression in the context of a safe assignment, expansion is 10110 -- done by enclosing operation. 10111 10112 Opnd := Relocate_Node (Right_Opnd (N)); 10113 Convert_To_Actual_Subtype (Opnd); 10114 Arr := Etype (Opnd); 10115 Ensure_Defined (Arr, N); 10116 Silly_Boolean_Array_Not_Test (N, Arr); 10117 10118 if Nkind (Parent (N)) = N_Assignment_Statement then 10119 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then 10120 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 10121 return; 10122 10123 -- Special case the negation of a binary operation 10124 10125 elsif Nkind (Opnd) in N_Op_And | N_Op_Or | N_Op_Xor 10126 and then Safe_In_Place_Array_Op 10127 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) 10128 then 10129 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); 10130 return; 10131 end if; 10132 10133 elsif Nkind (Parent (N)) in N_Binary_Op 10134 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 10135 then 10136 declare 10137 Op1 : constant Node_Id := Left_Opnd (Parent (N)); 10138 Op2 : constant Node_Id := Right_Opnd (Parent (N)); 10139 Lhs : constant Node_Id := Name (Parent (Parent (N))); 10140 10141 begin 10142 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then 10143 10144 -- (not A) op (not B) can be reduced to a single call 10145 10146 if N = Op1 and then Nkind (Op2) = N_Op_Not then 10147 return; 10148 10149 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then 10150 return; 10151 10152 -- A xor (not B) can also be special-cased 10153 10154 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then 10155 return; 10156 end if; 10157 end if; 10158 end; 10159 end if; 10160 10161 A := Make_Defining_Identifier (Loc, Name_uA); 10162 10163 if Transform_Function_Array then 10164 B := Make_Defining_Identifier (Loc, Name_UP_RESULT); 10165 else 10166 B := Make_Defining_Identifier (Loc, Name_uB); 10167 end if; 10168 10169 J := Make_Defining_Identifier (Loc, Name_uJ); 10170 10171 A_J := 10172 Make_Indexed_Component (Loc, 10173 Prefix => New_Occurrence_Of (A, Loc), 10174 Expressions => New_List (New_Occurrence_Of (J, Loc))); 10175 10176 B_J := 10177 Make_Indexed_Component (Loc, 10178 Prefix => New_Occurrence_Of (B, Loc), 10179 Expressions => New_List (New_Occurrence_Of (J, Loc))); 10180 10181 Loop_Statement := 10182 Make_Implicit_Loop_Statement (N, 10183 Identifier => Empty, 10184 10185 Iteration_Scheme => 10186 Make_Iteration_Scheme (Loc, 10187 Loop_Parameter_Specification => 10188 Make_Loop_Parameter_Specification (Loc, 10189 Defining_Identifier => J, 10190 Discrete_Subtype_Definition => 10191 Make_Attribute_Reference (Loc, 10192 Prefix => Make_Identifier (Loc, Chars (A)), 10193 Attribute_Name => Name_Range))), 10194 10195 Statements => New_List ( 10196 Make_Assignment_Statement (Loc, 10197 Name => B_J, 10198 Expression => Make_Op_Not (Loc, A_J)))); 10199 10200 Func_Name := Make_Temporary (Loc, 'N'); 10201 Set_Is_Inlined (Func_Name); 10202 10203 if Transform_Function_Array then 10204 Insert_Action (N, 10205 Make_Subprogram_Body (Loc, 10206 Specification => 10207 Make_Procedure_Specification (Loc, 10208 Defining_Unit_Name => Func_Name, 10209 Parameter_Specifications => New_List ( 10210 Make_Parameter_Specification (Loc, 10211 Defining_Identifier => A, 10212 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 10213 Make_Parameter_Specification (Loc, 10214 Defining_Identifier => B, 10215 Out_Present => True, 10216 Parameter_Type => New_Occurrence_Of (Typ, Loc)))), 10217 10218 Declarations => New_List, 10219 10220 Handled_Statement_Sequence => 10221 Make_Handled_Sequence_Of_Statements (Loc, 10222 Statements => New_List (Loop_Statement)))); 10223 10224 declare 10225 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 10226 Call : Node_Id; 10227 Decl : Node_Id; 10228 10229 begin 10230 -- Generate: 10231 -- Temp : ...; 10232 10233 Decl := 10234 Make_Object_Declaration (Loc, 10235 Defining_Identifier => Temp_Id, 10236 Object_Definition => New_Occurrence_Of (Typ, Loc)); 10237 10238 -- Generate: 10239 -- Proc_Call (Opnd, Temp); 10240 10241 Call := 10242 Make_Procedure_Call_Statement (Loc, 10243 Name => New_Occurrence_Of (Func_Name, Loc), 10244 Parameter_Associations => 10245 New_List (Opnd, New_Occurrence_Of (Temp_Id, Loc))); 10246 10247 Insert_Actions (Parent (N), New_List (Decl, Call)); 10248 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); 10249 end; 10250 else 10251 Insert_Action (N, 10252 Make_Subprogram_Body (Loc, 10253 Specification => 10254 Make_Function_Specification (Loc, 10255 Defining_Unit_Name => Func_Name, 10256 Parameter_Specifications => New_List ( 10257 Make_Parameter_Specification (Loc, 10258 Defining_Identifier => A, 10259 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 10260 Result_Definition => New_Occurrence_Of (Typ, Loc)), 10261 10262 Declarations => New_List ( 10263 Make_Object_Declaration (Loc, 10264 Defining_Identifier => B, 10265 Object_Definition => New_Occurrence_Of (Arr, Loc))), 10266 10267 Handled_Statement_Sequence => 10268 Make_Handled_Sequence_Of_Statements (Loc, 10269 Statements => New_List ( 10270 Loop_Statement, 10271 Make_Simple_Return_Statement (Loc, 10272 Expression => Make_Identifier (Loc, Chars (B))))))); 10273 10274 Rewrite (N, 10275 Make_Function_Call (Loc, 10276 Name => New_Occurrence_Of (Func_Name, Loc), 10277 Parameter_Associations => New_List (Opnd))); 10278 end if; 10279 10280 Analyze_And_Resolve (N, Typ); 10281 end Expand_N_Op_Not; 10282 10283 -------------------- 10284 -- Expand_N_Op_Or -- 10285 -------------------- 10286 10287 procedure Expand_N_Op_Or (N : Node_Id) is 10288 Typ : constant Entity_Id := Etype (N); 10289 10290 begin 10291 Binary_Op_Validity_Checks (N); 10292 10293 if Is_Array_Type (Etype (N)) then 10294 Expand_Boolean_Operator (N); 10295 10296 elsif Is_Boolean_Type (Etype (N)) then 10297 Adjust_Condition (Left_Opnd (N)); 10298 Adjust_Condition (Right_Opnd (N)); 10299 Set_Etype (N, Standard_Boolean); 10300 Adjust_Result_Type (N, Typ); 10301 10302 elsif Is_Intrinsic_Subprogram (Entity (N)) then 10303 Expand_Intrinsic_Call (N, Entity (N)); 10304 end if; 10305 10306 Expand_Nonbinary_Modular_Op (N); 10307 end Expand_N_Op_Or; 10308 10309 ---------------------- 10310 -- Expand_N_Op_Plus -- 10311 ---------------------- 10312 10313 procedure Expand_N_Op_Plus (N : Node_Id) is 10314 Typ : constant Entity_Id := Etype (N); 10315 10316 begin 10317 Unary_Op_Validity_Checks (N); 10318 10319 -- Check for MINIMIZED/ELIMINATED overflow mode 10320 10321 if Minimized_Eliminated_Overflow_Check (N) then 10322 Apply_Arithmetic_Overflow_Check (N); 10323 return; 10324 end if; 10325 10326 -- Try to narrow the operation 10327 10328 if Typ = Universal_Integer then 10329 Narrow_Large_Operation (N); 10330 end if; 10331 end Expand_N_Op_Plus; 10332 10333 --------------------- 10334 -- Expand_N_Op_Rem -- 10335 --------------------- 10336 10337 procedure Expand_N_Op_Rem (N : Node_Id) is 10338 Loc : constant Source_Ptr := Sloc (N); 10339 Typ : constant Entity_Id := Etype (N); 10340 10341 Left : Node_Id; 10342 Right : Node_Id; 10343 10344 Lo : Uint; 10345 Hi : Uint; 10346 OK : Boolean; 10347 10348 Lneg : Boolean; 10349 Rneg : Boolean; 10350 -- Set if corresponding operand can be negative 10351 10352 pragma Unreferenced (Hi); 10353 10354 begin 10355 Binary_Op_Validity_Checks (N); 10356 10357 -- Check for MINIMIZED/ELIMINATED overflow mode 10358 10359 if Minimized_Eliminated_Overflow_Check (N) then 10360 Apply_Arithmetic_Overflow_Check (N); 10361 return; 10362 end if; 10363 10364 -- Try to narrow the operation 10365 10366 if Typ = Universal_Integer then 10367 Narrow_Large_Operation (N); 10368 10369 if Nkind (N) /= N_Op_Rem then 10370 return; 10371 end if; 10372 end if; 10373 10374 if Is_Integer_Type (Etype (N)) then 10375 Apply_Divide_Checks (N); 10376 10377 -- All done if we don't have a REM any more, which can happen as a 10378 -- result of overflow expansion in MINIMIZED or ELIMINATED modes. 10379 10380 if Nkind (N) /= N_Op_Rem then 10381 return; 10382 end if; 10383 end if; 10384 10385 -- Proceed with expansion of REM 10386 10387 Left := Left_Opnd (N); 10388 Right := Right_Opnd (N); 10389 10390 -- Apply optimization x rem 1 = 0. We don't really need that with gcc, 10391 -- but it is useful with other back ends, and is certainly harmless. 10392 10393 if Is_Integer_Type (Etype (N)) 10394 and then Compile_Time_Known_Value (Right) 10395 and then Expr_Value (Right) = Uint_1 10396 then 10397 -- Call Remove_Side_Effects to ensure that any side effects in the 10398 -- ignored left operand (in particular function calls to user defined 10399 -- functions) are properly executed. 10400 10401 Remove_Side_Effects (Left); 10402 10403 Rewrite (N, Make_Integer_Literal (Loc, 0)); 10404 Analyze_And_Resolve (N, Typ); 10405 return; 10406 end if; 10407 10408 -- Deal with annoying case of largest negative number remainder minus 10409 -- one. Gigi may not handle this case correctly, because on some 10410 -- targets, the mod value is computed using a divide instruction 10411 -- which gives an overflow trap for this case. 10412 10413 -- It would be a bit more efficient to figure out which targets this 10414 -- is really needed for, but in practice it is reasonable to do the 10415 -- following special check in all cases, since it means we get a clearer 10416 -- message, and also the overhead is minimal given that division is 10417 -- expensive in any case. 10418 10419 -- In fact the check is quite easy, if the right operand is -1, then 10420 -- the remainder is always 0, and we can just ignore the left operand 10421 -- completely in this case. 10422 10423 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 10424 Lneg := (not OK) or else Lo < 0; 10425 10426 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True); 10427 Rneg := (not OK) or else Lo < 0; 10428 10429 -- We won't mess with trying to find out if the left operand can really 10430 -- be the largest negative number (that's a pain in the case of private 10431 -- types and this is really marginal). We will just assume that we need 10432 -- the test if the left operand can be negative at all. 10433 10434 if Lneg and Rneg then 10435 Rewrite (N, 10436 Make_If_Expression (Loc, 10437 Expressions => New_List ( 10438 Make_Op_Eq (Loc, 10439 Left_Opnd => Duplicate_Subexpr (Right), 10440 Right_Opnd => 10441 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))), 10442 10443 Unchecked_Convert_To (Typ, 10444 Make_Integer_Literal (Loc, Uint_0)), 10445 10446 Relocate_Node (N)))); 10447 10448 Set_Analyzed (Next (Next (First (Expressions (N))))); 10449 Analyze_And_Resolve (N, Typ); 10450 end if; 10451 end Expand_N_Op_Rem; 10452 10453 ----------------------------- 10454 -- Expand_N_Op_Rotate_Left -- 10455 ----------------------------- 10456 10457 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is 10458 begin 10459 Binary_Op_Validity_Checks (N); 10460 10461 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C, 10462 -- so we rewrite in terms of logical shifts 10463 10464 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits) 10465 10466 -- where Bits is the shift count mod Esize (the mod operation here 10467 -- deals with ludicrous large shift counts, which are apparently OK). 10468 10469 if Modify_Tree_For_C then 10470 declare 10471 Loc : constant Source_Ptr := Sloc (N); 10472 Rtp : constant Entity_Id := Etype (Right_Opnd (N)); 10473 Typ : constant Entity_Id := Etype (N); 10474 10475 begin 10476 -- Sem_Intr should prevent getting there with a non binary modulus 10477 10478 pragma Assert (not Non_Binary_Modulus (Typ)); 10479 10480 Rewrite (Right_Opnd (N), 10481 Make_Op_Rem (Loc, 10482 Left_Opnd => Relocate_Node (Right_Opnd (N)), 10483 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); 10484 10485 Analyze_And_Resolve (Right_Opnd (N), Rtp); 10486 10487 Rewrite (N, 10488 Make_Op_Or (Loc, 10489 Left_Opnd => 10490 Make_Op_Shift_Left (Loc, 10491 Left_Opnd => Left_Opnd (N), 10492 Right_Opnd => Right_Opnd (N)), 10493 10494 Right_Opnd => 10495 Make_Op_Shift_Right (Loc, 10496 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)), 10497 Right_Opnd => 10498 Make_Op_Subtract (Loc, 10499 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), 10500 Right_Opnd => 10501 Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); 10502 10503 Analyze_And_Resolve (N, Typ); 10504 end; 10505 end if; 10506 end Expand_N_Op_Rotate_Left; 10507 10508 ------------------------------ 10509 -- Expand_N_Op_Rotate_Right -- 10510 ------------------------------ 10511 10512 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is 10513 begin 10514 Binary_Op_Validity_Checks (N); 10515 10516 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C, 10517 -- so we rewrite in terms of logical shifts 10518 10519 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits) 10520 10521 -- where Bits is the shift count mod Esize (the mod operation here 10522 -- deals with ludicrous large shift counts, which are apparently OK). 10523 10524 if Modify_Tree_For_C then 10525 declare 10526 Loc : constant Source_Ptr := Sloc (N); 10527 Rtp : constant Entity_Id := Etype (Right_Opnd (N)); 10528 Typ : constant Entity_Id := Etype (N); 10529 10530 begin 10531 -- Sem_Intr should prevent getting there with a non binary modulus 10532 10533 pragma Assert (not Non_Binary_Modulus (Typ)); 10534 10535 Rewrite (Right_Opnd (N), 10536 Make_Op_Rem (Loc, 10537 Left_Opnd => Relocate_Node (Right_Opnd (N)), 10538 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); 10539 10540 Analyze_And_Resolve (Right_Opnd (N), Rtp); 10541 10542 Rewrite (N, 10543 Make_Op_Or (Loc, 10544 Left_Opnd => 10545 Make_Op_Shift_Right (Loc, 10546 Left_Opnd => Left_Opnd (N), 10547 Right_Opnd => Right_Opnd (N)), 10548 10549 Right_Opnd => 10550 Make_Op_Shift_Left (Loc, 10551 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)), 10552 Right_Opnd => 10553 Make_Op_Subtract (Loc, 10554 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)), 10555 Right_Opnd => 10556 Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); 10557 10558 Analyze_And_Resolve (N, Typ); 10559 end; 10560 end if; 10561 end Expand_N_Op_Rotate_Right; 10562 10563 ---------------------------- 10564 -- Expand_N_Op_Shift_Left -- 10565 ---------------------------- 10566 10567 -- Note: nothing in this routine depends on left as opposed to right shifts 10568 -- so we share the routine for expanding shift right operations. 10569 10570 procedure Expand_N_Op_Shift_Left (N : Node_Id) is 10571 begin 10572 Binary_Op_Validity_Checks (N); 10573 10574 -- If we are in Modify_Tree_For_C mode, then ensure that the right 10575 -- operand is not greater than the word size (since that would not 10576 -- be defined properly by the corresponding C shift operator). 10577 10578 if Modify_Tree_For_C then 10579 declare 10580 Right : constant Node_Id := Right_Opnd (N); 10581 Loc : constant Source_Ptr := Sloc (Right); 10582 Typ : constant Entity_Id := Etype (N); 10583 Siz : constant Uint := Esize (Typ); 10584 Orig : Node_Id; 10585 OK : Boolean; 10586 Lo : Uint; 10587 Hi : Uint; 10588 10589 begin 10590 -- Sem_Intr should prevent getting there with a non binary modulus 10591 10592 pragma Assert (not Non_Binary_Modulus (Typ)); 10593 10594 if Compile_Time_Known_Value (Right) then 10595 if Expr_Value (Right) >= Siz then 10596 Rewrite (N, Make_Integer_Literal (Loc, 0)); 10597 Analyze_And_Resolve (N, Typ); 10598 end if; 10599 10600 -- Not compile time known, find range 10601 10602 else 10603 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True); 10604 10605 -- Nothing to do if known to be OK range, otherwise expand 10606 10607 if not OK or else Hi >= Siz then 10608 10609 -- Prevent recursion on copy of shift node 10610 10611 Orig := Relocate_Node (N); 10612 Set_Analyzed (Orig); 10613 10614 -- Now do the rewrite 10615 10616 Rewrite (N, 10617 Make_If_Expression (Loc, 10618 Expressions => New_List ( 10619 Make_Op_Ge (Loc, 10620 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), 10621 Right_Opnd => Make_Integer_Literal (Loc, Siz)), 10622 Make_Integer_Literal (Loc, 0), 10623 Orig))); 10624 Analyze_And_Resolve (N, Typ); 10625 end if; 10626 end if; 10627 end; 10628 end if; 10629 end Expand_N_Op_Shift_Left; 10630 10631 ----------------------------- 10632 -- Expand_N_Op_Shift_Right -- 10633 ----------------------------- 10634 10635 procedure Expand_N_Op_Shift_Right (N : Node_Id) is 10636 begin 10637 -- Share shift left circuit 10638 10639 Expand_N_Op_Shift_Left (N); 10640 end Expand_N_Op_Shift_Right; 10641 10642 ---------------------------------------- 10643 -- Expand_N_Op_Shift_Right_Arithmetic -- 10644 ---------------------------------------- 10645 10646 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is 10647 begin 10648 Binary_Op_Validity_Checks (N); 10649 10650 -- If we are in Modify_Tree_For_C mode, there is no shift right 10651 -- arithmetic in C, so we rewrite in terms of logical shifts for 10652 -- modular integers, and keep the Shift_Right intrinsic for signed 10653 -- integers: even though doing a shift on a signed integer is not 10654 -- fully guaranteed by the C standard, this is what C compilers 10655 -- implement in practice. 10656 -- Consider also taking advantage of this for modular integers by first 10657 -- performing an unchecked conversion of the modular integer to a signed 10658 -- integer of the same sign, and then convert back. 10659 10660 -- Shift_Right (Num, Bits) or 10661 -- (if Num >= Sign 10662 -- then not (Shift_Right (Mask, bits)) 10663 -- else 0) 10664 10665 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1) 10666 10667 -- Note: the above works fine for shift counts greater than or equal 10668 -- to the word size, since in this case (not (Shift_Right (Mask, bits))) 10669 -- generates all 1'bits. 10670 10671 if Modify_Tree_For_C and then Is_Modular_Integer_Type (Etype (N)) then 10672 declare 10673 Loc : constant Source_Ptr := Sloc (N); 10674 Typ : constant Entity_Id := Etype (N); 10675 Sign : constant Uint := 2 ** (Esize (Typ) - 1); 10676 Mask : constant Uint := (2 ** Esize (Typ)) - 1; 10677 Left : constant Node_Id := Left_Opnd (N); 10678 Right : constant Node_Id := Right_Opnd (N); 10679 Maskx : Node_Id; 10680 10681 begin 10682 -- Sem_Intr should prevent getting there with a non binary modulus 10683 10684 pragma Assert (not Non_Binary_Modulus (Typ)); 10685 10686 -- Here if not (Shift_Right (Mask, bits)) can be computed at 10687 -- compile time as a single constant. 10688 10689 if Compile_Time_Known_Value (Right) then 10690 declare 10691 Val : constant Uint := Expr_Value (Right); 10692 10693 begin 10694 if Val >= Esize (Typ) then 10695 Maskx := Make_Integer_Literal (Loc, Mask); 10696 10697 else 10698 Maskx := 10699 Make_Integer_Literal (Loc, 10700 Intval => Mask - (Mask / (2 ** Expr_Value (Right)))); 10701 end if; 10702 end; 10703 10704 else 10705 Maskx := 10706 Make_Op_Not (Loc, 10707 Right_Opnd => 10708 Make_Op_Shift_Right (Loc, 10709 Left_Opnd => Make_Integer_Literal (Loc, Mask), 10710 Right_Opnd => Duplicate_Subexpr_No_Checks (Right))); 10711 end if; 10712 10713 -- Now do the rewrite 10714 10715 Rewrite (N, 10716 Make_Op_Or (Loc, 10717 Left_Opnd => 10718 Make_Op_Shift_Right (Loc, 10719 Left_Opnd => Left, 10720 Right_Opnd => Right), 10721 Right_Opnd => 10722 Make_If_Expression (Loc, 10723 Expressions => New_List ( 10724 Make_Op_Ge (Loc, 10725 Left_Opnd => Duplicate_Subexpr_No_Checks (Left), 10726 Right_Opnd => Make_Integer_Literal (Loc, Sign)), 10727 Maskx, 10728 Make_Integer_Literal (Loc, 0))))); 10729 Analyze_And_Resolve (N, Typ); 10730 end; 10731 end if; 10732 end Expand_N_Op_Shift_Right_Arithmetic; 10733 10734 -------------------------- 10735 -- Expand_N_Op_Subtract -- 10736 -------------------------- 10737 10738 procedure Expand_N_Op_Subtract (N : Node_Id) is 10739 Typ : constant Entity_Id := Etype (N); 10740 10741 begin 10742 Binary_Op_Validity_Checks (N); 10743 10744 -- Check for MINIMIZED/ELIMINATED overflow mode 10745 10746 if Minimized_Eliminated_Overflow_Check (N) then 10747 Apply_Arithmetic_Overflow_Check (N); 10748 return; 10749 end if; 10750 10751 -- Try to narrow the operation 10752 10753 if Typ = Universal_Integer then 10754 Narrow_Large_Operation (N); 10755 10756 if Nkind (N) /= N_Op_Subtract then 10757 return; 10758 end if; 10759 end if; 10760 10761 -- N - 0 = N for integer types 10762 10763 if Is_Integer_Type (Typ) 10764 and then Compile_Time_Known_Value (Right_Opnd (N)) 10765 and then Expr_Value (Right_Opnd (N)) = 0 10766 then 10767 Rewrite (N, Left_Opnd (N)); 10768 return; 10769 end if; 10770 10771 -- Arithmetic overflow checks for signed integer/fixed point types 10772 10773 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then 10774 Apply_Arithmetic_Overflow_Check (N); 10775 end if; 10776 10777 -- Overflow checks for floating-point if -gnateF mode active 10778 10779 Check_Float_Op_Overflow (N); 10780 10781 Expand_Nonbinary_Modular_Op (N); 10782 end Expand_N_Op_Subtract; 10783 10784 --------------------- 10785 -- Expand_N_Op_Xor -- 10786 --------------------- 10787 10788 procedure Expand_N_Op_Xor (N : Node_Id) is 10789 Typ : constant Entity_Id := Etype (N); 10790 10791 begin 10792 Binary_Op_Validity_Checks (N); 10793 10794 if Is_Array_Type (Etype (N)) then 10795 Expand_Boolean_Operator (N); 10796 10797 elsif Is_Boolean_Type (Etype (N)) then 10798 Adjust_Condition (Left_Opnd (N)); 10799 Adjust_Condition (Right_Opnd (N)); 10800 Set_Etype (N, Standard_Boolean); 10801 Adjust_Result_Type (N, Typ); 10802 10803 elsif Is_Intrinsic_Subprogram (Entity (N)) then 10804 Expand_Intrinsic_Call (N, Entity (N)); 10805 end if; 10806 10807 Expand_Nonbinary_Modular_Op (N); 10808 end Expand_N_Op_Xor; 10809 10810 ---------------------- 10811 -- Expand_N_Or_Else -- 10812 ---------------------- 10813 10814 procedure Expand_N_Or_Else (N : Node_Id) 10815 renames Expand_Short_Circuit_Operator; 10816 10817 ----------------------------------- 10818 -- Expand_N_Qualified_Expression -- 10819 ----------------------------------- 10820 10821 procedure Expand_N_Qualified_Expression (N : Node_Id) is 10822 Operand : constant Node_Id := Expression (N); 10823 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 10824 10825 begin 10826 -- Do validity check if validity checking operands 10827 10828 if Validity_Checks_On and Validity_Check_Operands then 10829 Ensure_Valid (Operand); 10830 end if; 10831 10832 -- Apply possible constraint check 10833 10834 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); 10835 10836 -- Apply possible predicate check 10837 10838 Apply_Predicate_Check (Operand, Target_Type); 10839 10840 if Do_Range_Check (Operand) then 10841 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed); 10842 end if; 10843 end Expand_N_Qualified_Expression; 10844 10845 ------------------------------------ 10846 -- Expand_N_Quantified_Expression -- 10847 ------------------------------------ 10848 10849 -- We expand: 10850 10851 -- for all X in range => Cond 10852 10853 -- into: 10854 10855 -- T := True; 10856 -- for X in range loop 10857 -- if not Cond then 10858 -- T := False; 10859 -- exit; 10860 -- end if; 10861 -- end loop; 10862 10863 -- Similarly, an existentially quantified expression: 10864 10865 -- for some X in range => Cond 10866 10867 -- becomes: 10868 10869 -- T := False; 10870 -- for X in range loop 10871 -- if Cond then 10872 -- T := True; 10873 -- exit; 10874 -- end if; 10875 -- end loop; 10876 10877 -- In both cases, the iteration may be over a container in which case it is 10878 -- given by an iterator specification, not a loop parameter specification. 10879 10880 procedure Expand_N_Quantified_Expression (N : Node_Id) is 10881 Actions : constant List_Id := New_List; 10882 For_All : constant Boolean := All_Present (N); 10883 Iter_Spec : constant Node_Id := Iterator_Specification (N); 10884 Loc : constant Source_Ptr := Sloc (N); 10885 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); 10886 Cond : Node_Id; 10887 Flag : Entity_Id; 10888 Scheme : Node_Id; 10889 Stmts : List_Id; 10890 Var : Entity_Id; 10891 10892 begin 10893 -- Ensure that the bound variable is properly frozen. We must do 10894 -- this before expansion because the expression is about to be 10895 -- converted into a loop, and resulting freeze nodes may end up 10896 -- in the wrong place in the tree. 10897 10898 if Present (Iter_Spec) then 10899 Var := Defining_Identifier (Iter_Spec); 10900 else 10901 Var := Defining_Identifier (Loop_Spec); 10902 end if; 10903 10904 declare 10905 P : Node_Id := Parent (N); 10906 begin 10907 while Nkind (P) in N_Subexpr loop 10908 P := Parent (P); 10909 end loop; 10910 10911 Freeze_Before (P, Etype (Var)); 10912 end; 10913 10914 -- Create the declaration of the flag which tracks the status of the 10915 -- quantified expression. Generate: 10916 10917 -- Flag : Boolean := (True | False); 10918 10919 Flag := Make_Temporary (Loc, 'T', N); 10920 10921 Append_To (Actions, 10922 Make_Object_Declaration (Loc, 10923 Defining_Identifier => Flag, 10924 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 10925 Expression => 10926 New_Occurrence_Of (Boolean_Literals (For_All), Loc))); 10927 10928 -- Construct the circuitry which tracks the status of the quantified 10929 -- expression. Generate: 10930 10931 -- if [not] Cond then 10932 -- Flag := (False | True); 10933 -- exit; 10934 -- end if; 10935 10936 Cond := Relocate_Node (Condition (N)); 10937 10938 if For_All then 10939 Cond := Make_Op_Not (Loc, Cond); 10940 end if; 10941 10942 Stmts := New_List ( 10943 Make_Implicit_If_Statement (N, 10944 Condition => Cond, 10945 Then_Statements => New_List ( 10946 Make_Assignment_Statement (Loc, 10947 Name => New_Occurrence_Of (Flag, Loc), 10948 Expression => 10949 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), 10950 Make_Exit_Statement (Loc)))); 10951 10952 -- Build the loop equivalent of the quantified expression 10953 10954 if Present (Iter_Spec) then 10955 Scheme := 10956 Make_Iteration_Scheme (Loc, 10957 Iterator_Specification => Iter_Spec); 10958 else 10959 Scheme := 10960 Make_Iteration_Scheme (Loc, 10961 Loop_Parameter_Specification => Loop_Spec); 10962 end if; 10963 10964 Append_To (Actions, 10965 Make_Loop_Statement (Loc, 10966 Iteration_Scheme => Scheme, 10967 Statements => Stmts, 10968 End_Label => Empty)); 10969 10970 -- Transform the quantified expression 10971 10972 Rewrite (N, 10973 Make_Expression_With_Actions (Loc, 10974 Expression => New_Occurrence_Of (Flag, Loc), 10975 Actions => Actions)); 10976 Analyze_And_Resolve (N, Standard_Boolean); 10977 end Expand_N_Quantified_Expression; 10978 10979 --------------------------------- 10980 -- Expand_N_Selected_Component -- 10981 --------------------------------- 10982 10983 procedure Expand_N_Selected_Component (N : Node_Id) is 10984 Loc : constant Source_Ptr := Sloc (N); 10985 Par : constant Node_Id := Parent (N); 10986 P : constant Node_Id := Prefix (N); 10987 S : constant Node_Id := Selector_Name (N); 10988 Ptyp : constant Entity_Id := Underlying_Type (Etype (P)); 10989 Disc : Entity_Id; 10990 New_N : Node_Id; 10991 Dcon : Elmt_Id; 10992 Dval : Node_Id; 10993 10994 function In_Left_Hand_Side (Comp : Node_Id) return Boolean; 10995 -- Gigi needs a temporary for prefixes that depend on a discriminant, 10996 -- unless the context of an assignment can provide size information. 10997 -- Don't we have a general routine that does this??? 10998 10999 function Is_Subtype_Declaration return Boolean; 11000 -- The replacement of a discriminant reference by its value is required 11001 -- if this is part of the initialization of an temporary generated by a 11002 -- change of representation. This shows up as the construction of a 11003 -- discriminant constraint for a subtype declared at the same point as 11004 -- the entity in the prefix of the selected component. We recognize this 11005 -- case when the context of the reference is: 11006 -- subtype ST is T(Obj.D); 11007 -- where the entity for Obj comes from source, and ST has the same sloc. 11008 11009 ----------------------- 11010 -- In_Left_Hand_Side -- 11011 ----------------------- 11012 11013 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is 11014 begin 11015 return (Nkind (Parent (Comp)) = N_Assignment_Statement 11016 and then Comp = Name (Parent (Comp))) 11017 or else (Present (Parent (Comp)) 11018 and then Nkind (Parent (Comp)) in N_Subexpr 11019 and then In_Left_Hand_Side (Parent (Comp))); 11020 end In_Left_Hand_Side; 11021 11022 ----------------------------- 11023 -- Is_Subtype_Declaration -- 11024 ----------------------------- 11025 11026 function Is_Subtype_Declaration return Boolean is 11027 Par : constant Node_Id := Parent (N); 11028 begin 11029 return 11030 Nkind (Par) = N_Index_Or_Discriminant_Constraint 11031 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration 11032 and then Comes_From_Source (Entity (Prefix (N))) 11033 and then Sloc (Par) = Sloc (Entity (Prefix (N))); 11034 end Is_Subtype_Declaration; 11035 11036 -- Start of processing for Expand_N_Selected_Component 11037 11038 begin 11039 -- Deal with discriminant check required 11040 11041 if Do_Discriminant_Check (N) then 11042 if Present (Discriminant_Checking_Func 11043 (Original_Record_Component (Entity (S)))) 11044 then 11045 -- Present the discriminant checking function to the backend, so 11046 -- that it can inline the call to the function. 11047 11048 Add_Inlined_Body 11049 (Discriminant_Checking_Func 11050 (Original_Record_Component (Entity (S))), 11051 N); 11052 11053 -- Now reset the flag and generate the call 11054 11055 Set_Do_Discriminant_Check (N, False); 11056 Generate_Discriminant_Check (N); 11057 11058 -- In the case of Unchecked_Union, no discriminant checking is 11059 -- actually performed. 11060 11061 else 11062 Set_Do_Discriminant_Check (N, False); 11063 end if; 11064 end if; 11065 11066 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 11067 -- function, then additional actuals must be passed. 11068 11069 if Is_Build_In_Place_Function_Call (P) then 11070 Make_Build_In_Place_Call_In_Anonymous_Context (P); 11071 11072 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 11073 -- containing build-in-place function calls whose returned object covers 11074 -- interface types. 11075 11076 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then 11077 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); 11078 end if; 11079 11080 -- Gigi cannot handle unchecked conversions that are the prefix of a 11081 -- selected component with discriminants. This must be checked during 11082 -- expansion, because during analysis the type of the selector is not 11083 -- known at the point the prefix is analyzed. If the conversion is the 11084 -- target of an assignment, then we cannot force the evaluation. 11085 11086 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion 11087 and then Has_Discriminants (Etype (N)) 11088 and then not In_Left_Hand_Side (N) 11089 then 11090 Force_Evaluation (Prefix (N)); 11091 end if; 11092 11093 -- Remaining processing applies only if selector is a discriminant 11094 11095 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then 11096 11097 -- If the selector is a discriminant of a constrained record type, 11098 -- we may be able to rewrite the expression with the actual value 11099 -- of the discriminant, a useful optimization in some cases. 11100 11101 if Is_Record_Type (Ptyp) 11102 and then Has_Discriminants (Ptyp) 11103 and then Is_Constrained (Ptyp) 11104 then 11105 -- Do this optimization for discrete types only, and not for 11106 -- access types (access discriminants get us into trouble). 11107 11108 if not Is_Discrete_Type (Etype (N)) then 11109 null; 11110 11111 -- Don't do this on the left-hand side of an assignment statement. 11112 -- Normally one would think that references like this would not 11113 -- occur, but they do in generated code, and mean that we really 11114 -- do want to assign the discriminant. 11115 11116 elsif Nkind (Par) = N_Assignment_Statement 11117 and then Name (Par) = N 11118 then 11119 null; 11120 11121 -- Don't do this optimization for the prefix of an attribute or 11122 -- the name of an object renaming declaration since these are 11123 -- contexts where we do not want the value anyway. 11124 11125 elsif (Nkind (Par) = N_Attribute_Reference 11126 and then Prefix (Par) = N) 11127 or else Is_Renamed_Object (N) 11128 then 11129 null; 11130 11131 -- Don't do this optimization if we are within the code for a 11132 -- discriminant check, since the whole point of such a check may 11133 -- be to verify the condition on which the code below depends. 11134 11135 elsif Is_In_Discriminant_Check (N) then 11136 null; 11137 11138 -- Green light to see if we can do the optimization. There is 11139 -- still one condition that inhibits the optimization below but 11140 -- now is the time to check the particular discriminant. 11141 11142 else 11143 -- Loop through discriminants to find the matching discriminant 11144 -- constraint to see if we can copy it. 11145 11146 Disc := First_Discriminant (Ptyp); 11147 Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); 11148 Discr_Loop : while Present (Dcon) loop 11149 Dval := Node (Dcon); 11150 11151 -- Check if this is the matching discriminant and if the 11152 -- discriminant value is simple enough to make sense to 11153 -- copy. We don't want to copy complex expressions, and 11154 -- indeed to do so can cause trouble (before we put in 11155 -- this guard, a discriminant expression containing an 11156 -- AND THEN was copied, causing problems for coverage 11157 -- analysis tools). 11158 11159 -- However, if the reference is part of the initialization 11160 -- code generated for an object declaration, we must use 11161 -- the discriminant value from the subtype constraint, 11162 -- because the selected component may be a reference to the 11163 -- object being initialized, whose discriminant is not yet 11164 -- set. This only happens in complex cases involving changes 11165 -- of representation. 11166 11167 if Disc = Entity (Selector_Name (N)) 11168 and then (Is_Entity_Name (Dval) 11169 or else Compile_Time_Known_Value (Dval) 11170 or else Is_Subtype_Declaration) 11171 then 11172 -- Here we have the matching discriminant. Check for 11173 -- the case of a discriminant of a component that is 11174 -- constrained by an outer discriminant, which cannot 11175 -- be optimized away. 11176 11177 if Denotes_Discriminant (Dval, Check_Concurrent => True) 11178 then 11179 exit Discr_Loop; 11180 11181 -- Do not retrieve value if constraint is not static. It 11182 -- is generally not useful, and the constraint may be a 11183 -- rewritten outer discriminant in which case it is in 11184 -- fact incorrect. 11185 11186 elsif Is_Entity_Name (Dval) 11187 and then 11188 Nkind (Parent (Entity (Dval))) = N_Object_Declaration 11189 and then Present (Expression (Parent (Entity (Dval)))) 11190 and then not 11191 Is_OK_Static_Expression 11192 (Expression (Parent (Entity (Dval)))) 11193 then 11194 exit Discr_Loop; 11195 11196 -- In the context of a case statement, the expression may 11197 -- have the base type of the discriminant, and we need to 11198 -- preserve the constraint to avoid spurious errors on 11199 -- missing cases. 11200 11201 elsif Nkind (Parent (N)) = N_Case_Statement 11202 and then Etype (Dval) /= Etype (Disc) 11203 then 11204 Rewrite (N, 11205 Make_Qualified_Expression (Loc, 11206 Subtype_Mark => 11207 New_Occurrence_Of (Etype (Disc), Loc), 11208 Expression => 11209 New_Copy_Tree (Dval))); 11210 Analyze_And_Resolve (N, Etype (Disc)); 11211 11212 -- In case that comes out as a static expression, 11213 -- reset it (a selected component is never static). 11214 11215 Set_Is_Static_Expression (N, False); 11216 return; 11217 11218 -- Otherwise we can just copy the constraint, but the 11219 -- result is certainly not static. In some cases the 11220 -- discriminant constraint has been analyzed in the 11221 -- context of the original subtype indication, but for 11222 -- itypes the constraint might not have been analyzed 11223 -- yet, and this must be done now. 11224 11225 else 11226 Rewrite (N, New_Copy_Tree (Dval)); 11227 Analyze_And_Resolve (N); 11228 Set_Is_Static_Expression (N, False); 11229 return; 11230 end if; 11231 end if; 11232 11233 Next_Elmt (Dcon); 11234 Next_Discriminant (Disc); 11235 end loop Discr_Loop; 11236 11237 -- Note: the above loop should always find a matching 11238 -- discriminant, but if it does not, we just missed an 11239 -- optimization due to some glitch (perhaps a previous 11240 -- error), so ignore. 11241 11242 end if; 11243 end if; 11244 11245 -- The only remaining processing is in the case of a discriminant of 11246 -- a concurrent object, where we rewrite the prefix to denote the 11247 -- corresponding record type. If the type is derived and has renamed 11248 -- discriminants, use corresponding discriminant, which is the one 11249 -- that appears in the corresponding record. 11250 11251 if not Is_Concurrent_Type (Ptyp) then 11252 return; 11253 end if; 11254 11255 Disc := Entity (Selector_Name (N)); 11256 11257 if Is_Derived_Type (Ptyp) 11258 and then Present (Corresponding_Discriminant (Disc)) 11259 then 11260 Disc := Corresponding_Discriminant (Disc); 11261 end if; 11262 11263 New_N := 11264 Make_Selected_Component (Loc, 11265 Prefix => 11266 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp), 11267 New_Copy_Tree (P)), 11268 Selector_Name => Make_Identifier (Loc, Chars (Disc))); 11269 11270 Rewrite (N, New_N); 11271 Analyze (N); 11272 end if; 11273 11274 -- Set Atomic_Sync_Required if necessary for atomic component 11275 11276 if Nkind (N) = N_Selected_Component then 11277 declare 11278 E : constant Entity_Id := Entity (Selector_Name (N)); 11279 Set : Boolean; 11280 11281 begin 11282 -- If component is atomic, but type is not, setting depends on 11283 -- disable/enable state for the component. 11284 11285 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then 11286 Set := not Atomic_Synchronization_Disabled (E); 11287 11288 -- If component is not atomic, but its type is atomic, setting 11289 -- depends on disable/enable state for the type. 11290 11291 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then 11292 Set := not Atomic_Synchronization_Disabled (Etype (E)); 11293 11294 -- If both component and type are atomic, we disable if either 11295 -- component or its type have sync disabled. 11296 11297 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then 11298 Set := (not Atomic_Synchronization_Disabled (E)) 11299 and then 11300 (not Atomic_Synchronization_Disabled (Etype (E))); 11301 11302 else 11303 Set := False; 11304 end if; 11305 11306 -- Set flag if required 11307 11308 if Set then 11309 Activate_Atomic_Synchronization (N); 11310 end if; 11311 end; 11312 end if; 11313 end Expand_N_Selected_Component; 11314 11315 -------------------- 11316 -- Expand_N_Slice -- 11317 -------------------- 11318 11319 procedure Expand_N_Slice (N : Node_Id) is 11320 Loc : constant Source_Ptr := Sloc (N); 11321 Typ : constant Entity_Id := Etype (N); 11322 11323 function Is_Procedure_Actual (N : Node_Id) return Boolean; 11324 -- Check whether the argument is an actual for a procedure call, in 11325 -- which case the expansion of a bit-packed slice is deferred until the 11326 -- call itself is expanded. The reason this is required is that we might 11327 -- have an IN OUT or OUT parameter, and the copy out is essential, and 11328 -- that copy out would be missed if we created a temporary here in 11329 -- Expand_N_Slice. Note that we don't bother to test specifically for an 11330 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it 11331 -- is harmless to defer expansion in the IN case, since the call 11332 -- processing will still generate the appropriate copy in operation, 11333 -- which will take care of the slice. 11334 11335 procedure Make_Temporary_For_Slice; 11336 -- Create a named variable for the value of the slice, in cases where 11337 -- the back end cannot handle it properly, e.g. when packed types or 11338 -- unaligned slices are involved. 11339 11340 ------------------------- 11341 -- Is_Procedure_Actual -- 11342 ------------------------- 11343 11344 function Is_Procedure_Actual (N : Node_Id) return Boolean is 11345 Par : Node_Id := Parent (N); 11346 11347 begin 11348 loop 11349 -- If our parent is a procedure call we can return 11350 11351 if Nkind (Par) = N_Procedure_Call_Statement then 11352 return True; 11353 11354 -- If our parent is a type conversion, keep climbing the tree, 11355 -- since a type conversion can be a procedure actual. Also keep 11356 -- climbing if parameter association or a qualified expression, 11357 -- since these are additional cases that do can appear on 11358 -- procedure actuals. 11359 11360 elsif Nkind (Par) in N_Type_Conversion 11361 | N_Parameter_Association 11362 | N_Qualified_Expression 11363 then 11364 Par := Parent (Par); 11365 11366 -- Any other case is not what we are looking for 11367 11368 else 11369 return False; 11370 end if; 11371 end loop; 11372 end Is_Procedure_Actual; 11373 11374 ------------------------------ 11375 -- Make_Temporary_For_Slice -- 11376 ------------------------------ 11377 11378 procedure Make_Temporary_For_Slice is 11379 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); 11380 Decl : Node_Id; 11381 11382 begin 11383 Decl := 11384 Make_Object_Declaration (Loc, 11385 Defining_Identifier => Ent, 11386 Object_Definition => New_Occurrence_Of (Typ, Loc)); 11387 11388 Set_No_Initialization (Decl); 11389 11390 Insert_Actions (N, New_List ( 11391 Decl, 11392 Make_Assignment_Statement (Loc, 11393 Name => New_Occurrence_Of (Ent, Loc), 11394 Expression => Relocate_Node (N)))); 11395 11396 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 11397 Analyze_And_Resolve (N, Typ); 11398 end Make_Temporary_For_Slice; 11399 11400 -- Local variables 11401 11402 Pref : constant Node_Id := Prefix (N); 11403 11404 -- Start of processing for Expand_N_Slice 11405 11406 begin 11407 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place 11408 -- function, then additional actuals must be passed. 11409 11410 if Is_Build_In_Place_Function_Call (Pref) then 11411 Make_Build_In_Place_Call_In_Anonymous_Context (Pref); 11412 11413 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix 11414 -- containing build-in-place function calls whose returned object covers 11415 -- interface types. 11416 11417 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then 11418 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); 11419 end if; 11420 11421 -- The remaining case to be handled is packed slices. We can leave 11422 -- packed slices as they are in the following situations: 11423 11424 -- 1. Right or left side of an assignment (we can handle this 11425 -- situation correctly in the assignment statement expansion). 11426 11427 -- 2. Prefix of indexed component (the slide is optimized away in this 11428 -- case, see the start of Expand_N_Slice.) 11429 11430 -- 3. Object renaming declaration, since we want the name of the 11431 -- slice, not the value. 11432 11433 -- 4. Argument to procedure call, since copy-in/copy-out handling may 11434 -- be required, and this is handled in the expansion of call 11435 -- itself. 11436 11437 -- 5. Prefix of an address attribute (this is an error which is caught 11438 -- elsewhere, and the expansion would interfere with generating the 11439 -- error message) or of a size attribute (because 'Size may change 11440 -- when applied to the temporary instead of the slice directly). 11441 11442 if not Is_Packed (Typ) then 11443 11444 -- Apply transformation for actuals of a function call, where 11445 -- Expand_Actuals is not used. 11446 11447 if Nkind (Parent (N)) = N_Function_Call 11448 and then Is_Possibly_Unaligned_Slice (N) 11449 then 11450 Make_Temporary_For_Slice; 11451 end if; 11452 11453 elsif Nkind (Parent (N)) = N_Assignment_Statement 11454 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement 11455 and then Parent (N) = Name (Parent (Parent (N)))) 11456 then 11457 return; 11458 11459 elsif Nkind (Parent (N)) = N_Indexed_Component 11460 or else Is_Renamed_Object (N) 11461 or else Is_Procedure_Actual (N) 11462 then 11463 return; 11464 11465 elsif Nkind (Parent (N)) = N_Attribute_Reference 11466 and then (Attribute_Name (Parent (N)) = Name_Address 11467 or else Attribute_Name (Parent (N)) = Name_Size) 11468 then 11469 return; 11470 11471 else 11472 Make_Temporary_For_Slice; 11473 end if; 11474 end Expand_N_Slice; 11475 11476 ------------------------------ 11477 -- Expand_N_Type_Conversion -- 11478 ------------------------------ 11479 11480 procedure Expand_N_Type_Conversion (N : Node_Id) is 11481 Loc : constant Source_Ptr := Sloc (N); 11482 Operand : constant Node_Id := Expression (N); 11483 Operand_Acc : Node_Id := Operand; 11484 Target_Type : Entity_Id := Etype (N); 11485 Operand_Type : Entity_Id := Etype (Operand); 11486 11487 procedure Discrete_Range_Check; 11488 -- Handles generation of range check for discrete target value 11489 11490 procedure Handle_Changed_Representation; 11491 -- This is called in the case of record and array type conversions to 11492 -- see if there is a change of representation to be handled. Change of 11493 -- representation is actually handled at the assignment statement level, 11494 -- and what this procedure does is rewrite node N conversion as an 11495 -- assignment to temporary. If there is no change of representation, 11496 -- then the conversion node is unchanged. 11497 11498 procedure Raise_Accessibility_Error; 11499 -- Called when we know that an accessibility check will fail. Rewrites 11500 -- node N to an appropriate raise statement and outputs warning msgs. 11501 -- The Etype of the raise node is set to Target_Type. Note that in this 11502 -- case the rest of the processing should be skipped (i.e. the call to 11503 -- this procedure will be followed by "goto Done"). 11504 11505 procedure Real_Range_Check; 11506 -- Handles generation of range check for real target value 11507 11508 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; 11509 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully 11510 -- evaluates to True. 11511 11512 function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id) 11513 return Boolean; 11514 -- Given a target type for a conversion, determine whether the 11515 -- statically deeper accessibility rules apply to it. 11516 11517 -------------------------- 11518 -- Discrete_Range_Check -- 11519 -------------------------- 11520 11521 -- Case of conversions to a discrete type. We let Generate_Range_Check 11522 -- do the heavy lifting, after converting a fixed-point operand to an 11523 -- appropriate integer type. 11524 11525 procedure Discrete_Range_Check is 11526 Expr : Node_Id; 11527 Ityp : Entity_Id; 11528 11529 procedure Generate_Temporary; 11530 -- Generate a temporary to facilitate in the C backend the code 11531 -- generation of the unchecked conversion since the size of the 11532 -- source type may differ from the size of the target type. 11533 11534 ------------------------ 11535 -- Generate_Temporary -- 11536 ------------------------ 11537 11538 procedure Generate_Temporary is 11539 begin 11540 if Esize (Etype (Expr)) < Esize (Etype (Ityp)) then 11541 declare 11542 Exp_Type : constant Entity_Id := Ityp; 11543 Def_Id : constant Entity_Id := 11544 Make_Temporary (Loc, 'R', Expr); 11545 E : Node_Id; 11546 Res : Node_Id; 11547 11548 begin 11549 Set_Is_Internal (Def_Id); 11550 Set_Etype (Def_Id, Exp_Type); 11551 Res := New_Occurrence_Of (Def_Id, Loc); 11552 11553 E := 11554 Make_Object_Declaration (Loc, 11555 Defining_Identifier => Def_Id, 11556 Object_Definition => New_Occurrence_Of 11557 (Exp_Type, Loc), 11558 Constant_Present => True, 11559 Expression => Relocate_Node (Expr)); 11560 11561 Set_Assignment_OK (E); 11562 Insert_Action (Expr, E); 11563 11564 Set_Assignment_OK (Res, Assignment_OK (Expr)); 11565 11566 Rewrite (Expr, Res); 11567 Analyze_And_Resolve (Expr, Exp_Type); 11568 end; 11569 end if; 11570 end Generate_Temporary; 11571 11572 -- Start of processing for Discrete_Range_Check 11573 11574 begin 11575 -- Nothing more to do if conversion was rewritten 11576 11577 if Nkind (N) /= N_Type_Conversion then 11578 return; 11579 end if; 11580 11581 Expr := Expression (N); 11582 11583 -- Clear the Do_Range_Check flag on Expr 11584 11585 Set_Do_Range_Check (Expr, False); 11586 11587 -- Nothing to do if range checks suppressed 11588 11589 if Range_Checks_Suppressed (Target_Type) then 11590 return; 11591 end if; 11592 11593 -- Nothing to do if expression is an entity on which checks have been 11594 -- suppressed. 11595 11596 if Is_Entity_Name (Expr) 11597 and then Range_Checks_Suppressed (Entity (Expr)) 11598 then 11599 return; 11600 end if; 11601 11602 -- Before we do a range check, we have to deal with treating 11603 -- a fixed-point operand as an integer. The way we do this 11604 -- is simply to do an unchecked conversion to an appropriate 11605 -- integer type with the smallest size, so that we can suppress 11606 -- trivial checks. 11607 11608 if Is_Fixed_Point_Type (Etype (Expr)) then 11609 Ityp := Small_Integer_Type_For 11610 (Esize (Base_Type (Etype (Expr))), False); 11611 11612 -- Generate a temporary with the integer type to facilitate in the 11613 -- C backend the code generation for the unchecked conversion. 11614 11615 if Modify_Tree_For_C then 11616 Generate_Temporary; 11617 end if; 11618 11619 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); 11620 end if; 11621 11622 -- Reset overflow flag, since the range check will include 11623 -- dealing with possible overflow, and generate the check. 11624 11625 Set_Do_Overflow_Check (N, False); 11626 11627 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed); 11628 end Discrete_Range_Check; 11629 11630 ----------------------------------- 11631 -- Handle_Changed_Representation -- 11632 ----------------------------------- 11633 11634 procedure Handle_Changed_Representation is 11635 Temp : Entity_Id; 11636 Decl : Node_Id; 11637 Odef : Node_Id; 11638 N_Ix : Node_Id; 11639 Cons : List_Id; 11640 11641 begin 11642 -- Nothing else to do if no change of representation 11643 11644 if Has_Compatible_Representation (Target_Type, Operand_Type) then 11645 return; 11646 11647 -- The real change of representation work is done by the assignment 11648 -- statement processing. So if this type conversion is appearing as 11649 -- the expression of an assignment statement, nothing needs to be 11650 -- done to the conversion. 11651 11652 elsif Nkind (Parent (N)) = N_Assignment_Statement then 11653 return; 11654 11655 -- Otherwise we need to generate a temporary variable, and do the 11656 -- change of representation assignment into that temporary variable. 11657 -- The conversion is then replaced by a reference to this variable. 11658 11659 else 11660 Cons := No_List; 11661 11662 -- If type is unconstrained we have to add a constraint, copied 11663 -- from the actual value of the left-hand side. 11664 11665 if not Is_Constrained (Target_Type) then 11666 if Has_Discriminants (Operand_Type) then 11667 11668 -- A change of representation can only apply to untagged 11669 -- types. We need to build the constraint that applies to 11670 -- the target type, using the constraints of the operand. 11671 -- The analysis is complicated if there are both inherited 11672 -- discriminants and constrained discriminants. 11673 -- We iterate over the discriminants of the target, and 11674 -- find the discriminant of the same name: 11675 11676 -- a) If there is a corresponding discriminant in the object 11677 -- then the value is a selected component of the operand. 11678 11679 -- b) Otherwise the value of a constrained discriminant is 11680 -- found in the stored constraint of the operand. 11681 11682 declare 11683 Stored : constant Elist_Id := 11684 Stored_Constraint (Operand_Type); 11685 11686 Elmt : Elmt_Id; 11687 11688 Disc_O : Entity_Id; 11689 -- Discriminant of the operand type. Its value in the 11690 -- object is captured in a selected component. 11691 11692 Disc_S : Entity_Id; 11693 -- Stored discriminant of the operand. If present, it 11694 -- corresponds to a constrained discriminant of the 11695 -- parent type. 11696 11697 Disc_T : Entity_Id; 11698 -- Discriminant of the target type 11699 11700 begin 11701 Disc_T := First_Discriminant (Target_Type); 11702 Disc_O := First_Discriminant (Operand_Type); 11703 Disc_S := First_Stored_Discriminant (Operand_Type); 11704 11705 if Present (Stored) then 11706 Elmt := First_Elmt (Stored); 11707 else 11708 Elmt := No_Elmt; -- init to avoid warning 11709 end if; 11710 11711 Cons := New_List; 11712 while Present (Disc_T) loop 11713 if Present (Disc_O) 11714 and then Chars (Disc_T) = Chars (Disc_O) 11715 then 11716 Append_To (Cons, 11717 Make_Selected_Component (Loc, 11718 Prefix => 11719 Duplicate_Subexpr_Move_Checks (Operand), 11720 Selector_Name => 11721 Make_Identifier (Loc, Chars (Disc_O)))); 11722 Next_Discriminant (Disc_O); 11723 11724 elsif Present (Disc_S) then 11725 Append_To (Cons, New_Copy_Tree (Node (Elmt))); 11726 Next_Elmt (Elmt); 11727 end if; 11728 11729 Next_Discriminant (Disc_T); 11730 end loop; 11731 end; 11732 11733 elsif Is_Array_Type (Operand_Type) then 11734 N_Ix := First_Index (Target_Type); 11735 Cons := New_List; 11736 11737 for J in 1 .. Number_Dimensions (Operand_Type) loop 11738 11739 -- We convert the bounds explicitly. We use an unchecked 11740 -- conversion because bounds checks are done elsewhere. 11741 11742 Append_To (Cons, 11743 Make_Range (Loc, 11744 Low_Bound => 11745 Unchecked_Convert_To (Etype (N_Ix), 11746 Make_Attribute_Reference (Loc, 11747 Prefix => 11748 Duplicate_Subexpr_No_Checks 11749 (Operand, Name_Req => True), 11750 Attribute_Name => Name_First, 11751 Expressions => New_List ( 11752 Make_Integer_Literal (Loc, J)))), 11753 11754 High_Bound => 11755 Unchecked_Convert_To (Etype (N_Ix), 11756 Make_Attribute_Reference (Loc, 11757 Prefix => 11758 Duplicate_Subexpr_No_Checks 11759 (Operand, Name_Req => True), 11760 Attribute_Name => Name_Last, 11761 Expressions => New_List ( 11762 Make_Integer_Literal (Loc, J)))))); 11763 11764 Next_Index (N_Ix); 11765 end loop; 11766 end if; 11767 end if; 11768 11769 Odef := New_Occurrence_Of (Target_Type, Loc); 11770 11771 if Present (Cons) then 11772 Odef := 11773 Make_Subtype_Indication (Loc, 11774 Subtype_Mark => Odef, 11775 Constraint => 11776 Make_Index_Or_Discriminant_Constraint (Loc, 11777 Constraints => Cons)); 11778 end if; 11779 11780 Temp := Make_Temporary (Loc, 'C'); 11781 Decl := 11782 Make_Object_Declaration (Loc, 11783 Defining_Identifier => Temp, 11784 Object_Definition => Odef); 11785 11786 Set_No_Initialization (Decl, True); 11787 11788 -- Insert required actions. It is essential to suppress checks 11789 -- since we have suppressed default initialization, which means 11790 -- that the variable we create may have no discriminants. 11791 11792 Insert_Actions (N, 11793 New_List ( 11794 Decl, 11795 Make_Assignment_Statement (Loc, 11796 Name => New_Occurrence_Of (Temp, Loc), 11797 Expression => Relocate_Node (N))), 11798 Suppress => All_Checks); 11799 11800 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 11801 return; 11802 end if; 11803 end Handle_Changed_Representation; 11804 11805 ------------------------------- 11806 -- Raise_Accessibility_Error -- 11807 ------------------------------- 11808 11809 procedure Raise_Accessibility_Error is 11810 begin 11811 Error_Msg_Warn := SPARK_Mode /= On; 11812 Rewrite (N, 11813 Make_Raise_Program_Error (Sloc (N), 11814 Reason => PE_Accessibility_Check_Failed)); 11815 Set_Etype (N, Target_Type); 11816 11817 Error_Msg_N ("<<accessibility check failure", N); 11818 Error_Msg_NE ("\<<& [", N, Standard_Program_Error); 11819 end Raise_Accessibility_Error; 11820 11821 ---------------------- 11822 -- Real_Range_Check -- 11823 ---------------------- 11824 11825 -- Case of conversions to floating-point or fixed-point. If range checks 11826 -- are enabled and the target type has a range constraint, we convert: 11827 11828 -- typ (x) 11829 11830 -- to 11831 11832 -- Tnn : typ'Base := typ'Base (x); 11833 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] 11834 -- typ (Tnn) 11835 11836 -- This is necessary when there is a conversion of integer to float or 11837 -- to fixed-point to ensure that the correct checks are made. It is not 11838 -- necessary for the float-to-float case where it is enough to just set 11839 -- the Do_Range_Check flag on the expression. 11840 11841 procedure Real_Range_Check is 11842 Btyp : constant Entity_Id := Base_Type (Target_Type); 11843 Lo : constant Node_Id := Type_Low_Bound (Target_Type); 11844 Hi : constant Node_Id := Type_High_Bound (Target_Type); 11845 11846 Conv : Node_Id; 11847 Hi_Arg : Node_Id; 11848 Hi_Val : Node_Id; 11849 Lo_Arg : Node_Id; 11850 Lo_Val : Node_Id; 11851 Expr : Entity_Id; 11852 Tnn : Entity_Id; 11853 11854 begin 11855 -- Nothing more to do if conversion was rewritten 11856 11857 if Nkind (N) /= N_Type_Conversion then 11858 return; 11859 end if; 11860 11861 Expr := Expression (N); 11862 11863 -- Clear the Do_Range_Check flag on Expr 11864 11865 Set_Do_Range_Check (Expr, False); 11866 11867 -- Nothing to do if range checks suppressed, or target has the same 11868 -- range as the base type (or is the base type). 11869 11870 if Range_Checks_Suppressed (Target_Type) 11871 or else (Lo = Type_Low_Bound (Btyp) 11872 and then 11873 Hi = Type_High_Bound (Btyp)) 11874 then 11875 return; 11876 end if; 11877 11878 -- Nothing to do if expression is an entity on which checks have been 11879 -- suppressed. 11880 11881 if Is_Entity_Name (Expr) 11882 and then Range_Checks_Suppressed (Entity (Expr)) 11883 then 11884 return; 11885 end if; 11886 11887 -- Nothing to do if expression was rewritten into a float-to-float 11888 -- conversion, since this kind of conversion is handled elsewhere. 11889 11890 if Is_Floating_Point_Type (Etype (Expr)) 11891 and then Is_Floating_Point_Type (Target_Type) 11892 then 11893 return; 11894 end if; 11895 11896 -- Nothing to do if bounds are all static and we can tell that the 11897 -- expression is within the bounds of the target. Note that if the 11898 -- operand is of an unconstrained floating-point type, then we do 11899 -- not trust it to be in range (might be infinite) 11900 11901 declare 11902 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr)); 11903 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr)); 11904 11905 begin 11906 if (not Is_Floating_Point_Type (Etype (Expr)) 11907 or else Is_Constrained (Etype (Expr))) 11908 and then Compile_Time_Known_Value (S_Lo) 11909 and then Compile_Time_Known_Value (S_Hi) 11910 and then Compile_Time_Known_Value (Hi) 11911 and then Compile_Time_Known_Value (Lo) 11912 then 11913 declare 11914 D_Lov : constant Ureal := Expr_Value_R (Lo); 11915 D_Hiv : constant Ureal := Expr_Value_R (Hi); 11916 S_Lov : Ureal; 11917 S_Hiv : Ureal; 11918 11919 begin 11920 if Is_Real_Type (Etype (Expr)) then 11921 S_Lov := Expr_Value_R (S_Lo); 11922 S_Hiv := Expr_Value_R (S_Hi); 11923 else 11924 S_Lov := UR_From_Uint (Expr_Value (S_Lo)); 11925 S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); 11926 end if; 11927 11928 if D_Hiv > D_Lov 11929 and then S_Lov >= D_Lov 11930 and then S_Hiv <= D_Hiv 11931 then 11932 return; 11933 end if; 11934 end; 11935 end if; 11936 end; 11937 11938 -- Otherwise rewrite the conversion as described above 11939 11940 Conv := Convert_To (Btyp, Expr); 11941 11942 -- If a conversion is necessary, then copy the specific flags from 11943 -- the original one and also move the Do_Overflow_Check flag since 11944 -- this new conversion is to the base type. 11945 11946 if Nkind (Conv) = N_Type_Conversion then 11947 Set_Conversion_OK (Conv, Conversion_OK (N)); 11948 Set_Float_Truncate (Conv, Float_Truncate (N)); 11949 Set_Rounded_Result (Conv, Rounded_Result (N)); 11950 11951 if Do_Overflow_Check (N) then 11952 Set_Do_Overflow_Check (Conv); 11953 Set_Do_Overflow_Check (N, False); 11954 end if; 11955 end if; 11956 11957 Tnn := Make_Temporary (Loc, 'T', Conv); 11958 11959 -- For a conversion from Float to Fixed where the bounds of the 11960 -- fixed-point type are static, we can obtain a more accurate 11961 -- fixed-point value by converting the result of the floating- 11962 -- point expression to an appropriate integer type, and then 11963 -- performing an unchecked conversion to the target fixed-point 11964 -- type. The range check can then use the corresponding integer 11965 -- value of the bounds instead of requiring further conversions. 11966 -- This preserves the identity: 11967 11968 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val)) 11969 11970 -- which used to fail when Fix_Val was a bound of the type and 11971 -- the 'Small was not a representable number. 11972 -- This transformation requires an integer type large enough to 11973 -- accommodate a fixed-point value. 11974 11975 if Is_Ordinary_Fixed_Point_Type (Target_Type) 11976 and then Is_Floating_Point_Type (Etype (Expr)) 11977 and then RM_Size (Btyp) <= System_Max_Integer_Size 11978 and then Nkind (Lo) = N_Real_Literal 11979 and then Nkind (Hi) = N_Real_Literal 11980 then 11981 declare 11982 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv); 11983 Int_Typ : constant Entity_Id := 11984 Small_Integer_Type_For (RM_Size (Btyp), False); 11985 11986 begin 11987 -- Generate a temporary with the integer value. Required in the 11988 -- CCG compiler to ensure that run-time checks reference this 11989 -- integer expression (instead of the resulting fixed-point 11990 -- value because fixed-point values are handled by means of 11991 -- unsigned integer types). 11992 11993 Insert_Action (N, 11994 Make_Object_Declaration (Loc, 11995 Defining_Identifier => Expr_Id, 11996 Object_Definition => New_Occurrence_Of (Int_Typ, Loc), 11997 Constant_Present => True, 11998 Expression => 11999 Convert_To (Int_Typ, Expression (Conv)))); 12000 12001 -- Create integer objects for range checking of result. 12002 12003 Lo_Arg := 12004 Unchecked_Convert_To 12005 (Int_Typ, New_Occurrence_Of (Expr_Id, Loc)); 12006 12007 Lo_Val := 12008 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo)); 12009 12010 Hi_Arg := 12011 Unchecked_Convert_To 12012 (Int_Typ, New_Occurrence_Of (Expr_Id, Loc)); 12013 12014 Hi_Val := 12015 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi)); 12016 12017 -- Rewrite conversion as an integer conversion of the 12018 -- original floating-point expression, followed by an 12019 -- unchecked conversion to the target fixed-point type. 12020 12021 Conv := 12022 Make_Unchecked_Type_Conversion (Loc, 12023 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 12024 Expression => New_Occurrence_Of (Expr_Id, Loc)); 12025 end; 12026 12027 -- All other conversions 12028 12029 else 12030 Lo_Arg := New_Occurrence_Of (Tnn, Loc); 12031 Lo_Val := 12032 Make_Attribute_Reference (Loc, 12033 Prefix => New_Occurrence_Of (Target_Type, Loc), 12034 Attribute_Name => Name_First); 12035 12036 Hi_Arg := New_Occurrence_Of (Tnn, Loc); 12037 Hi_Val := 12038 Make_Attribute_Reference (Loc, 12039 Prefix => New_Occurrence_Of (Target_Type, Loc), 12040 Attribute_Name => Name_Last); 12041 end if; 12042 12043 -- Build code for range checking. Note that checks are suppressed 12044 -- here since we don't want a recursive range check popping up. 12045 12046 Insert_Actions (N, New_List ( 12047 Make_Object_Declaration (Loc, 12048 Defining_Identifier => Tnn, 12049 Object_Definition => New_Occurrence_Of (Btyp, Loc), 12050 Constant_Present => True, 12051 Expression => Conv), 12052 12053 Make_Raise_Constraint_Error (Loc, 12054 Condition => 12055 Make_Or_Else (Loc, 12056 Left_Opnd => 12057 Make_Op_Lt (Loc, 12058 Left_Opnd => Lo_Arg, 12059 Right_Opnd => Lo_Val), 12060 12061 Right_Opnd => 12062 Make_Op_Gt (Loc, 12063 Left_Opnd => Hi_Arg, 12064 Right_Opnd => Hi_Val)), 12065 Reason => CE_Range_Check_Failed)), 12066 Suppress => All_Checks); 12067 12068 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc)); 12069 end Real_Range_Check; 12070 12071 ----------------------------- 12072 -- Has_Extra_Accessibility -- 12073 ----------------------------- 12074 12075 -- Returns true for a formal of an anonymous access type or for an Ada 12076 -- 2012-style stand-alone object of an anonymous access type. 12077 12078 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is 12079 begin 12080 if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then 12081 return Present (Effective_Extra_Accessibility (Id)); 12082 else 12083 return False; 12084 end if; 12085 end Has_Extra_Accessibility; 12086 12087 ---------------------------------------- 12088 -- Statically_Deeper_Relation_Applies -- 12089 ---------------------------------------- 12090 12091 function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id) 12092 return Boolean 12093 is 12094 begin 12095 -- The case where the target type is an anonymous access type is 12096 -- ignored since they have different semantics and get covered by 12097 -- various runtime checks depending on context. 12098 12099 -- Note, the current implementation of this predicate is incomplete 12100 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and 12101 -- (19.1) ??? 12102 12103 return Ekind (Targ_Typ) /= E_Anonymous_Access_Type; 12104 end Statically_Deeper_Relation_Applies; 12105 12106 -- Start of processing for Expand_N_Type_Conversion 12107 12108 begin 12109 -- First remove check marks put by the semantic analysis on the type 12110 -- conversion between array types. We need these checks, and they will 12111 -- be generated by this expansion routine, but we do not depend on these 12112 -- flags being set, and since we do intend to expand the checks in the 12113 -- front end, we don't want them on the tree passed to the back end. 12114 12115 if Is_Array_Type (Target_Type) then 12116 if Is_Constrained (Target_Type) then 12117 Set_Do_Length_Check (N, False); 12118 else 12119 Set_Do_Range_Check (Operand, False); 12120 end if; 12121 end if; 12122 12123 -- Nothing at all to do if conversion is to the identical type so remove 12124 -- the conversion completely, it is useless, except that it may carry 12125 -- an Assignment_OK attribute, which must be propagated to the operand 12126 -- and the Do_Range_Check flag on the operand must be cleared, if any. 12127 12128 if Operand_Type = Target_Type then 12129 if Assignment_OK (N) then 12130 Set_Assignment_OK (Operand); 12131 end if; 12132 12133 Set_Do_Range_Check (Operand, False); 12134 12135 Rewrite (N, Relocate_Node (Operand)); 12136 12137 goto Done; 12138 end if; 12139 12140 -- Nothing to do if this is the second argument of read. This is a 12141 -- "backwards" conversion that will be handled by the specialized code 12142 -- in attribute processing. 12143 12144 if Nkind (Parent (N)) = N_Attribute_Reference 12145 and then Attribute_Name (Parent (N)) = Name_Read 12146 and then Next (First (Expressions (Parent (N)))) = N 12147 then 12148 goto Done; 12149 end if; 12150 12151 -- Check for case of converting to a type that has an invariant 12152 -- associated with it. This requires an invariant check. We insert 12153 -- a call: 12154 12155 -- invariant_check (typ (expr)) 12156 12157 -- in the code, after removing side effects from the expression. 12158 -- This is clearer than replacing the conversion into an expression 12159 -- with actions, because the context may impose additional actions 12160 -- (tag checks, membership tests, etc.) that conflict with this 12161 -- rewriting (used previously). 12162 12163 -- Note: the Comes_From_Source check, and then the resetting of this 12164 -- flag prevents what would otherwise be an infinite recursion. 12165 12166 if Has_Invariants (Target_Type) 12167 and then Present (Invariant_Procedure (Target_Type)) 12168 and then Comes_From_Source (N) 12169 then 12170 Set_Comes_From_Source (N, False); 12171 Remove_Side_Effects (N); 12172 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N))); 12173 goto Done; 12174 12175 -- AI12-0042: For a view conversion to a class-wide type occurring 12176 -- within the immediate scope of T, from a specific type that is 12177 -- a descendant of T (including T itself), an invariant check is 12178 -- performed on the part of the object that is of type T. (We don't 12179 -- need to explicitly check for the operand type being a descendant, 12180 -- just that it's a specific type, because the conversion would be 12181 -- illegal if it's specific and not a descendant -- downward conversion 12182 -- is not allowed). 12183 12184 elsif Is_Class_Wide_Type (Target_Type) 12185 and then not Is_Class_Wide_Type (Etype (Expression (N))) 12186 and then Present (Invariant_Procedure (Root_Type (Target_Type))) 12187 and then Comes_From_Source (N) 12188 and then Within_Scope (Find_Enclosing_Scope (N), Scope (Target_Type)) 12189 then 12190 Remove_Side_Effects (N); 12191 12192 -- Perform the invariant check on a conversion to the class-wide 12193 -- type's root type. 12194 12195 declare 12196 Root_Conv : constant Node_Id := 12197 Make_Type_Conversion (Loc, 12198 Subtype_Mark => 12199 New_Occurrence_Of (Root_Type (Target_Type), Loc), 12200 Expression => Duplicate_Subexpr (Expression (N))); 12201 begin 12202 Set_Etype (Root_Conv, Root_Type (Target_Type)); 12203 12204 Insert_Action (N, Make_Invariant_Call (Root_Conv)); 12205 goto Done; 12206 end; 12207 end if; 12208 12209 -- Here if we may need to expand conversion 12210 12211 -- If the operand of the type conversion is an arithmetic operation on 12212 -- signed integers, and the based type of the signed integer type in 12213 -- question is smaller than Standard.Integer, we promote both of the 12214 -- operands to type Integer. 12215 12216 -- For example, if we have 12217 12218 -- target-type (opnd1 + opnd2) 12219 12220 -- and opnd1 and opnd2 are of type short integer, then we rewrite 12221 -- this as: 12222 12223 -- target-type (integer(opnd1) + integer(opnd2)) 12224 12225 -- We do this because we are always allowed to compute in a larger type 12226 -- if we do the right thing with the result, and in this case we are 12227 -- going to do a conversion which will do an appropriate check to make 12228 -- sure that things are in range of the target type in any case. This 12229 -- avoids some unnecessary intermediate overflows. 12230 12231 -- We might consider a similar transformation in the case where the 12232 -- target is a real type or a 64-bit integer type, and the operand 12233 -- is an arithmetic operation using a 32-bit integer type. However, 12234 -- we do not bother with this case, because it could cause significant 12235 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be 12236 -- much cheaper, but we don't want different behavior on 32-bit and 12237 -- 64-bit machines. Note that the exclusion of the 64-bit case also 12238 -- handles the configurable run-time cases where 64-bit arithmetic 12239 -- may simply be unavailable. 12240 12241 -- Note: this circuit is partially redundant with respect to the circuit 12242 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in 12243 -- the processing here. Also we still need the Checks circuit, since we 12244 -- have to be sure not to generate junk overflow checks in the first 12245 -- place, since it would be tricky to remove them here. 12246 12247 if Integer_Promotion_Possible (N) then 12248 12249 -- All conditions met, go ahead with transformation 12250 12251 declare 12252 Opnd : Node_Id; 12253 L, R : Node_Id; 12254 12255 begin 12256 Opnd := New_Op_Node (Nkind (Operand), Loc); 12257 12258 R := Convert_To (Standard_Integer, Right_Opnd (Operand)); 12259 Set_Right_Opnd (Opnd, R); 12260 12261 if Nkind (Operand) in N_Binary_Op then 12262 L := Convert_To (Standard_Integer, Left_Opnd (Operand)); 12263 Set_Left_Opnd (Opnd, L); 12264 end if; 12265 12266 Rewrite (N, 12267 Make_Type_Conversion (Loc, 12268 Subtype_Mark => Relocate_Node (Subtype_Mark (N)), 12269 Expression => Opnd)); 12270 12271 Analyze_And_Resolve (N, Target_Type); 12272 goto Done; 12273 end; 12274 end if; 12275 12276 -- Do validity check if validity checking operands 12277 12278 if Validity_Checks_On and Validity_Check_Operands then 12279 Ensure_Valid (Operand); 12280 end if; 12281 12282 -- Special case of converting from non-standard boolean type 12283 12284 if Is_Boolean_Type (Operand_Type) 12285 and then (Nonzero_Is_True (Operand_Type)) 12286 then 12287 Adjust_Condition (Operand); 12288 Set_Etype (Operand, Standard_Boolean); 12289 Operand_Type := Standard_Boolean; 12290 end if; 12291 12292 -- Case of converting to an access type 12293 12294 if Is_Access_Type (Target_Type) then 12295 -- In terms of accessibility rules, an anonymous access discriminant 12296 -- is not considered separate from its parent object. 12297 12298 if Nkind (Operand) = N_Selected_Component 12299 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant 12300 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 12301 then 12302 Operand_Acc := Original_Node (Prefix (Operand)); 12303 end if; 12304 12305 -- If this type conversion was internally generated by the front end 12306 -- to displace the pointer to the object to reference an interface 12307 -- type and the original node was an Unrestricted_Access attribute, 12308 -- then skip applying accessibility checks (because, according to the 12309 -- GNAT Reference Manual, this attribute is similar to 'Access except 12310 -- that all accessibility and aliased view checks are omitted). 12311 12312 if not Comes_From_Source (N) 12313 and then Is_Interface (Designated_Type (Target_Type)) 12314 and then Nkind (Original_Node (N)) = N_Attribute_Reference 12315 and then Attribute_Name (Original_Node (N)) = 12316 Name_Unrestricted_Access 12317 then 12318 null; 12319 12320 -- Apply an accessibility check when the conversion operand is an 12321 -- access parameter (or a renaming thereof), unless conversion was 12322 -- expanded from an Unchecked_ or Unrestricted_Access attribute, 12323 -- or for the actual of a class-wide interface parameter. Note that 12324 -- other checks may still need to be applied below (such as tagged 12325 -- type checks). 12326 12327 elsif Is_Entity_Name (Operand_Acc) 12328 and then Has_Extra_Accessibility (Entity (Operand_Acc)) 12329 and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type 12330 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference 12331 or else Attribute_Name (Original_Node (N)) = Name_Access) 12332 then 12333 if not Comes_From_Source (N) 12334 and then Nkind (Parent (N)) in N_Function_Call 12335 | N_Parameter_Association 12336 | N_Procedure_Call_Statement 12337 and then Is_Interface (Designated_Type (Target_Type)) 12338 and then Is_Class_Wide_Type (Designated_Type (Target_Type)) 12339 then 12340 null; 12341 12342 else 12343 Apply_Accessibility_Check 12344 (Operand, Target_Type, Insert_Node => Operand); 12345 end if; 12346 12347 -- If the level of the operand type is statically deeper than the 12348 -- level of the target type, then force Program_Error. Note that this 12349 -- can only occur for cases where the attribute is within the body of 12350 -- an instantiation, otherwise the conversion will already have been 12351 -- rejected as illegal. 12352 12353 -- Note: warnings are issued by the analyzer for the instance cases 12354 12355 elsif In_Instance_Body 12356 and then Statically_Deeper_Relation_Applies (Target_Type) 12357 and then 12358 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) 12359 then 12360 Raise_Accessibility_Error; 12361 goto Done; 12362 12363 -- When the operand is a selected access discriminant the check needs 12364 -- to be made against the level of the object denoted by the prefix 12365 -- of the selected name. Force Program_Error for this case as well 12366 -- (this accessibility violation can only happen if within the body 12367 -- of an instantiation). 12368 12369 elsif In_Instance_Body 12370 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 12371 and then Nkind (Operand) = N_Selected_Component 12372 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant 12373 and then Static_Accessibility_Level (Operand, Zero_On_Dynamic_Level) 12374 > Type_Access_Level (Target_Type) 12375 then 12376 Raise_Accessibility_Error; 12377 goto Done; 12378 end if; 12379 end if; 12380 12381 -- Case of conversions of tagged types and access to tagged types 12382 12383 -- When needed, that is to say when the expression is class-wide, Add 12384 -- runtime a tag check for (strict) downward conversion by using the 12385 -- membership test, generating: 12386 12387 -- [constraint_error when Operand not in Target_Type'Class] 12388 12389 -- or in the access type case 12390 12391 -- [constraint_error 12392 -- when Operand /= null 12393 -- and then Operand.all not in 12394 -- Designated_Type (Target_Type)'Class] 12395 12396 if (Is_Access_Type (Target_Type) 12397 and then Is_Tagged_Type (Designated_Type (Target_Type))) 12398 or else Is_Tagged_Type (Target_Type) 12399 then 12400 -- Do not do any expansion in the access type case if the parent is a 12401 -- renaming, since this is an error situation which will be caught by 12402 -- Sem_Ch8, and the expansion can interfere with this error check. 12403 12404 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then 12405 goto Done; 12406 end if; 12407 12408 -- Otherwise, proceed with processing tagged conversion 12409 12410 Tagged_Conversion : declare 12411 Actual_Op_Typ : Entity_Id; 12412 Actual_Targ_Typ : Entity_Id; 12413 Root_Op_Typ : Entity_Id; 12414 12415 procedure Make_Tag_Check (Targ_Typ : Entity_Id); 12416 -- Create a membership check to test whether Operand is a member 12417 -- of Targ_Typ. If the original Target_Type is an access, include 12418 -- a test for null value. The check is inserted at N. 12419 12420 -------------------- 12421 -- Make_Tag_Check -- 12422 -------------------- 12423 12424 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is 12425 Cond : Node_Id; 12426 12427 begin 12428 -- Generate: 12429 -- [Constraint_Error 12430 -- when Operand /= null 12431 -- and then Operand.all not in Targ_Typ] 12432 12433 if Is_Access_Type (Target_Type) then 12434 Cond := 12435 Make_And_Then (Loc, 12436 Left_Opnd => 12437 Make_Op_Ne (Loc, 12438 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 12439 Right_Opnd => Make_Null (Loc)), 12440 12441 Right_Opnd => 12442 Make_Not_In (Loc, 12443 Left_Opnd => 12444 Make_Explicit_Dereference (Loc, 12445 Prefix => Duplicate_Subexpr_No_Checks (Operand)), 12446 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc))); 12447 12448 -- Generate: 12449 -- [Constraint_Error when Operand not in Targ_Typ] 12450 12451 else 12452 Cond := 12453 Make_Not_In (Loc, 12454 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), 12455 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)); 12456 end if; 12457 12458 Insert_Action (N, 12459 Make_Raise_Constraint_Error (Loc, 12460 Condition => Cond, 12461 Reason => CE_Tag_Check_Failed), 12462 Suppress => All_Checks); 12463 end Make_Tag_Check; 12464 12465 -- Start of processing for Tagged_Conversion 12466 12467 begin 12468 -- Handle entities from the limited view 12469 12470 if Is_Access_Type (Operand_Type) then 12471 Actual_Op_Typ := 12472 Available_View (Designated_Type (Operand_Type)); 12473 else 12474 Actual_Op_Typ := Operand_Type; 12475 end if; 12476 12477 if Is_Access_Type (Target_Type) then 12478 Actual_Targ_Typ := 12479 Available_View (Designated_Type (Target_Type)); 12480 else 12481 Actual_Targ_Typ := Target_Type; 12482 end if; 12483 12484 Root_Op_Typ := Root_Type (Actual_Op_Typ); 12485 12486 -- Ada 2005 (AI-251): Handle interface type conversion 12487 12488 if Is_Interface (Actual_Op_Typ) 12489 or else 12490 Is_Interface (Actual_Targ_Typ) 12491 then 12492 Expand_Interface_Conversion (N); 12493 goto Done; 12494 end if; 12495 12496 -- Create a runtime tag check for a downward CW type conversion 12497 12498 if Is_Class_Wide_Type (Actual_Op_Typ) 12499 and then Actual_Op_Typ /= Actual_Targ_Typ 12500 and then Root_Op_Typ /= Actual_Targ_Typ 12501 and then Is_Ancestor 12502 (Root_Op_Typ, Actual_Targ_Typ, Use_Full_View => True) 12503 and then not Tag_Checks_Suppressed (Actual_Targ_Typ) 12504 then 12505 declare 12506 Conv : Node_Id; 12507 begin 12508 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); 12509 Conv := 12510 Make_Unchecked_Type_Conversion (Loc, 12511 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 12512 Expression => Relocate_Node (Expression (N))); 12513 Rewrite (N, Conv); 12514 Analyze_And_Resolve (N, Target_Type); 12515 end; 12516 end if; 12517 end Tagged_Conversion; 12518 12519 -- Case of other access type conversions 12520 12521 elsif Is_Access_Type (Target_Type) then 12522 Apply_Constraint_Check (Operand, Target_Type); 12523 12524 -- Case of conversions from a fixed-point type 12525 12526 -- These conversions require special expansion and processing, found in 12527 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, 12528 -- since from a semantic point of view, these are simple integer 12529 -- conversions, which do not need further processing except for the 12530 -- generation of range checks, which is performed at the end of this 12531 -- procedure. 12532 12533 elsif Is_Fixed_Point_Type (Operand_Type) 12534 and then not Conversion_OK (N) 12535 then 12536 -- We should never see universal fixed at this case, since the 12537 -- expansion of the constituent divide or multiply should have 12538 -- eliminated the explicit mention of universal fixed. 12539 12540 pragma Assert (Operand_Type /= Universal_Fixed); 12541 12542 -- Check for special case of the conversion to universal real that 12543 -- occurs as a result of the use of a round attribute. In this case, 12544 -- the real type for the conversion is taken from the target type of 12545 -- the Round attribute and the result must be marked as rounded. 12546 12547 if Target_Type = Universal_Real 12548 and then Nkind (Parent (N)) = N_Attribute_Reference 12549 and then Attribute_Name (Parent (N)) = Name_Round 12550 then 12551 Set_Etype (N, Etype (Parent (N))); 12552 Target_Type := Etype (N); 12553 Set_Rounded_Result (N); 12554 end if; 12555 12556 if Is_Fixed_Point_Type (Target_Type) then 12557 Expand_Convert_Fixed_To_Fixed (N); 12558 elsif Is_Integer_Type (Target_Type) then 12559 Expand_Convert_Fixed_To_Integer (N); 12560 else 12561 pragma Assert (Is_Floating_Point_Type (Target_Type)); 12562 Expand_Convert_Fixed_To_Float (N); 12563 end if; 12564 12565 -- Case of conversions to a fixed-point type 12566 12567 -- These conversions require special expansion and processing, found in 12568 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, 12569 -- since from a semantic point of view, these are simple integer 12570 -- conversions, which do not need further processing. 12571 12572 elsif Is_Fixed_Point_Type (Target_Type) 12573 and then not Conversion_OK (N) 12574 then 12575 if Is_Integer_Type (Operand_Type) then 12576 Expand_Convert_Integer_To_Fixed (N); 12577 else 12578 pragma Assert (Is_Floating_Point_Type (Operand_Type)); 12579 Expand_Convert_Float_To_Fixed (N); 12580 end if; 12581 12582 -- Case of array conversions 12583 12584 -- Expansion of array conversions, add required length/range checks but 12585 -- only do this if there is no change of representation. For handling of 12586 -- this case, see Handle_Changed_Representation. 12587 12588 elsif Is_Array_Type (Target_Type) then 12589 if Is_Constrained (Target_Type) then 12590 Apply_Length_Check (Operand, Target_Type); 12591 else 12592 Apply_Range_Check (Operand, Target_Type); 12593 end if; 12594 12595 Handle_Changed_Representation; 12596 12597 -- Case of conversions of discriminated types 12598 12599 -- Add required discriminant checks if target is constrained. Again this 12600 -- change is skipped if we have a change of representation. 12601 12602 elsif Has_Discriminants (Target_Type) 12603 and then Is_Constrained (Target_Type) 12604 then 12605 Apply_Discriminant_Check (Operand, Target_Type); 12606 Handle_Changed_Representation; 12607 12608 -- Case of all other record conversions. The only processing required 12609 -- is to check for a change of representation requiring the special 12610 -- assignment processing. 12611 12612 elsif Is_Record_Type (Target_Type) then 12613 12614 -- Ada 2005 (AI-216): Program_Error is raised when converting from 12615 -- a derived Unchecked_Union type to an unconstrained type that is 12616 -- not Unchecked_Union if the operand lacks inferable discriminants. 12617 12618 if Is_Derived_Type (Operand_Type) 12619 and then Is_Unchecked_Union (Base_Type (Operand_Type)) 12620 and then not Is_Constrained (Target_Type) 12621 and then not Is_Unchecked_Union (Base_Type (Target_Type)) 12622 and then not Has_Inferable_Discriminants (Operand) 12623 then 12624 -- To prevent Gigi from generating illegal code, we generate a 12625 -- Program_Error node, but we give it the target type of the 12626 -- conversion (is this requirement documented somewhere ???) 12627 12628 declare 12629 PE : constant Node_Id := Make_Raise_Program_Error (Loc, 12630 Reason => PE_Unchecked_Union_Restriction); 12631 12632 begin 12633 Set_Etype (PE, Target_Type); 12634 Rewrite (N, PE); 12635 12636 end; 12637 else 12638 Handle_Changed_Representation; 12639 end if; 12640 12641 -- Case of conversions of enumeration types 12642 12643 elsif Is_Enumeration_Type (Target_Type) then 12644 12645 -- Special processing is required if there is a change of 12646 -- representation (from enumeration representation clauses). 12647 12648 if not Has_Compatible_Representation (Target_Type, Operand_Type) 12649 and then not Conversion_OK (N) 12650 then 12651 12652 -- Convert: x(y) to x'val (ytyp'pos (y)) 12653 12654 Rewrite (N, 12655 Make_Attribute_Reference (Loc, 12656 Prefix => New_Occurrence_Of (Target_Type, Loc), 12657 Attribute_Name => Name_Val, 12658 Expressions => New_List ( 12659 Make_Attribute_Reference (Loc, 12660 Prefix => New_Occurrence_Of (Operand_Type, Loc), 12661 Attribute_Name => Name_Pos, 12662 Expressions => New_List (Operand))))); 12663 12664 Analyze_And_Resolve (N, Target_Type); 12665 end if; 12666 end if; 12667 12668 -- At this stage, either the conversion node has been transformed into 12669 -- some other equivalent expression, or left as a conversion that can be 12670 -- handled by Gigi, in the following cases: 12671 12672 -- Conversions with no change of representation or type 12673 12674 -- Numeric conversions involving integer, floating- and fixed-point 12675 -- values. Fixed-point values are allowed only if Conversion_OK is 12676 -- set, i.e. if the fixed-point values are to be treated as integers. 12677 12678 -- No other conversions should be passed to Gigi 12679 12680 -- Check: are these rules stated in sinfo??? if so, why restate here??? 12681 12682 -- The only remaining step is to generate a range check if we still have 12683 -- a type conversion at this stage and Do_Range_Check is set. Note that 12684 -- we need to deal with at most 8 out of the 9 possible cases of numeric 12685 -- conversions here, because the float-to-integer case is entirely dealt 12686 -- with by Apply_Float_Conversion_Check. 12687 12688 if Nkind (N) = N_Type_Conversion 12689 and then Do_Range_Check (Expression (N)) 12690 then 12691 -- Float-to-float conversions 12692 12693 if Is_Floating_Point_Type (Target_Type) 12694 and then Is_Floating_Point_Type (Etype (Expression (N))) 12695 then 12696 -- Reset overflow flag, since the range check will include 12697 -- dealing with possible overflow, and generate the check. 12698 12699 Set_Do_Overflow_Check (N, False); 12700 12701 Generate_Range_Check 12702 (Expression (N), Target_Type, CE_Range_Check_Failed); 12703 12704 -- Discrete-to-discrete conversions or fixed-point-to-discrete 12705 -- conversions when Conversion_OK is set. 12706 12707 elsif Is_Discrete_Type (Target_Type) 12708 and then (Is_Discrete_Type (Etype (Expression (N))) 12709 or else (Is_Fixed_Point_Type (Etype (Expression (N))) 12710 and then Conversion_OK (N))) 12711 then 12712 -- If Address is either a source type or target type, 12713 -- suppress range check to avoid typing anomalies when 12714 -- it is a visible integer type. 12715 12716 if Is_Descendant_Of_Address (Etype (Expression (N))) 12717 or else Is_Descendant_Of_Address (Target_Type) 12718 then 12719 Set_Do_Range_Check (Expression (N), False); 12720 else 12721 Discrete_Range_Check; 12722 end if; 12723 12724 -- Conversions to floating- or fixed-point when Conversion_OK is set 12725 12726 elsif Is_Floating_Point_Type (Target_Type) 12727 or else (Is_Fixed_Point_Type (Target_Type) 12728 and then Conversion_OK (N)) 12729 then 12730 Real_Range_Check; 12731 end if; 12732 12733 pragma Assert (not Do_Range_Check (Expression (N))); 12734 end if; 12735 12736 -- Here at end of processing 12737 12738 <<Done>> 12739 -- Apply predicate check if required. Note that we can't just call 12740 -- Apply_Predicate_Check here, because the type looks right after 12741 -- the conversion and it would omit the check. The Comes_From_Source 12742 -- guard is necessary to prevent infinite recursions when we generate 12743 -- internal conversions for the purpose of checking predicates. 12744 12745 if Predicate_Enabled (Target_Type) 12746 and then Target_Type /= Operand_Type 12747 and then Comes_From_Source (N) 12748 then 12749 declare 12750 New_Expr : constant Node_Id := Duplicate_Subexpr (N); 12751 12752 begin 12753 -- Avoid infinite recursion on the subsequent expansion of the 12754 -- copy of the original type conversion. When needed, a range 12755 -- check has already been applied to the expression. 12756 12757 Set_Comes_From_Source (New_Expr, False); 12758 Insert_Action (N, 12759 Make_Predicate_Check (Target_Type, New_Expr), 12760 Suppress => Range_Check); 12761 end; 12762 end if; 12763 end Expand_N_Type_Conversion; 12764 12765 ----------------------------------- 12766 -- Expand_N_Unchecked_Expression -- 12767 ----------------------------------- 12768 12769 -- Remove the unchecked expression node from the tree. Its job was simply 12770 -- to make sure that its constituent expression was handled with checks 12771 -- off, and now that is done, we can remove it from the tree, and indeed 12772 -- must, since Gigi does not expect to see these nodes. 12773 12774 procedure Expand_N_Unchecked_Expression (N : Node_Id) is 12775 Exp : constant Node_Id := Expression (N); 12776 begin 12777 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); 12778 Rewrite (N, Exp); 12779 end Expand_N_Unchecked_Expression; 12780 12781 ---------------------------------------- 12782 -- Expand_N_Unchecked_Type_Conversion -- 12783 ---------------------------------------- 12784 12785 -- If this cannot be handled by Gigi and we haven't already made a 12786 -- temporary for it, do it now. 12787 12788 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is 12789 Target_Type : constant Entity_Id := Etype (N); 12790 Operand : constant Node_Id := Expression (N); 12791 Operand_Type : constant Entity_Id := Etype (Operand); 12792 12793 begin 12794 -- Nothing at all to do if conversion is to the identical type so remove 12795 -- the conversion completely, it is useless, except that it may carry 12796 -- an Assignment_OK indication which must be propagated to the operand. 12797 12798 if Operand_Type = Target_Type then 12799 12800 -- Code duplicates Expand_N_Unchecked_Expression above, factor??? 12801 12802 if Assignment_OK (N) then 12803 Set_Assignment_OK (Operand); 12804 end if; 12805 12806 Rewrite (N, Relocate_Node (Operand)); 12807 return; 12808 end if; 12809 12810 -- Generate an extra temporary for cases unsupported by the C backend 12811 12812 if Modify_Tree_For_C then 12813 declare 12814 Source : constant Node_Id := Unqual_Conv (Expression (N)); 12815 Source_Typ : Entity_Id := Get_Full_View (Etype (Source)); 12816 12817 begin 12818 if Is_Packed_Array (Source_Typ) then 12819 Source_Typ := Packed_Array_Impl_Type (Source_Typ); 12820 end if; 12821 12822 if Nkind (Source) = N_Function_Call 12823 and then (Is_Composite_Type (Etype (Source)) 12824 or else Is_Composite_Type (Target_Type)) 12825 then 12826 Force_Evaluation (Source); 12827 end if; 12828 end; 12829 end if; 12830 12831 -- Nothing to do if conversion is safe 12832 12833 if Safe_Unchecked_Type_Conversion (N) then 12834 return; 12835 end if; 12836 12837 -- Otherwise force evaluation unless Assignment_OK flag is set (this 12838 -- flag indicates ??? More comments needed here) 12839 12840 if Assignment_OK (N) then 12841 null; 12842 else 12843 Force_Evaluation (N); 12844 end if; 12845 end Expand_N_Unchecked_Type_Conversion; 12846 12847 ---------------------------- 12848 -- Expand_Record_Equality -- 12849 ---------------------------- 12850 12851 -- For non-variant records, Equality is expanded when needed into: 12852 12853 -- and then Lhs.Discr1 = Rhs.Discr1 12854 -- and then ... 12855 -- and then Lhs.Discrn = Rhs.Discrn 12856 -- and then Lhs.Cmp1 = Rhs.Cmp1 12857 -- and then ... 12858 -- and then Lhs.Cmpn = Rhs.Cmpn 12859 12860 -- The expression is folded by the back end for adjacent fields. This 12861 -- function is called for tagged record in only one occasion: for imple- 12862 -- menting predefined primitive equality (see Predefined_Primitives_Bodies) 12863 -- otherwise the primitive "=" is used directly. 12864 12865 function Expand_Record_Equality 12866 (Nod : Node_Id; 12867 Typ : Entity_Id; 12868 Lhs : Node_Id; 12869 Rhs : Node_Id; 12870 Bodies : List_Id) return Node_Id 12871 is 12872 Loc : constant Source_Ptr := Sloc (Nod); 12873 12874 Result : Node_Id; 12875 C : Entity_Id; 12876 12877 First_Time : Boolean := True; 12878 12879 function Element_To_Compare (C : Entity_Id) return Entity_Id; 12880 -- Return the next discriminant or component to compare, starting with 12881 -- C, skipping inherited components. 12882 12883 ------------------------ 12884 -- Element_To_Compare -- 12885 ------------------------ 12886 12887 function Element_To_Compare (C : Entity_Id) return Entity_Id is 12888 Comp : Entity_Id; 12889 12890 begin 12891 Comp := C; 12892 loop 12893 -- Exit loop when the next element to be compared is found, or 12894 -- there is no more such element. 12895 12896 exit when No (Comp); 12897 12898 exit when Ekind (Comp) in E_Discriminant | E_Component 12899 and then not ( 12900 12901 -- Skip inherited components 12902 12903 -- Note: for a tagged type, we always generate the "=" primitive 12904 -- for the base type (not on the first subtype), so the test for 12905 -- Comp /= Original_Record_Component (Comp) is True for 12906 -- inherited components only. 12907 12908 (Is_Tagged_Type (Typ) 12909 and then Comp /= Original_Record_Component (Comp)) 12910 12911 -- Skip _Tag 12912 12913 or else Chars (Comp) = Name_uTag 12914 12915 -- Skip interface elements (secondary tags???) 12916 12917 or else Is_Interface (Etype (Comp))); 12918 12919 Next_Entity (Comp); 12920 end loop; 12921 12922 return Comp; 12923 end Element_To_Compare; 12924 12925 -- Start of processing for Expand_Record_Equality 12926 12927 begin 12928 -- Generates the following code: (assuming that Typ has one Discr and 12929 -- component C2 is also a record) 12930 12931 -- Lhs.Discr1 = Rhs.Discr1 12932 -- and then Lhs.C1 = Rhs.C1 12933 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn 12934 -- and then ... 12935 -- and then Lhs.Cmpn = Rhs.Cmpn 12936 12937 Result := New_Occurrence_Of (Standard_True, Loc); 12938 C := Element_To_Compare (First_Entity (Typ)); 12939 while Present (C) loop 12940 declare 12941 New_Lhs : Node_Id; 12942 New_Rhs : Node_Id; 12943 Check : Node_Id; 12944 12945 begin 12946 if First_Time then 12947 New_Lhs := Lhs; 12948 New_Rhs := Rhs; 12949 else 12950 New_Lhs := New_Copy_Tree (Lhs); 12951 New_Rhs := New_Copy_Tree (Rhs); 12952 end if; 12953 12954 Check := 12955 Expand_Composite_Equality (Nod, Etype (C), 12956 Lhs => 12957 Make_Selected_Component (Loc, 12958 Prefix => New_Lhs, 12959 Selector_Name => New_Occurrence_Of (C, Loc)), 12960 Rhs => 12961 Make_Selected_Component (Loc, 12962 Prefix => New_Rhs, 12963 Selector_Name => New_Occurrence_Of (C, Loc)), 12964 Bodies => Bodies); 12965 12966 -- If some (sub)component is an unchecked_union, the whole 12967 -- operation will raise program error. 12968 12969 if Nkind (Check) = N_Raise_Program_Error then 12970 Result := Check; 12971 Set_Etype (Result, Standard_Boolean); 12972 exit; 12973 else 12974 if First_Time then 12975 Result := Check; 12976 12977 -- Generate logical "and" for CodePeer to simplify the 12978 -- generated code and analysis. 12979 12980 elsif CodePeer_Mode then 12981 Result := 12982 Make_Op_And (Loc, 12983 Left_Opnd => Result, 12984 Right_Opnd => Check); 12985 12986 else 12987 Result := 12988 Make_And_Then (Loc, 12989 Left_Opnd => Result, 12990 Right_Opnd => Check); 12991 end if; 12992 end if; 12993 end; 12994 12995 First_Time := False; 12996 C := Element_To_Compare (Next_Entity (C)); 12997 end loop; 12998 12999 return Result; 13000 end Expand_Record_Equality; 13001 13002 --------------------------- 13003 -- Expand_Set_Membership -- 13004 --------------------------- 13005 13006 procedure Expand_Set_Membership (N : Node_Id) is 13007 Lop : constant Node_Id := Left_Opnd (N); 13008 Alt : Node_Id; 13009 Res : Node_Id; 13010 13011 function Make_Cond (Alt : Node_Id) return Node_Id; 13012 -- If the alternative is a subtype mark, create a simple membership 13013 -- test. Otherwise create an equality test for it. 13014 13015 --------------- 13016 -- Make_Cond -- 13017 --------------- 13018 13019 function Make_Cond (Alt : Node_Id) return Node_Id is 13020 Cond : Node_Id; 13021 L : constant Node_Id := New_Copy_Tree (Lop); 13022 R : constant Node_Id := Relocate_Node (Alt); 13023 13024 begin 13025 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) 13026 or else Nkind (Alt) = N_Range 13027 then 13028 Cond := 13029 Make_In (Sloc (Alt), 13030 Left_Opnd => L, 13031 Right_Opnd => R); 13032 else 13033 Cond := 13034 Make_Op_Eq (Sloc (Alt), 13035 Left_Opnd => L, 13036 Right_Opnd => R); 13037 13038 if Is_Record_Or_Limited_Type (Etype (Alt)) then 13039 13040 -- We reset the Entity in order to use the primitive equality 13041 -- of the type, as per RM 4.5.2 (28.1/4). 13042 13043 Set_Entity (Cond, Empty); 13044 end if; 13045 end if; 13046 13047 return Cond; 13048 end Make_Cond; 13049 13050 -- Start of processing for Expand_Set_Membership 13051 13052 begin 13053 Remove_Side_Effects (Lop); 13054 13055 Alt := First (Alternatives (N)); 13056 Res := Make_Cond (Alt); 13057 Next (Alt); 13058 13059 -- We use left associativity as in the equivalent boolean case. This 13060 -- kind of canonicalization helps the optimizer of the code generator. 13061 13062 while Present (Alt) loop 13063 Res := 13064 Make_Or_Else (Sloc (Alt), 13065 Left_Opnd => Res, 13066 Right_Opnd => Make_Cond (Alt)); 13067 Next (Alt); 13068 end loop; 13069 13070 Rewrite (N, Res); 13071 Analyze_And_Resolve (N, Standard_Boolean); 13072 end Expand_Set_Membership; 13073 13074 ----------------------------------- 13075 -- Expand_Short_Circuit_Operator -- 13076 ----------------------------------- 13077 13078 -- Deal with special expansion if actions are present for the right operand 13079 -- and deal with optimizing case of arguments being True or False. We also 13080 -- deal with the special case of non-standard boolean values. 13081 13082 procedure Expand_Short_Circuit_Operator (N : Node_Id) is 13083 Loc : constant Source_Ptr := Sloc (N); 13084 Typ : constant Entity_Id := Etype (N); 13085 Left : constant Node_Id := Left_Opnd (N); 13086 Right : constant Node_Id := Right_Opnd (N); 13087 LocR : constant Source_Ptr := Sloc (Right); 13088 Actlist : List_Id; 13089 13090 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; 13091 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); 13092 -- If Left = Shortcut_Value then Right need not be evaluated 13093 13094 function Make_Test_Expr (Opnd : Node_Id) return Node_Id; 13095 -- For Opnd a boolean expression, return a Boolean expression equivalent 13096 -- to Opnd /= Shortcut_Value. 13097 13098 function Useful (Actions : List_Id) return Boolean; 13099 -- Return True if Actions is not empty and contains useful nodes to 13100 -- process. 13101 13102 -------------------- 13103 -- Make_Test_Expr -- 13104 -------------------- 13105 13106 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is 13107 begin 13108 if Shortcut_Value then 13109 return Make_Op_Not (Sloc (Opnd), Opnd); 13110 else 13111 return Opnd; 13112 end if; 13113 end Make_Test_Expr; 13114 13115 ------------ 13116 -- Useful -- 13117 ------------ 13118 13119 function Useful (Actions : List_Id) return Boolean is 13120 L : Node_Id; 13121 begin 13122 if Present (Actions) then 13123 L := First (Actions); 13124 13125 -- For now "useful" means not N_Variable_Reference_Marker. 13126 -- Consider stripping other nodes in the future. 13127 13128 while Present (L) loop 13129 if Nkind (L) /= N_Variable_Reference_Marker then 13130 return True; 13131 end if; 13132 13133 Next (L); 13134 end loop; 13135 end if; 13136 13137 return False; 13138 end Useful; 13139 13140 -- Local variables 13141 13142 Op_Var : Entity_Id; 13143 -- Entity for a temporary variable holding the value of the operator, 13144 -- used for expansion in the case where actions are present. 13145 13146 -- Start of processing for Expand_Short_Circuit_Operator 13147 13148 begin 13149 -- Deal with non-standard booleans 13150 13151 if Is_Boolean_Type (Typ) then 13152 Adjust_Condition (Left); 13153 Adjust_Condition (Right); 13154 Set_Etype (N, Standard_Boolean); 13155 end if; 13156 13157 -- Check for cases where left argument is known to be True or False 13158 13159 if Compile_Time_Known_Value (Left) then 13160 13161 -- Mark SCO for left condition as compile time known 13162 13163 if Generate_SCO and then Comes_From_Source (Left) then 13164 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); 13165 end if; 13166 13167 -- Rewrite True AND THEN Right / False OR ELSE Right to Right. 13168 -- Any actions associated with Right will be executed unconditionally 13169 -- and can thus be inserted into the tree unconditionally. 13170 13171 if Expr_Value_E (Left) /= Shortcut_Ent then 13172 if Present (Actions (N)) then 13173 Insert_Actions (N, Actions (N)); 13174 end if; 13175 13176 Rewrite (N, Right); 13177 13178 -- Rewrite False AND THEN Right / True OR ELSE Right to Left. 13179 -- In this case we can forget the actions associated with Right, 13180 -- since they will never be executed. 13181 13182 else 13183 Kill_Dead_Code (Right); 13184 Kill_Dead_Code (Actions (N)); 13185 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 13186 end if; 13187 13188 Adjust_Result_Type (N, Typ); 13189 return; 13190 end if; 13191 13192 -- If Actions are present for the right operand, we have to do some 13193 -- special processing. We can't just let these actions filter back into 13194 -- code preceding the short circuit (which is what would have happened 13195 -- if we had not trapped them in the short-circuit form), since they 13196 -- must only be executed if the right operand of the short circuit is 13197 -- executed and not otherwise. 13198 13199 if Useful (Actions (N)) then 13200 Actlist := Actions (N); 13201 13202 -- The old approach is to expand: 13203 13204 -- left AND THEN right 13205 13206 -- into 13207 13208 -- C : Boolean := False; 13209 -- IF left THEN 13210 -- Actions; 13211 -- IF right THEN 13212 -- C := True; 13213 -- END IF; 13214 -- END IF; 13215 13216 -- and finally rewrite the operator into a reference to C. Similarly 13217 -- for left OR ELSE right, with negated values. Note that this 13218 -- rewrite causes some difficulties for coverage analysis because 13219 -- of the introduction of the new variable C, which obscures the 13220 -- structure of the test. 13221 13222 -- We use this "old approach" if Minimize_Expression_With_Actions 13223 -- is True. 13224 13225 if Minimize_Expression_With_Actions then 13226 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); 13227 13228 Insert_Action (N, 13229 Make_Object_Declaration (Loc, 13230 Defining_Identifier => Op_Var, 13231 Object_Definition => 13232 New_Occurrence_Of (Standard_Boolean, Loc), 13233 Expression => 13234 New_Occurrence_Of (Shortcut_Ent, Loc))); 13235 13236 Append_To (Actlist, 13237 Make_Implicit_If_Statement (Right, 13238 Condition => Make_Test_Expr (Right), 13239 Then_Statements => New_List ( 13240 Make_Assignment_Statement (LocR, 13241 Name => New_Occurrence_Of (Op_Var, LocR), 13242 Expression => 13243 New_Occurrence_Of 13244 (Boolean_Literals (not Shortcut_Value), LocR))))); 13245 13246 Insert_Action (N, 13247 Make_Implicit_If_Statement (Left, 13248 Condition => Make_Test_Expr (Left), 13249 Then_Statements => Actlist)); 13250 13251 Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); 13252 Analyze_And_Resolve (N, Standard_Boolean); 13253 13254 -- The new approach (the default) is to use an 13255 -- Expression_With_Actions node for the right operand of the 13256 -- short-circuit form. Note that this solves the traceability 13257 -- problems for coverage analysis. 13258 13259 else 13260 Rewrite (Right, 13261 Make_Expression_With_Actions (LocR, 13262 Expression => Relocate_Node (Right), 13263 Actions => Actlist)); 13264 13265 Set_Actions (N, No_List); 13266 Analyze_And_Resolve (Right, Standard_Boolean); 13267 end if; 13268 13269 Adjust_Result_Type (N, Typ); 13270 return; 13271 end if; 13272 13273 -- No actions present, check for cases of right argument True/False 13274 13275 if Compile_Time_Known_Value (Right) then 13276 13277 -- Mark SCO for left condition as compile time known 13278 13279 if Generate_SCO and then Comes_From_Source (Right) then 13280 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); 13281 end if; 13282 13283 -- Change (Left and then True), (Left or else False) to Left. Note 13284 -- that we know there are no actions associated with the right 13285 -- operand, since we just checked for this case above. 13286 13287 if Expr_Value_E (Right) /= Shortcut_Ent then 13288 Rewrite (N, Left); 13289 13290 -- Change (Left and then False), (Left or else True) to Right, 13291 -- making sure to preserve any side effects associated with the Left 13292 -- operand. 13293 13294 else 13295 Remove_Side_Effects (Left); 13296 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); 13297 end if; 13298 end if; 13299 13300 Adjust_Result_Type (N, Typ); 13301 end Expand_Short_Circuit_Operator; 13302 13303 ------------------------------------ 13304 -- Fixup_Universal_Fixed_Operation -- 13305 ------------------------------------- 13306 13307 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is 13308 Conv : constant Node_Id := Parent (N); 13309 13310 begin 13311 -- We must have a type conversion immediately above us 13312 13313 pragma Assert (Nkind (Conv) = N_Type_Conversion); 13314 13315 -- Normally the type conversion gives our target type. The exception 13316 -- occurs in the case of the Round attribute, where the conversion 13317 -- will be to universal real, and our real type comes from the Round 13318 -- attribute (as well as an indication that we must round the result) 13319 13320 if Etype (Conv) = Universal_Real 13321 and then Nkind (Parent (Conv)) = N_Attribute_Reference 13322 and then Attribute_Name (Parent (Conv)) = Name_Round 13323 then 13324 Set_Etype (N, Base_Type (Etype (Parent (Conv)))); 13325 Set_Rounded_Result (N); 13326 13327 -- Normal case where type comes from conversion above us 13328 13329 else 13330 Set_Etype (N, Base_Type (Etype (Conv))); 13331 end if; 13332 end Fixup_Universal_Fixed_Operation; 13333 13334 --------------------------------- 13335 -- Has_Inferable_Discriminants -- 13336 --------------------------------- 13337 13338 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is 13339 13340 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; 13341 -- Determines whether the left-most prefix of a selected component is a 13342 -- formal parameter in a subprogram. Assumes N is a selected component. 13343 13344 -------------------------------- 13345 -- Prefix_Is_Formal_Parameter -- 13346 -------------------------------- 13347 13348 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is 13349 Sel_Comp : Node_Id; 13350 13351 begin 13352 -- Move to the left-most prefix by climbing up the tree 13353 13354 Sel_Comp := N; 13355 while Present (Parent (Sel_Comp)) 13356 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component 13357 loop 13358 Sel_Comp := Parent (Sel_Comp); 13359 end loop; 13360 13361 return Is_Formal (Entity (Prefix (Sel_Comp))); 13362 end Prefix_Is_Formal_Parameter; 13363 13364 -- Start of processing for Has_Inferable_Discriminants 13365 13366 begin 13367 -- For selected components, the subtype of the selector must be a 13368 -- constrained Unchecked_Union. If the component is subject to a 13369 -- per-object constraint, then the enclosing object must have inferable 13370 -- discriminants. 13371 13372 if Nkind (N) = N_Selected_Component then 13373 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then 13374 13375 -- A small hack. If we have a per-object constrained selected 13376 -- component of a formal parameter, return True since we do not 13377 -- know the actual parameter association yet. 13378 13379 if Prefix_Is_Formal_Parameter (N) then 13380 return True; 13381 13382 -- Otherwise, check the enclosing object and the selector 13383 13384 else 13385 return Has_Inferable_Discriminants (Prefix (N)) 13386 and then Has_Inferable_Discriminants (Selector_Name (N)); 13387 end if; 13388 13389 -- The call to Has_Inferable_Discriminants will determine whether 13390 -- the selector has a constrained Unchecked_Union nominal type. 13391 13392 else 13393 return Has_Inferable_Discriminants (Selector_Name (N)); 13394 end if; 13395 13396 -- A qualified expression has inferable discriminants if its subtype 13397 -- mark is a constrained Unchecked_Union subtype. 13398 13399 elsif Nkind (N) = N_Qualified_Expression then 13400 return Is_Unchecked_Union (Etype (Subtype_Mark (N))) 13401 and then Is_Constrained (Etype (Subtype_Mark (N))); 13402 13403 -- For all other names, it is sufficient to have a constrained 13404 -- Unchecked_Union nominal subtype. 13405 13406 else 13407 return Is_Unchecked_Union (Base_Type (Etype (N))) 13408 and then Is_Constrained (Etype (N)); 13409 end if; 13410 end Has_Inferable_Discriminants; 13411 13412 ------------------------------- 13413 -- Insert_Dereference_Action -- 13414 ------------------------------- 13415 13416 procedure Insert_Dereference_Action (N : Node_Id) is 13417 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; 13418 -- Return true if type of P is derived from Checked_Pool; 13419 13420 ----------------------------- 13421 -- Is_Checked_Storage_Pool -- 13422 ----------------------------- 13423 13424 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is 13425 T : Entity_Id; 13426 13427 begin 13428 if No (P) then 13429 return False; 13430 end if; 13431 13432 T := Etype (P); 13433 while T /= Etype (T) loop 13434 if Is_RTE (T, RE_Checked_Pool) then 13435 return True; 13436 else 13437 T := Etype (T); 13438 end if; 13439 end loop; 13440 13441 return False; 13442 end Is_Checked_Storage_Pool; 13443 13444 -- Local variables 13445 13446 Context : constant Node_Id := Parent (N); 13447 Ptr_Typ : constant Entity_Id := Etype (N); 13448 Desig_Typ : constant Entity_Id := 13449 Available_View (Designated_Type (Ptr_Typ)); 13450 Loc : constant Source_Ptr := Sloc (N); 13451 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ); 13452 13453 Addr : Entity_Id; 13454 Alig : Entity_Id; 13455 Deref : Node_Id; 13456 Size : Entity_Id; 13457 Size_Bits : Node_Id; 13458 Stmt : Node_Id; 13459 13460 -- Start of processing for Insert_Dereference_Action 13461 13462 begin 13463 pragma Assert (Nkind (Context) = N_Explicit_Dereference); 13464 13465 -- Do not re-expand a dereference which has already been processed by 13466 -- this routine. 13467 13468 if Has_Dereference_Action (Context) then 13469 return; 13470 13471 -- Do not perform this type of expansion for internally-generated 13472 -- dereferences. 13473 13474 elsif not Comes_From_Source (Original_Node (Context)) then 13475 return; 13476 13477 -- A dereference action is only applicable to objects which have been 13478 -- allocated on a checked pool. 13479 13480 elsif not Is_Checked_Storage_Pool (Pool) then 13481 return; 13482 end if; 13483 13484 -- Extract the address of the dereferenced object. Generate: 13485 13486 -- Addr : System.Address := <N>'Pool_Address; 13487 13488 Addr := Make_Temporary (Loc, 'P'); 13489 13490 Insert_Action (N, 13491 Make_Object_Declaration (Loc, 13492 Defining_Identifier => Addr, 13493 Object_Definition => 13494 New_Occurrence_Of (RTE (RE_Address), Loc), 13495 Expression => 13496 Make_Attribute_Reference (Loc, 13497 Prefix => Duplicate_Subexpr_Move_Checks (N), 13498 Attribute_Name => Name_Pool_Address))); 13499 13500 -- Calculate the size of the dereferenced object. Generate: 13501 13502 -- Size : Storage_Count := <N>.all'Size / Storage_Unit; 13503 13504 Deref := 13505 Make_Explicit_Dereference (Loc, 13506 Prefix => Duplicate_Subexpr_Move_Checks (N)); 13507 Set_Has_Dereference_Action (Deref); 13508 13509 Size_Bits := 13510 Make_Attribute_Reference (Loc, 13511 Prefix => Deref, 13512 Attribute_Name => Name_Size); 13513 13514 -- Special case of an unconstrained array: need to add descriptor size 13515 13516 if Is_Array_Type (Desig_Typ) 13517 and then not Is_Constrained (First_Subtype (Desig_Typ)) 13518 then 13519 Size_Bits := 13520 Make_Op_Add (Loc, 13521 Left_Opnd => 13522 Make_Attribute_Reference (Loc, 13523 Prefix => 13524 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc), 13525 Attribute_Name => Name_Descriptor_Size), 13526 Right_Opnd => Size_Bits); 13527 end if; 13528 13529 Size := Make_Temporary (Loc, 'S'); 13530 Insert_Action (N, 13531 Make_Object_Declaration (Loc, 13532 Defining_Identifier => Size, 13533 Object_Definition => 13534 New_Occurrence_Of (RTE (RE_Storage_Count), Loc), 13535 Expression => 13536 Make_Op_Divide (Loc, 13537 Left_Opnd => Size_Bits, 13538 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); 13539 13540 -- Calculate the alignment of the dereferenced object. Generate: 13541 -- Alig : constant Storage_Count := <N>.all'Alignment; 13542 13543 Deref := 13544 Make_Explicit_Dereference (Loc, 13545 Prefix => Duplicate_Subexpr_Move_Checks (N)); 13546 Set_Has_Dereference_Action (Deref); 13547 13548 Alig := Make_Temporary (Loc, 'A'); 13549 Insert_Action (N, 13550 Make_Object_Declaration (Loc, 13551 Defining_Identifier => Alig, 13552 Object_Definition => 13553 New_Occurrence_Of (RTE (RE_Storage_Count), Loc), 13554 Expression => 13555 Make_Attribute_Reference (Loc, 13556 Prefix => Deref, 13557 Attribute_Name => Name_Alignment))); 13558 13559 -- A dereference of a controlled object requires special processing. The 13560 -- finalization machinery requests additional space from the underlying 13561 -- pool to allocate and hide two pointers. As a result, a checked pool 13562 -- may mark the wrong memory as valid. Since checked pools do not have 13563 -- knowledge of hidden pointers, we have to bring the two pointers back 13564 -- in view in order to restore the original state of the object. 13565 13566 -- The address manipulation is not performed for access types that are 13567 -- subject to pragma No_Heap_Finalization because the two pointers do 13568 -- not exist in the first place. 13569 13570 if No_Heap_Finalization (Ptr_Typ) then 13571 null; 13572 13573 elsif Needs_Finalization (Desig_Typ) then 13574 13575 -- Adjust the address and size of the dereferenced object. Generate: 13576 -- Adjust_Controlled_Dereference (Addr, Size, Alig); 13577 13578 Stmt := 13579 Make_Procedure_Call_Statement (Loc, 13580 Name => 13581 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc), 13582 Parameter_Associations => New_List ( 13583 New_Occurrence_Of (Addr, Loc), 13584 New_Occurrence_Of (Size, Loc), 13585 New_Occurrence_Of (Alig, Loc))); 13586 13587 -- Class-wide types complicate things because we cannot determine 13588 -- statically whether the actual object is truly controlled. We must 13589 -- generate a runtime check to detect this property. Generate: 13590 -- 13591 -- if Needs_Finalization (<N>.all'Tag) then 13592 -- <Stmt>; 13593 -- end if; 13594 13595 if Is_Class_Wide_Type (Desig_Typ) then 13596 Deref := 13597 Make_Explicit_Dereference (Loc, 13598 Prefix => Duplicate_Subexpr_Move_Checks (N)); 13599 Set_Has_Dereference_Action (Deref); 13600 13601 Stmt := 13602 Make_Implicit_If_Statement (N, 13603 Condition => 13604 Make_Function_Call (Loc, 13605 Name => 13606 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc), 13607 Parameter_Associations => New_List ( 13608 Make_Attribute_Reference (Loc, 13609 Prefix => Deref, 13610 Attribute_Name => Name_Tag))), 13611 Then_Statements => New_List (Stmt)); 13612 end if; 13613 13614 Insert_Action (N, Stmt); 13615 end if; 13616 13617 -- Generate: 13618 -- Dereference (Pool, Addr, Size, Alig); 13619 13620 Insert_Action (N, 13621 Make_Procedure_Call_Statement (Loc, 13622 Name => 13623 New_Occurrence_Of 13624 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc), 13625 Parameter_Associations => New_List ( 13626 New_Occurrence_Of (Pool, Loc), 13627 New_Occurrence_Of (Addr, Loc), 13628 New_Occurrence_Of (Size, Loc), 13629 New_Occurrence_Of (Alig, Loc)))); 13630 13631 -- Mark the explicit dereference as processed to avoid potential 13632 -- infinite expansion. 13633 13634 Set_Has_Dereference_Action (Context); 13635 13636 exception 13637 when RE_Not_Available => 13638 return; 13639 end Insert_Dereference_Action; 13640 13641 -------------------------------- 13642 -- Integer_Promotion_Possible -- 13643 -------------------------------- 13644 13645 function Integer_Promotion_Possible (N : Node_Id) return Boolean is 13646 Operand : constant Node_Id := Expression (N); 13647 Operand_Type : constant Entity_Id := Etype (Operand); 13648 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type); 13649 13650 begin 13651 pragma Assert (Nkind (N) = N_Type_Conversion); 13652 13653 return 13654 13655 -- We only do the transformation for source constructs. We assume 13656 -- that the expander knows what it is doing when it generates code. 13657 13658 Comes_From_Source (N) 13659 13660 -- If the operand type is Short_Integer or Short_Short_Integer, 13661 -- then we will promote to Integer, which is available on all 13662 -- targets, and is sufficient to ensure no intermediate overflow. 13663 -- Furthermore it is likely to be as efficient or more efficient 13664 -- than using the smaller type for the computation so we do this 13665 -- unconditionally. 13666 13667 and then 13668 (Root_Operand_Type = Base_Type (Standard_Short_Integer) 13669 or else 13670 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) 13671 13672 -- Test for interesting operation, which includes addition, 13673 -- division, exponentiation, multiplication, subtraction, absolute 13674 -- value and unary negation. Unary "+" is omitted since it is a 13675 -- no-op and thus can't overflow. 13676 13677 and then Nkind (Operand) in 13678 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon | 13679 N_Op_Minus | N_Op_Multiply | N_Op_Subtract; 13680 end Integer_Promotion_Possible; 13681 13682 ------------------------------ 13683 -- Make_Array_Comparison_Op -- 13684 ------------------------------ 13685 13686 -- This is a hand-coded expansion of the following generic function: 13687 13688 -- generic 13689 -- type elem is (<>); 13690 -- type index is (<>); 13691 -- type a is array (index range <>) of elem; 13692 13693 -- function Gnnn (X : a; Y: a) return boolean is 13694 -- J : index := Y'first; 13695 13696 -- begin 13697 -- if X'length = 0 then 13698 -- return false; 13699 13700 -- elsif Y'length = 0 then 13701 -- return true; 13702 13703 -- else 13704 -- for I in X'range loop 13705 -- if X (I) = Y (J) then 13706 -- if J = Y'last then 13707 -- exit; 13708 -- else 13709 -- J := index'succ (J); 13710 -- end if; 13711 13712 -- else 13713 -- return X (I) > Y (J); 13714 -- end if; 13715 -- end loop; 13716 13717 -- return X'length > Y'length; 13718 -- end if; 13719 -- end Gnnn; 13720 13721 -- Note that since we are essentially doing this expansion by hand, we 13722 -- do not need to generate an actual or formal generic part, just the 13723 -- instantiated function itself. 13724 13725 -- Perhaps we could have the actual generic available in the run-time, 13726 -- obtained by rtsfind, and actually expand a real instantiation ??? 13727 13728 function Make_Array_Comparison_Op 13729 (Typ : Entity_Id; 13730 Nod : Node_Id) return Node_Id 13731 is 13732 Loc : constant Source_Ptr := Sloc (Nod); 13733 13734 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX); 13735 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY); 13736 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI); 13737 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 13738 13739 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); 13740 13741 Loop_Statement : Node_Id; 13742 Loop_Body : Node_Id; 13743 If_Stat : Node_Id; 13744 Inner_If : Node_Id; 13745 Final_Expr : Node_Id; 13746 Func_Body : Node_Id; 13747 Func_Name : Entity_Id; 13748 Formals : List_Id; 13749 Length1 : Node_Id; 13750 Length2 : Node_Id; 13751 13752 begin 13753 -- if J = Y'last then 13754 -- exit; 13755 -- else 13756 -- J := index'succ (J); 13757 -- end if; 13758 13759 Inner_If := 13760 Make_Implicit_If_Statement (Nod, 13761 Condition => 13762 Make_Op_Eq (Loc, 13763 Left_Opnd => New_Occurrence_Of (J, Loc), 13764 Right_Opnd => 13765 Make_Attribute_Reference (Loc, 13766 Prefix => New_Occurrence_Of (Y, Loc), 13767 Attribute_Name => Name_Last)), 13768 13769 Then_Statements => New_List ( 13770 Make_Exit_Statement (Loc)), 13771 13772 Else_Statements => 13773 New_List ( 13774 Make_Assignment_Statement (Loc, 13775 Name => New_Occurrence_Of (J, Loc), 13776 Expression => 13777 Make_Attribute_Reference (Loc, 13778 Prefix => New_Occurrence_Of (Index, Loc), 13779 Attribute_Name => Name_Succ, 13780 Expressions => New_List (New_Occurrence_Of (J, Loc)))))); 13781 13782 -- if X (I) = Y (J) then 13783 -- if ... end if; 13784 -- else 13785 -- return X (I) > Y (J); 13786 -- end if; 13787 13788 Loop_Body := 13789 Make_Implicit_If_Statement (Nod, 13790 Condition => 13791 Make_Op_Eq (Loc, 13792 Left_Opnd => 13793 Make_Indexed_Component (Loc, 13794 Prefix => New_Occurrence_Of (X, Loc), 13795 Expressions => New_List (New_Occurrence_Of (I, Loc))), 13796 13797 Right_Opnd => 13798 Make_Indexed_Component (Loc, 13799 Prefix => New_Occurrence_Of (Y, Loc), 13800 Expressions => New_List (New_Occurrence_Of (J, Loc)))), 13801 13802 Then_Statements => New_List (Inner_If), 13803 13804 Else_Statements => New_List ( 13805 Make_Simple_Return_Statement (Loc, 13806 Expression => 13807 Make_Op_Gt (Loc, 13808 Left_Opnd => 13809 Make_Indexed_Component (Loc, 13810 Prefix => New_Occurrence_Of (X, Loc), 13811 Expressions => New_List (New_Occurrence_Of (I, Loc))), 13812 13813 Right_Opnd => 13814 Make_Indexed_Component (Loc, 13815 Prefix => New_Occurrence_Of (Y, Loc), 13816 Expressions => New_List ( 13817 New_Occurrence_Of (J, Loc))))))); 13818 13819 -- for I in X'range loop 13820 -- if ... end if; 13821 -- end loop; 13822 13823 Loop_Statement := 13824 Make_Implicit_Loop_Statement (Nod, 13825 Identifier => Empty, 13826 13827 Iteration_Scheme => 13828 Make_Iteration_Scheme (Loc, 13829 Loop_Parameter_Specification => 13830 Make_Loop_Parameter_Specification (Loc, 13831 Defining_Identifier => I, 13832 Discrete_Subtype_Definition => 13833 Make_Attribute_Reference (Loc, 13834 Prefix => New_Occurrence_Of (X, Loc), 13835 Attribute_Name => Name_Range))), 13836 13837 Statements => New_List (Loop_Body)); 13838 13839 -- if X'length = 0 then 13840 -- return false; 13841 -- elsif Y'length = 0 then 13842 -- return true; 13843 -- else 13844 -- for ... loop ... end loop; 13845 -- return X'length > Y'length; 13846 -- end if; 13847 13848 Length1 := 13849 Make_Attribute_Reference (Loc, 13850 Prefix => New_Occurrence_Of (X, Loc), 13851 Attribute_Name => Name_Length); 13852 13853 Length2 := 13854 Make_Attribute_Reference (Loc, 13855 Prefix => New_Occurrence_Of (Y, Loc), 13856 Attribute_Name => Name_Length); 13857 13858 Final_Expr := 13859 Make_Op_Gt (Loc, 13860 Left_Opnd => Length1, 13861 Right_Opnd => Length2); 13862 13863 If_Stat := 13864 Make_Implicit_If_Statement (Nod, 13865 Condition => 13866 Make_Op_Eq (Loc, 13867 Left_Opnd => 13868 Make_Attribute_Reference (Loc, 13869 Prefix => New_Occurrence_Of (X, Loc), 13870 Attribute_Name => Name_Length), 13871 Right_Opnd => 13872 Make_Integer_Literal (Loc, 0)), 13873 13874 Then_Statements => 13875 New_List ( 13876 Make_Simple_Return_Statement (Loc, 13877 Expression => New_Occurrence_Of (Standard_False, Loc))), 13878 13879 Elsif_Parts => New_List ( 13880 Make_Elsif_Part (Loc, 13881 Condition => 13882 Make_Op_Eq (Loc, 13883 Left_Opnd => 13884 Make_Attribute_Reference (Loc, 13885 Prefix => New_Occurrence_Of (Y, Loc), 13886 Attribute_Name => Name_Length), 13887 Right_Opnd => 13888 Make_Integer_Literal (Loc, 0)), 13889 13890 Then_Statements => 13891 New_List ( 13892 Make_Simple_Return_Statement (Loc, 13893 Expression => New_Occurrence_Of (Standard_True, Loc))))), 13894 13895 Else_Statements => New_List ( 13896 Loop_Statement, 13897 Make_Simple_Return_Statement (Loc, 13898 Expression => Final_Expr))); 13899 13900 -- (X : a; Y: a) 13901 13902 Formals := New_List ( 13903 Make_Parameter_Specification (Loc, 13904 Defining_Identifier => X, 13905 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 13906 13907 Make_Parameter_Specification (Loc, 13908 Defining_Identifier => Y, 13909 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 13910 13911 -- function Gnnn (...) return boolean is 13912 -- J : index := Y'first; 13913 -- begin 13914 -- if ... end if; 13915 -- end Gnnn; 13916 13917 Func_Name := Make_Temporary (Loc, 'G'); 13918 13919 Func_Body := 13920 Make_Subprogram_Body (Loc, 13921 Specification => 13922 Make_Function_Specification (Loc, 13923 Defining_Unit_Name => Func_Name, 13924 Parameter_Specifications => Formals, 13925 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 13926 13927 Declarations => New_List ( 13928 Make_Object_Declaration (Loc, 13929 Defining_Identifier => J, 13930 Object_Definition => New_Occurrence_Of (Index, Loc), 13931 Expression => 13932 Make_Attribute_Reference (Loc, 13933 Prefix => New_Occurrence_Of (Y, Loc), 13934 Attribute_Name => Name_First))), 13935 13936 Handled_Statement_Sequence => 13937 Make_Handled_Sequence_Of_Statements (Loc, 13938 Statements => New_List (If_Stat))); 13939 13940 return Func_Body; 13941 end Make_Array_Comparison_Op; 13942 13943 --------------------------- 13944 -- Make_Boolean_Array_Op -- 13945 --------------------------- 13946 13947 -- For logical operations on boolean arrays, expand in line the following, 13948 -- replacing 'and' with 'or' or 'xor' where needed: 13949 13950 -- function Annn (A : typ; B: typ) return typ is 13951 -- C : typ; 13952 -- begin 13953 -- for J in A'range loop 13954 -- C (J) := A (J) op B (J); 13955 -- end loop; 13956 -- return C; 13957 -- end Annn; 13958 13959 -- or in the case of Transform_Function_Array: 13960 13961 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is 13962 -- begin 13963 -- for J in A'range loop 13964 -- RESULT (J) := A (J) op B (J); 13965 -- end loop; 13966 -- end Annn; 13967 13968 -- Here typ is the boolean array type 13969 13970 function Make_Boolean_Array_Op 13971 (Typ : Entity_Id; 13972 N : Node_Id) return Node_Id 13973 is 13974 Loc : constant Source_Ptr := Sloc (N); 13975 13976 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 13977 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); 13978 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ); 13979 13980 C : Entity_Id; 13981 13982 A_J : Node_Id; 13983 B_J : Node_Id; 13984 C_J : Node_Id; 13985 Op : Node_Id; 13986 13987 Formals : List_Id; 13988 Func_Name : Entity_Id; 13989 Func_Body : Node_Id; 13990 Loop_Statement : Node_Id; 13991 13992 begin 13993 if Transform_Function_Array then 13994 C := Make_Defining_Identifier (Loc, Name_UP_RESULT); 13995 else 13996 C := Make_Defining_Identifier (Loc, Name_uC); 13997 end if; 13998 13999 A_J := 14000 Make_Indexed_Component (Loc, 14001 Prefix => New_Occurrence_Of (A, Loc), 14002 Expressions => New_List (New_Occurrence_Of (J, Loc))); 14003 14004 B_J := 14005 Make_Indexed_Component (Loc, 14006 Prefix => New_Occurrence_Of (B, Loc), 14007 Expressions => New_List (New_Occurrence_Of (J, Loc))); 14008 14009 C_J := 14010 Make_Indexed_Component (Loc, 14011 Prefix => New_Occurrence_Of (C, Loc), 14012 Expressions => New_List (New_Occurrence_Of (J, Loc))); 14013 14014 if Nkind (N) = N_Op_And then 14015 Op := 14016 Make_Op_And (Loc, 14017 Left_Opnd => A_J, 14018 Right_Opnd => B_J); 14019 14020 elsif Nkind (N) = N_Op_Or then 14021 Op := 14022 Make_Op_Or (Loc, 14023 Left_Opnd => A_J, 14024 Right_Opnd => B_J); 14025 14026 else 14027 Op := 14028 Make_Op_Xor (Loc, 14029 Left_Opnd => A_J, 14030 Right_Opnd => B_J); 14031 end if; 14032 14033 Loop_Statement := 14034 Make_Implicit_Loop_Statement (N, 14035 Identifier => Empty, 14036 14037 Iteration_Scheme => 14038 Make_Iteration_Scheme (Loc, 14039 Loop_Parameter_Specification => 14040 Make_Loop_Parameter_Specification (Loc, 14041 Defining_Identifier => J, 14042 Discrete_Subtype_Definition => 14043 Make_Attribute_Reference (Loc, 14044 Prefix => New_Occurrence_Of (A, Loc), 14045 Attribute_Name => Name_Range))), 14046 14047 Statements => New_List ( 14048 Make_Assignment_Statement (Loc, 14049 Name => C_J, 14050 Expression => Op))); 14051 14052 Formals := New_List ( 14053 Make_Parameter_Specification (Loc, 14054 Defining_Identifier => A, 14055 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 14056 14057 Make_Parameter_Specification (Loc, 14058 Defining_Identifier => B, 14059 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 14060 14061 if Transform_Function_Array then 14062 Append_To (Formals, 14063 Make_Parameter_Specification (Loc, 14064 Defining_Identifier => C, 14065 Out_Present => True, 14066 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 14067 end if; 14068 14069 Func_Name := Make_Temporary (Loc, 'A'); 14070 Set_Is_Inlined (Func_Name); 14071 14072 if Transform_Function_Array then 14073 Func_Body := 14074 Make_Subprogram_Body (Loc, 14075 Specification => 14076 Make_Procedure_Specification (Loc, 14077 Defining_Unit_Name => Func_Name, 14078 Parameter_Specifications => Formals), 14079 14080 Declarations => New_List, 14081 14082 Handled_Statement_Sequence => 14083 Make_Handled_Sequence_Of_Statements (Loc, 14084 Statements => New_List (Loop_Statement))); 14085 14086 else 14087 Func_Body := 14088 Make_Subprogram_Body (Loc, 14089 Specification => 14090 Make_Function_Specification (Loc, 14091 Defining_Unit_Name => Func_Name, 14092 Parameter_Specifications => Formals, 14093 Result_Definition => New_Occurrence_Of (Typ, Loc)), 14094 14095 Declarations => New_List ( 14096 Make_Object_Declaration (Loc, 14097 Defining_Identifier => C, 14098 Object_Definition => New_Occurrence_Of (Typ, Loc))), 14099 14100 Handled_Statement_Sequence => 14101 Make_Handled_Sequence_Of_Statements (Loc, 14102 Statements => New_List ( 14103 Loop_Statement, 14104 Make_Simple_Return_Statement (Loc, 14105 Expression => New_Occurrence_Of (C, Loc))))); 14106 end if; 14107 14108 return Func_Body; 14109 end Make_Boolean_Array_Op; 14110 14111 ----------------------------------------- 14112 -- Minimized_Eliminated_Overflow_Check -- 14113 ----------------------------------------- 14114 14115 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is 14116 begin 14117 return 14118 Is_Signed_Integer_Type (Etype (N)) 14119 and then Overflow_Check_Mode in Minimized_Or_Eliminated; 14120 end Minimized_Eliminated_Overflow_Check; 14121 14122 ---------------------------- 14123 -- Narrow_Large_Operation -- 14124 ---------------------------- 14125 14126 procedure Narrow_Large_Operation (N : Node_Id) is 14127 Kind : constant Node_Kind := Nkind (N); 14128 In_Rng : constant Boolean := Kind = N_In; 14129 Binary : constant Boolean := Kind in N_Binary_Op or else In_Rng; 14130 Compar : constant Boolean := Kind in N_Op_Compare or else In_Rng; 14131 R : constant Node_Id := Right_Opnd (N); 14132 Typ : constant Entity_Id := Etype (R); 14133 Tsiz : constant Uint := RM_Size (Typ); 14134 14135 function Get_Size_For_Range (Lo, Hi : Uint) return Uint; 14136 -- Return the size of a small signed integer type covering Lo .. Hi. 14137 -- The important thing is to return a size lower than that of Typ. 14138 14139 ------------------------ 14140 -- Get_Size_For_Range -- 14141 ------------------------ 14142 14143 function Get_Size_For_Range (Lo, Hi : Uint) return Uint is 14144 14145 function Is_OK_For_Range (Siz : Uint) return Boolean; 14146 -- Return True if a signed integer with given size can cover Lo .. Hi 14147 14148 -------------------------- 14149 -- Is_OK_For_Range -- 14150 -------------------------- 14151 14152 function Is_OK_For_Range (Siz : Uint) return Boolean is 14153 B : constant Uint := Uint_2 ** (Siz - 1); 14154 14155 begin 14156 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) 14157 14158 return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B; 14159 end Is_OK_For_Range; 14160 14161 begin 14162 -- This is (almost always) the size of Integer 14163 14164 if Is_OK_For_Range (Uint_32) then 14165 return Uint_32; 14166 14167 -- If the size of Typ is 64 then check 63 14168 14169 elsif Tsiz = Uint_64 and then Is_OK_For_Range (Uint_63) then 14170 return Uint_63; 14171 14172 -- This is (almost always) the size of Long_Long_Integer 14173 14174 elsif Is_OK_For_Range (Uint_64) then 14175 return Uint_64; 14176 14177 -- If the size of Typ is 128 then check 127 14178 14179 elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then 14180 return Uint_127; 14181 14182 else 14183 return Uint_128; 14184 end if; 14185 end Get_Size_For_Range; 14186 14187 -- Local variables 14188 14189 L : Node_Id; 14190 Llo, Lhi : Uint; 14191 Rlo, Rhi : Uint; 14192 Lsiz, Rsiz : Uint; 14193 Nlo, Nhi : Uint; 14194 Nsiz : Uint; 14195 Ntyp : Entity_Id; 14196 Nop : Node_Id; 14197 OK : Boolean; 14198 14199 -- Start of processing for Narrow_Large_Operation 14200 14201 begin 14202 -- First, determine the range of the left operand, if any 14203 14204 if Binary then 14205 L := Left_Opnd (N); 14206 Determine_Range (L, OK, Llo, Lhi, Assume_Valid => True); 14207 if not OK then 14208 return; 14209 end if; 14210 14211 else 14212 L := Empty; 14213 Llo := Uint_0; 14214 Lhi := Uint_0; 14215 end if; 14216 14217 -- Second, determine the range of the right operand, which can itself 14218 -- be a range, in which case we take the lower bound of the low bound 14219 -- and the upper bound of the high bound. 14220 14221 if In_Rng then 14222 declare 14223 Zlo, Zhi : Uint; 14224 14225 begin 14226 Determine_Range 14227 (Low_Bound (R), OK, Rlo, Zhi, Assume_Valid => True); 14228 if not OK then 14229 return; 14230 end if; 14231 14232 Determine_Range 14233 (High_Bound (R), OK, Zlo, Rhi, Assume_Valid => True); 14234 if not OK then 14235 return; 14236 end if; 14237 end; 14238 14239 else 14240 Determine_Range (R, OK, Rlo, Rhi, Assume_Valid => True); 14241 if not OK then 14242 return; 14243 end if; 14244 end if; 14245 14246 -- Then compute a size suitable for each range 14247 14248 if Binary then 14249 Lsiz := Get_Size_For_Range (Llo, Lhi); 14250 else 14251 Lsiz := Uint_0; 14252 end if; 14253 14254 Rsiz := Get_Size_For_Range (Rlo, Rhi); 14255 14256 -- Now compute the size of the narrower type 14257 14258 if Compar then 14259 -- The type must be able to accommodate the operands 14260 14261 Nsiz := UI_Max (Lsiz, Rsiz); 14262 14263 else 14264 -- The type must be able to accommodate the operand(s) and result. 14265 14266 -- Note that Determine_Range typically does not report the bounds of 14267 -- the value as being larger than those of the base type, which means 14268 -- that it does not report overflow (see also Enable_Overflow_Check). 14269 14270 Determine_Range (N, OK, Nlo, Nhi, Assume_Valid => True); 14271 if not OK then 14272 return; 14273 end if; 14274 14275 -- Therefore, if Nsiz is not lower than the size of the original type 14276 -- here, we cannot be sure that the operation does not overflow. 14277 14278 Nsiz := Get_Size_For_Range (Nlo, Nhi); 14279 Nsiz := UI_Max (Nsiz, Lsiz); 14280 Nsiz := UI_Max (Nsiz, Rsiz); 14281 end if; 14282 14283 -- If the size is not lower than the size of the original type, then 14284 -- there is no point in changing the type, except in the case where 14285 -- we can remove a conversion to the original type from an operand. 14286 14287 if Nsiz >= Tsiz 14288 and then not (Binary 14289 and then Nkind (L) = N_Type_Conversion 14290 and then Entity (Subtype_Mark (L)) = Typ) 14291 and then not (Nkind (R) = N_Type_Conversion 14292 and then Entity (Subtype_Mark (R)) = Typ) 14293 then 14294 return; 14295 end if; 14296 14297 -- Now pick the narrower type according to the size. We use the base 14298 -- type instead of the first subtype because operations are done in 14299 -- the base type, so this avoids the need for useless conversions. 14300 14301 if Nsiz <= System_Max_Integer_Size then 14302 Ntyp := Etype (Integer_Type_For (Nsiz, Uns => False)); 14303 else 14304 return; 14305 end if; 14306 14307 -- Finally, rewrite the operation in the narrower type 14308 14309 Nop := New_Op_Node (Kind, Sloc (N)); 14310 14311 if Binary then 14312 Set_Left_Opnd (Nop, Convert_To (Ntyp, L)); 14313 end if; 14314 14315 if In_Rng then 14316 Set_Right_Opnd (Nop, 14317 Make_Range (Sloc (N), 14318 Convert_To (Ntyp, Low_Bound (R)), 14319 Convert_To (Ntyp, High_Bound (R)))); 14320 else 14321 Set_Right_Opnd (Nop, Convert_To (Ntyp, R)); 14322 end if; 14323 14324 Rewrite (N, Nop); 14325 14326 if Compar then 14327 -- Analyze it with the comparison type and checks suppressed since 14328 -- the conversions of the operands cannot overflow. 14329 14330 Analyze_And_Resolve 14331 (N, Etype (Original_Node (N)), Suppress => Overflow_Check); 14332 14333 else 14334 -- Analyze it with the narrower type and checks suppressed, but only 14335 -- when we are sure that the operation does not overflow, see above. 14336 14337 if Nsiz < Tsiz then 14338 Analyze_And_Resolve (N, Ntyp, Suppress => Overflow_Check); 14339 else 14340 Analyze_And_Resolve (N, Ntyp); 14341 end if; 14342 14343 -- Put back a conversion to the original type 14344 14345 Convert_To_And_Rewrite (Typ, N); 14346 end if; 14347 end Narrow_Large_Operation; 14348 14349 -------------------------------- 14350 -- Optimize_Length_Comparison -- 14351 -------------------------------- 14352 14353 procedure Optimize_Length_Comparison (N : Node_Id) is 14354 Loc : constant Source_Ptr := Sloc (N); 14355 Typ : constant Entity_Id := Etype (N); 14356 Result : Node_Id; 14357 14358 Left : Node_Id; 14359 Right : Node_Id; 14360 -- First and Last attribute reference nodes, which end up as left and 14361 -- right operands of the optimized result. 14362 14363 Is_Zero : Boolean; 14364 -- True for comparison operand of zero 14365 14366 Maybe_Superflat : Boolean; 14367 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set 14368 -- to false but the comparison operand can be zero at run time. In this 14369 -- case, we normally cannot do anything because the canonical formula of 14370 -- the length is not valid, but there is one exception: when the operand 14371 -- is itself the length of an array with the same bounds as the array on 14372 -- the LHS, we can entirely optimize away the comparison. 14373 14374 Comp : Node_Id; 14375 -- Comparison operand, set only if Is_Zero is false 14376 14377 Ent : array (Pos range 1 .. 2) of Entity_Id := (Empty, Empty); 14378 -- Entities whose length is being compared 14379 14380 Index : array (Pos range 1 .. 2) of Node_Id := (Empty, Empty); 14381 -- Integer_Literal nodes for length attribute expressions, or Empty 14382 -- if there is no such expression present. 14383 14384 Op : Node_Kind := Nkind (N); 14385 -- Kind of comparison operator, gets flipped if operands backwards 14386 14387 function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id; 14388 -- Given a discrete expression, returns a Long_Long_Integer typed 14389 -- expression representing the underlying value of the expression. 14390 -- This is done with an unchecked conversion to Long_Long_Integer. 14391 -- We use unchecked conversion to handle the enumeration type case. 14392 14393 function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean; 14394 -- Tests if N is a length attribute applied to a simple entity. If so, 14395 -- returns True, and sets Ent to the entity, and Index to the integer 14396 -- literal provided as an attribute expression, or to Empty if none. 14397 -- Num is the index designating the relevant slot in Ent and Index. 14398 -- Also returns True if the expression is a generated type conversion 14399 -- whose expression is of the desired form. This latter case arises 14400 -- when Apply_Universal_Integer_Attribute_Check installs a conversion 14401 -- to check for being in range, which is not needed in this context. 14402 -- Returns False if neither condition holds. 14403 14404 function Is_Optimizable (N : Node_Id) return Boolean; 14405 -- Tests N to see if it is an optimizable comparison value (defined as 14406 -- constant zero or one, or something else where the value is known to 14407 -- be nonnegative and in the 32-bit range and where the corresponding 14408 -- Length value is also known to be 32 bits). If result is true, sets 14409 -- Is_Zero, Maybe_Superflat and Comp accordingly. 14410 14411 procedure Rewrite_For_Equal_Lengths; 14412 -- Rewrite the comparison of two equal lengths into either True or False 14413 14414 ---------------------------------- 14415 -- Convert_To_Long_Long_Integer -- 14416 ---------------------------------- 14417 14418 function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id is 14419 begin 14420 return Unchecked_Convert_To (Standard_Long_Long_Integer, N); 14421 end Convert_To_Long_Long_Integer; 14422 14423 ---------------------- 14424 -- Is_Entity_Length -- 14425 ---------------------- 14426 14427 function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean is 14428 begin 14429 if Nkind (N) = N_Attribute_Reference 14430 and then Attribute_Name (N) = Name_Length 14431 and then Is_Entity_Name (Prefix (N)) 14432 then 14433 Ent (Num) := Entity (Prefix (N)); 14434 14435 if Present (Expressions (N)) then 14436 Index (Num) := First (Expressions (N)); 14437 else 14438 Index (Num) := Empty; 14439 end if; 14440 14441 return True; 14442 14443 elsif Nkind (N) = N_Type_Conversion 14444 and then not Comes_From_Source (N) 14445 then 14446 return Is_Entity_Length (Expression (N), Num); 14447 14448 else 14449 return False; 14450 end if; 14451 end Is_Entity_Length; 14452 14453 -------------------- 14454 -- Is_Optimizable -- 14455 -------------------- 14456 14457 function Is_Optimizable (N : Node_Id) return Boolean is 14458 Val : Uint; 14459 OK : Boolean; 14460 Lo : Uint; 14461 Hi : Uint; 14462 Indx : Node_Id; 14463 Dbl : Boolean; 14464 Ityp : Entity_Id; 14465 14466 begin 14467 if Compile_Time_Known_Value (N) then 14468 Val := Expr_Value (N); 14469 14470 if Val = Uint_0 then 14471 Is_Zero := True; 14472 Maybe_Superflat := False; 14473 Comp := Empty; 14474 return True; 14475 14476 elsif Val = Uint_1 then 14477 Is_Zero := False; 14478 Maybe_Superflat := False; 14479 Comp := Empty; 14480 return True; 14481 end if; 14482 end if; 14483 14484 -- Here we have to make sure of being within a 32-bit range (take the 14485 -- full unsigned range so the length of 32-bit arrays is accepted). 14486 14487 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); 14488 14489 if not OK 14490 or else Lo < Uint_0 14491 or else Hi > Uint_2 ** 32 14492 then 14493 return False; 14494 end if; 14495 14496 Maybe_Superflat := (Lo = Uint_0); 14497 14498 -- Tests if N is also a length attribute applied to a simple entity 14499 14500 Dbl := Is_Entity_Length (N, 2); 14501 14502 -- We can deal with the superflat case only if N is also a length 14503 14504 if Maybe_Superflat and then not Dbl then 14505 return False; 14506 end if; 14507 14508 -- Comparison value was within range, so now we must check the index 14509 -- value to make sure it is also within 32 bits. 14510 14511 for K in Pos range 1 .. 2 loop 14512 Indx := First_Index (Etype (Ent (K))); 14513 14514 if Present (Index (K)) then 14515 for J in 2 .. UI_To_Int (Intval (Index (K))) loop 14516 Next_Index (Indx); 14517 end loop; 14518 end if; 14519 14520 Ityp := Etype (Indx); 14521 14522 if Esize (Ityp) > 32 then 14523 return False; 14524 end if; 14525 14526 exit when not Dbl; 14527 end loop; 14528 14529 Is_Zero := False; 14530 Comp := N; 14531 return True; 14532 end Is_Optimizable; 14533 14534 ------------------------------- 14535 -- Rewrite_For_Equal_Lengths -- 14536 ------------------------------- 14537 14538 procedure Rewrite_For_Equal_Lengths is 14539 begin 14540 case Op is 14541 when N_Op_Eq 14542 | N_Op_Ge 14543 | N_Op_Le 14544 => 14545 Rewrite (N, 14546 Convert_To (Typ, 14547 New_Occurrence_Of (Standard_True, Sloc (N)))); 14548 14549 when N_Op_Ne 14550 | N_Op_Gt 14551 | N_Op_Lt 14552 => 14553 Rewrite (N, 14554 Convert_To (Typ, 14555 New_Occurrence_Of (Standard_False, Sloc (N)))); 14556 14557 when others => 14558 raise Program_Error; 14559 end case; 14560 14561 Analyze_And_Resolve (N, Typ); 14562 end Rewrite_For_Equal_Lengths; 14563 14564 -- Start of processing for Optimize_Length_Comparison 14565 14566 begin 14567 -- Nothing to do if not a comparison 14568 14569 if Op not in N_Op_Compare then 14570 return; 14571 end if; 14572 14573 -- Nothing to do if special -gnatd.P debug flag set. 14574 14575 if Debug_Flag_Dot_PP then 14576 return; 14577 end if; 14578 14579 -- Ent'Length op 0/1 14580 14581 if Is_Entity_Length (Left_Opnd (N), 1) 14582 and then Is_Optimizable (Right_Opnd (N)) 14583 then 14584 null; 14585 14586 -- 0/1 op Ent'Length 14587 14588 elsif Is_Entity_Length (Right_Opnd (N), 1) 14589 and then Is_Optimizable (Left_Opnd (N)) 14590 then 14591 -- Flip comparison to opposite sense 14592 14593 case Op is 14594 when N_Op_Lt => Op := N_Op_Gt; 14595 when N_Op_Le => Op := N_Op_Ge; 14596 when N_Op_Gt => Op := N_Op_Lt; 14597 when N_Op_Ge => Op := N_Op_Le; 14598 when others => null; 14599 end case; 14600 14601 -- Else optimization not possible 14602 14603 else 14604 return; 14605 end if; 14606 14607 -- Fall through if we will do the optimization 14608 14609 -- Cases to handle: 14610 14611 -- X'Length = 0 => X'First > X'Last 14612 -- X'Length = 1 => X'First = X'Last 14613 -- X'Length = n => X'First + (n - 1) = X'Last 14614 14615 -- X'Length /= 0 => X'First <= X'Last 14616 -- X'Length /= 1 => X'First /= X'Last 14617 -- X'Length /= n => X'First + (n - 1) /= X'Last 14618 14619 -- X'Length >= 0 => always true, warn 14620 -- X'Length >= 1 => X'First <= X'Last 14621 -- X'Length >= n => X'First + (n - 1) <= X'Last 14622 14623 -- X'Length > 0 => X'First <= X'Last 14624 -- X'Length > 1 => X'First < X'Last 14625 -- X'Length > n => X'First + (n - 1) < X'Last 14626 14627 -- X'Length <= 0 => X'First > X'Last (warn, could be =) 14628 -- X'Length <= 1 => X'First >= X'Last 14629 -- X'Length <= n => X'First + (n - 1) >= X'Last 14630 14631 -- X'Length < 0 => always false (warn) 14632 -- X'Length < 1 => X'First > X'Last 14633 -- X'Length < n => X'First + (n - 1) > X'Last 14634 14635 -- Note: for the cases of n (not constant 0,1), we require that the 14636 -- corresponding index type be integer or shorter (i.e. not 64-bit), 14637 -- and the same for the comparison value. Then we do the comparison 14638 -- using 64-bit arithmetic (actually long long integer), so that we 14639 -- cannot have overflow intefering with the result. 14640 14641 -- First deal with warning cases 14642 14643 if Is_Zero then 14644 case Op is 14645 14646 -- X'Length >= 0 14647 14648 when N_Op_Ge => 14649 Rewrite (N, 14650 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc))); 14651 Analyze_And_Resolve (N, Typ); 14652 Warn_On_Known_Condition (N); 14653 return; 14654 14655 -- X'Length < 0 14656 14657 when N_Op_Lt => 14658 Rewrite (N, 14659 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc))); 14660 Analyze_And_Resolve (N, Typ); 14661 Warn_On_Known_Condition (N); 14662 return; 14663 14664 when N_Op_Le => 14665 if Constant_Condition_Warnings 14666 and then Comes_From_Source (Original_Node (N)) 14667 then 14668 Error_Msg_N ("could replace by ""'=""?c?", N); 14669 end if; 14670 14671 Op := N_Op_Eq; 14672 14673 when others => 14674 null; 14675 end case; 14676 end if; 14677 14678 -- Build the First reference we will use 14679 14680 Left := 14681 Make_Attribute_Reference (Loc, 14682 Prefix => New_Occurrence_Of (Ent (1), Loc), 14683 Attribute_Name => Name_First); 14684 14685 if Present (Index (1)) then 14686 Set_Expressions (Left, New_List (New_Copy (Index (1)))); 14687 end if; 14688 14689 -- Build the Last reference we will use 14690 14691 Right := 14692 Make_Attribute_Reference (Loc, 14693 Prefix => New_Occurrence_Of (Ent (1), Loc), 14694 Attribute_Name => Name_Last); 14695 14696 if Present (Index (1)) then 14697 Set_Expressions (Right, New_List (New_Copy (Index (1)))); 14698 end if; 14699 14700 -- If general value case, then do the addition of (n - 1), and 14701 -- also add the needed conversions to type Long_Long_Integer. 14702 14703 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into: 14704 14705 -- Y'Last + (X'First - Y'First) op X'Last 14706 14707 -- in the hope that X'First - Y'First can be computed statically. 14708 14709 if Present (Comp) then 14710 if Present (Ent (2)) then 14711 declare 14712 Y_First : constant Node_Id := 14713 Make_Attribute_Reference (Loc, 14714 Prefix => New_Occurrence_Of (Ent (2), Loc), 14715 Attribute_Name => Name_First); 14716 Y_Last : constant Node_Id := 14717 Make_Attribute_Reference (Loc, 14718 Prefix => New_Occurrence_Of (Ent (2), Loc), 14719 Attribute_Name => Name_Last); 14720 R : Compare_Result; 14721 14722 begin 14723 if Present (Index (2)) then 14724 Set_Expressions (Y_First, New_List (New_Copy (Index (2)))); 14725 Set_Expressions (Y_Last, New_List (New_Copy (Index (2)))); 14726 end if; 14727 14728 Analyze (Left); 14729 Analyze (Y_First); 14730 14731 -- If X'First = Y'First, simplify the above formula into a 14732 -- direct comparison of Y'Last and X'Last. 14733 14734 R := Compile_Time_Compare (Left, Y_First, Assume_Valid => True); 14735 14736 if R = EQ then 14737 Analyze (Right); 14738 Analyze (Y_Last); 14739 14740 R := Compile_Time_Compare 14741 (Right, Y_Last, Assume_Valid => True); 14742 14743 -- If the pairs of attributes are equal, we are done 14744 14745 if R = EQ then 14746 Rewrite_For_Equal_Lengths; 14747 return; 14748 end if; 14749 14750 -- If the base types are different, convert both operands to 14751 -- Long_Long_Integer, else compare them directly. 14752 14753 if Base_Type (Etype (Right)) /= Base_Type (Etype (Y_Last)) 14754 then 14755 Left := Convert_To_Long_Long_Integer (Y_Last); 14756 else 14757 Left := Y_Last; 14758 Comp := Empty; 14759 end if; 14760 14761 -- Otherwise, use the above formula as-is 14762 14763 else 14764 Left := 14765 Make_Op_Add (Loc, 14766 Left_Opnd => 14767 Convert_To_Long_Long_Integer (Y_Last), 14768 Right_Opnd => 14769 Make_Op_Subtract (Loc, 14770 Left_Opnd => 14771 Convert_To_Long_Long_Integer (Left), 14772 Right_Opnd => 14773 Convert_To_Long_Long_Integer (Y_First))); 14774 end if; 14775 end; 14776 14777 -- General value case 14778 14779 else 14780 Left := 14781 Make_Op_Add (Loc, 14782 Left_Opnd => Convert_To_Long_Long_Integer (Left), 14783 Right_Opnd => 14784 Make_Op_Subtract (Loc, 14785 Left_Opnd => Convert_To_Long_Long_Integer (Comp), 14786 Right_Opnd => Make_Integer_Literal (Loc, 1))); 14787 end if; 14788 end if; 14789 14790 -- We cannot do anything in the superflat case past this point 14791 14792 if Maybe_Superflat then 14793 return; 14794 end if; 14795 14796 -- If general operand, convert Last reference to Long_Long_Integer 14797 14798 if Present (Comp) then 14799 Right := Convert_To_Long_Long_Integer (Right); 14800 end if; 14801 14802 -- Check for cases to optimize 14803 14804 -- X'Length = 0 => X'First > X'Last 14805 -- X'Length < 1 => X'First > X'Last 14806 -- X'Length < n => X'First + (n - 1) > X'Last 14807 14808 if (Is_Zero and then Op = N_Op_Eq) 14809 or else (not Is_Zero and then Op = N_Op_Lt) 14810 then 14811 Result := 14812 Make_Op_Gt (Loc, 14813 Left_Opnd => Left, 14814 Right_Opnd => Right); 14815 14816 -- X'Length = 1 => X'First = X'Last 14817 -- X'Length = n => X'First + (n - 1) = X'Last 14818 14819 elsif not Is_Zero and then Op = N_Op_Eq then 14820 Result := 14821 Make_Op_Eq (Loc, 14822 Left_Opnd => Left, 14823 Right_Opnd => Right); 14824 14825 -- X'Length /= 0 => X'First <= X'Last 14826 -- X'Length > 0 => X'First <= X'Last 14827 14828 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then 14829 Result := 14830 Make_Op_Le (Loc, 14831 Left_Opnd => Left, 14832 Right_Opnd => Right); 14833 14834 -- X'Length /= 1 => X'First /= X'Last 14835 -- X'Length /= n => X'First + (n - 1) /= X'Last 14836 14837 elsif not Is_Zero and then Op = N_Op_Ne then 14838 Result := 14839 Make_Op_Ne (Loc, 14840 Left_Opnd => Left, 14841 Right_Opnd => Right); 14842 14843 -- X'Length >= 1 => X'First <= X'Last 14844 -- X'Length >= n => X'First + (n - 1) <= X'Last 14845 14846 elsif not Is_Zero and then Op = N_Op_Ge then 14847 Result := 14848 Make_Op_Le (Loc, 14849 Left_Opnd => Left, 14850 Right_Opnd => Right); 14851 14852 -- X'Length > 1 => X'First < X'Last 14853 -- X'Length > n => X'First + (n = 1) < X'Last 14854 14855 elsif not Is_Zero and then Op = N_Op_Gt then 14856 Result := 14857 Make_Op_Lt (Loc, 14858 Left_Opnd => Left, 14859 Right_Opnd => Right); 14860 14861 -- X'Length <= 1 => X'First >= X'Last 14862 -- X'Length <= n => X'First + (n - 1) >= X'Last 14863 14864 elsif not Is_Zero and then Op = N_Op_Le then 14865 Result := 14866 Make_Op_Ge (Loc, 14867 Left_Opnd => Left, 14868 Right_Opnd => Right); 14869 14870 -- Should not happen at this stage 14871 14872 else 14873 raise Program_Error; 14874 end if; 14875 14876 -- Rewrite and finish up (we can suppress overflow checks, see above) 14877 14878 Rewrite (N, Result); 14879 Analyze_And_Resolve (N, Typ, Suppress => Overflow_Check); 14880 end Optimize_Length_Comparison; 14881 14882 -------------------------------- 14883 -- Process_If_Case_Statements -- 14884 -------------------------------- 14885 14886 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is 14887 Decl : Node_Id; 14888 14889 begin 14890 Decl := First (Stmts); 14891 while Present (Decl) loop 14892 if Nkind (Decl) = N_Object_Declaration 14893 and then Is_Finalizable_Transient (Decl, N) 14894 then 14895 Process_Transient_In_Expression (Decl, N, Stmts); 14896 end if; 14897 14898 Next (Decl); 14899 end loop; 14900 end Process_If_Case_Statements; 14901 14902 ------------------------------------- 14903 -- Process_Transient_In_Expression -- 14904 ------------------------------------- 14905 14906 procedure Process_Transient_In_Expression 14907 (Obj_Decl : Node_Id; 14908 Expr : Node_Id; 14909 Stmts : List_Id) 14910 is 14911 Loc : constant Source_Ptr := Sloc (Obj_Decl); 14912 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); 14913 14914 Hook_Context : constant Node_Id := Find_Hook_Context (Expr); 14915 -- The node on which to insert the hook as an action. This is usually 14916 -- the innermost enclosing non-transient construct. 14917 14918 Fin_Call : Node_Id; 14919 Hook_Assign : Node_Id; 14920 Hook_Clear : Node_Id; 14921 Hook_Decl : Node_Id; 14922 Hook_Insert : Node_Id; 14923 Ptr_Decl : Node_Id; 14924 14925 Fin_Context : Node_Id; 14926 -- The node after which to insert the finalization actions of the 14927 -- transient object. 14928 14929 begin 14930 pragma Assert (Nkind (Expr) in N_Case_Expression 14931 | N_Expression_With_Actions 14932 | N_If_Expression); 14933 14934 -- When the context is a Boolean evaluation, all three nodes capture the 14935 -- result of their computation in a local temporary: 14936 14937 -- do 14938 -- Trans_Id : Ctrl_Typ := ...; 14939 -- Result : constant Boolean := ... Trans_Id ...; 14940 -- <finalize Trans_Id> 14941 -- in Result end; 14942 14943 -- As a result, the finalization of any transient objects can safely 14944 -- take place after the result capture. 14945 14946 -- ??? could this be extended to elementary types? 14947 14948 if Is_Boolean_Type (Etype (Expr)) then 14949 Fin_Context := Last (Stmts); 14950 14951 -- Otherwise the immediate context may not be safe enough to carry 14952 -- out transient object finalization due to aliasing and nesting of 14953 -- constructs. Insert calls to [Deep_]Finalize after the innermost 14954 -- enclosing non-transient construct. 14955 14956 else 14957 Fin_Context := Hook_Context; 14958 end if; 14959 14960 -- Mark the transient object as successfully processed to avoid double 14961 -- finalization. 14962 14963 Set_Is_Finalized_Transient (Obj_Id); 14964 14965 -- Construct all the pieces necessary to hook and finalize a transient 14966 -- object. 14967 14968 Build_Transient_Object_Statements 14969 (Obj_Decl => Obj_Decl, 14970 Fin_Call => Fin_Call, 14971 Hook_Assign => Hook_Assign, 14972 Hook_Clear => Hook_Clear, 14973 Hook_Decl => Hook_Decl, 14974 Ptr_Decl => Ptr_Decl, 14975 Finalize_Obj => False); 14976 14977 -- Add the access type which provides a reference to the transient 14978 -- object. Generate: 14979 14980 -- type Ptr_Typ is access all Desig_Typ; 14981 14982 Insert_Action (Hook_Context, Ptr_Decl); 14983 14984 -- Add the temporary which acts as a hook to the transient object. 14985 -- Generate: 14986 14987 -- Hook : Ptr_Id := null; 14988 14989 Insert_Action (Hook_Context, Hook_Decl); 14990 14991 -- When the transient object is initialized by an aggregate, the hook 14992 -- must capture the object after the last aggregate assignment takes 14993 -- place. Only then is the object considered initialized. Generate: 14994 14995 -- Hook := Ptr_Typ (Obj_Id); 14996 -- <or> 14997 -- Hook := Obj_Id'Unrestricted_Access; 14998 14999 if Ekind (Obj_Id) in E_Constant | E_Variable 15000 and then Present (Last_Aggregate_Assignment (Obj_Id)) 15001 then 15002 Hook_Insert := Last_Aggregate_Assignment (Obj_Id); 15003 15004 -- Otherwise the hook seizes the related object immediately 15005 15006 else 15007 Hook_Insert := Obj_Decl; 15008 end if; 15009 15010 Insert_After_And_Analyze (Hook_Insert, Hook_Assign); 15011 15012 -- When the node is part of a return statement, there is no need to 15013 -- insert a finalization call, as the general finalization mechanism 15014 -- (see Build_Finalizer) would take care of the transient object on 15015 -- subprogram exit. Note that it would also be impossible to insert the 15016 -- finalization code after the return statement as this will render it 15017 -- unreachable. 15018 15019 if Nkind (Fin_Context) = N_Simple_Return_Statement then 15020 null; 15021 15022 -- Finalize the hook after the context has been evaluated. Generate: 15023 15024 -- if Hook /= null then 15025 -- [Deep_]Finalize (Hook.all); 15026 -- Hook := null; 15027 -- end if; 15028 15029 else 15030 Insert_Action_After (Fin_Context, 15031 Make_Implicit_If_Statement (Obj_Decl, 15032 Condition => 15033 Make_Op_Ne (Loc, 15034 Left_Opnd => 15035 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc), 15036 Right_Opnd => Make_Null (Loc)), 15037 15038 Then_Statements => New_List ( 15039 Fin_Call, 15040 Hook_Clear))); 15041 end if; 15042 end Process_Transient_In_Expression; 15043 15044 ------------------------ 15045 -- Rewrite_Comparison -- 15046 ------------------------ 15047 15048 procedure Rewrite_Comparison (N : Node_Id) is 15049 Typ : constant Entity_Id := Etype (N); 15050 15051 False_Result : Boolean; 15052 True_Result : Boolean; 15053 15054 begin 15055 if Nkind (N) = N_Type_Conversion then 15056 Rewrite_Comparison (Expression (N)); 15057 return; 15058 15059 elsif Nkind (N) not in N_Op_Compare then 15060 return; 15061 end if; 15062 15063 -- If both operands are static, then the comparison has been already 15064 -- folded in evaluation. 15065 15066 pragma Assert 15067 (not Is_Static_Expression (Left_Opnd (N)) 15068 or else 15069 not Is_Static_Expression (Right_Opnd (N))); 15070 15071 -- Determine the potential outcome of the comparison assuming that the 15072 -- operands are valid and emit a warning when the comparison evaluates 15073 -- to True or False only in the presence of invalid values. 15074 15075 Warn_On_Constant_Valid_Condition (N); 15076 15077 -- Determine the potential outcome of the comparison assuming that the 15078 -- operands are not valid. 15079 15080 Test_Comparison 15081 (Op => N, 15082 Assume_Valid => False, 15083 True_Result => True_Result, 15084 False_Result => False_Result); 15085 15086 -- The outcome is a decisive False or True, rewrite the operator into a 15087 -- non-static literal. 15088 15089 if False_Result or True_Result then 15090 Rewrite (N, 15091 Convert_To (Typ, 15092 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N)))); 15093 15094 Analyze_And_Resolve (N, Typ); 15095 Set_Is_Static_Expression (N, False); 15096 Warn_On_Known_Condition (N); 15097 end if; 15098 end Rewrite_Comparison; 15099 15100 ---------------------------- 15101 -- Safe_In_Place_Array_Op -- 15102 ---------------------------- 15103 15104 function Safe_In_Place_Array_Op 15105 (Lhs : Node_Id; 15106 Op1 : Node_Id; 15107 Op2 : Node_Id) return Boolean 15108 is 15109 Target : Entity_Id; 15110 15111 function Is_Safe_Operand (Op : Node_Id) return Boolean; 15112 -- Operand is safe if it cannot overlap part of the target of the 15113 -- operation. If the operand and the target are identical, the operand 15114 -- is safe. The operand can be empty in the case of negation. 15115 15116 function Is_Unaliased (N : Node_Id) return Boolean; 15117 -- Check that N is a stand-alone entity 15118 15119 ------------------ 15120 -- Is_Unaliased -- 15121 ------------------ 15122 15123 function Is_Unaliased (N : Node_Id) return Boolean is 15124 begin 15125 return 15126 Is_Entity_Name (N) 15127 and then No (Address_Clause (Entity (N))) 15128 and then No (Renamed_Object (Entity (N))); 15129 end Is_Unaliased; 15130 15131 --------------------- 15132 -- Is_Safe_Operand -- 15133 --------------------- 15134 15135 function Is_Safe_Operand (Op : Node_Id) return Boolean is 15136 begin 15137 if No (Op) then 15138 return True; 15139 15140 elsif Is_Entity_Name (Op) then 15141 return Is_Unaliased (Op); 15142 15143 elsif Nkind (Op) in N_Indexed_Component | N_Selected_Component then 15144 return Is_Unaliased (Prefix (Op)); 15145 15146 elsif Nkind (Op) = N_Slice then 15147 return 15148 Is_Unaliased (Prefix (Op)) 15149 and then Entity (Prefix (Op)) /= Target; 15150 15151 elsif Nkind (Op) = N_Op_Not then 15152 return Is_Safe_Operand (Right_Opnd (Op)); 15153 15154 else 15155 return False; 15156 end if; 15157 end Is_Safe_Operand; 15158 15159 -- Start of processing for Safe_In_Place_Array_Op 15160 15161 begin 15162 -- Skip this processing if the component size is different from system 15163 -- storage unit (since at least for NOT this would cause problems). 15164 15165 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then 15166 return False; 15167 15168 -- Cannot do in place stuff if non-standard Boolean representation 15169 15170 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then 15171 return False; 15172 15173 elsif not Is_Unaliased (Lhs) then 15174 return False; 15175 15176 else 15177 Target := Entity (Lhs); 15178 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); 15179 end if; 15180 end Safe_In_Place_Array_Op; 15181 15182 ----------------------- 15183 -- Tagged_Membership -- 15184 ----------------------- 15185 15186 -- There are two different cases to consider depending on whether the right 15187 -- operand is a class-wide type or not. If not we just compare the actual 15188 -- tag of the left expr to the target type tag: 15189 -- 15190 -- Left_Expr.Tag = Right_Type'Tag; 15191 -- 15192 -- If it is a class-wide type we use the RT function CW_Membership which is 15193 -- usually implemented by looking in the ancestor tables contained in the 15194 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag 15195 15196 -- In both cases if Left_Expr is an access type, we first check whether it 15197 -- is null. 15198 15199 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT 15200 -- function IW_Membership which is usually implemented by looking in the 15201 -- table of abstract interface types plus the ancestor table contained in 15202 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag 15203 15204 procedure Tagged_Membership 15205 (N : Node_Id; 15206 SCIL_Node : out Node_Id; 15207 Result : out Node_Id) 15208 is 15209 Left : constant Node_Id := Left_Opnd (N); 15210 Right : constant Node_Id := Right_Opnd (N); 15211 Loc : constant Source_Ptr := Sloc (N); 15212 15213 -- Handle entities from the limited view 15214 15215 Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right)); 15216 15217 Full_R_Typ : Entity_Id; 15218 Left_Type : Entity_Id := Available_View (Etype (Left)); 15219 Right_Type : Entity_Id := Orig_Right_Type; 15220 Obj_Tag : Node_Id; 15221 15222 begin 15223 SCIL_Node := Empty; 15224 15225 -- In the case where the type is an access type, the test is applied 15226 -- using the designated types (needed in Ada 2012 for implicit anonymous 15227 -- access conversions, for AI05-0149). 15228 15229 if Is_Access_Type (Right_Type) then 15230 Left_Type := Designated_Type (Left_Type); 15231 Right_Type := Designated_Type (Right_Type); 15232 end if; 15233 15234 if Is_Class_Wide_Type (Left_Type) then 15235 Left_Type := Root_Type (Left_Type); 15236 end if; 15237 15238 if Is_Class_Wide_Type (Right_Type) then 15239 Full_R_Typ := Underlying_Type (Root_Type (Right_Type)); 15240 else 15241 Full_R_Typ := Underlying_Type (Right_Type); 15242 end if; 15243 15244 Obj_Tag := 15245 Make_Selected_Component (Loc, 15246 Prefix => Relocate_Node (Left), 15247 Selector_Name => 15248 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc)); 15249 15250 if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then 15251 15252 -- No need to issue a run-time check if we statically know that the 15253 -- result of this membership test is always true. For example, 15254 -- considering the following declarations: 15255 15256 -- type Iface is interface; 15257 -- type T is tagged null record; 15258 -- type DT is new T and Iface with null record; 15259 15260 -- Obj1 : T; 15261 -- Obj2 : DT; 15262 15263 -- These membership tests are always true: 15264 15265 -- Obj1 in T'Class 15266 -- Obj2 in T'Class; 15267 -- Obj2 in Iface'Class; 15268 15269 -- We do not need to handle cases where the membership is illegal. 15270 -- For example: 15271 15272 -- Obj1 in DT'Class; -- Compile time error 15273 -- Obj1 in Iface'Class; -- Compile time error 15274 15275 if not Is_Interface (Left_Type) 15276 and then not Is_Class_Wide_Type (Left_Type) 15277 and then (Is_Ancestor (Etype (Right_Type), Left_Type, 15278 Use_Full_View => True) 15279 or else (Is_Interface (Etype (Right_Type)) 15280 and then Interface_Present_In_Ancestor 15281 (Typ => Left_Type, 15282 Iface => Etype (Right_Type)))) 15283 then 15284 Result := New_Occurrence_Of (Standard_True, Loc); 15285 return; 15286 end if; 15287 15288 -- Ada 2005 (AI-251): Class-wide applied to interfaces 15289 15290 if Is_Interface (Etype (Class_Wide_Type (Right_Type))) 15291 15292 -- Support to: "Iface_CW_Typ in Typ'Class" 15293 15294 or else Is_Interface (Left_Type) 15295 then 15296 -- Issue error if IW_Membership operation not available in a 15297 -- configurable run-time setting. 15298 15299 if not RTE_Available (RE_IW_Membership) then 15300 Error_Msg_CRT 15301 ("dynamic membership test on interface types", N); 15302 Result := Empty; 15303 return; 15304 end if; 15305 15306 Result := 15307 Make_Function_Call (Loc, 15308 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), 15309 Parameter_Associations => New_List ( 15310 Make_Attribute_Reference (Loc, 15311 Prefix => Obj_Tag, 15312 Attribute_Name => Name_Address), 15313 New_Occurrence_Of ( 15314 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), 15315 Loc))); 15316 15317 -- Ada 95: Normal case 15318 15319 else 15320 -- Issue error if CW_Membership operation not available in a 15321 -- configurable run-time setting. 15322 15323 if not RTE_Available (RE_CW_Membership) then 15324 Error_Msg_CRT 15325 ("dynamic membership test on tagged types", N); 15326 Result := Empty; 15327 return; 15328 end if; 15329 15330 Result := 15331 Make_Function_Call (Loc, 15332 Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc), 15333 Parameter_Associations => New_List ( 15334 Obj_Tag, 15335 New_Occurrence_Of ( 15336 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), 15337 Loc))); 15338 15339 -- Generate the SCIL node for this class-wide membership test. 15340 15341 if Generate_SCIL then 15342 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); 15343 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); 15344 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); 15345 end if; 15346 end if; 15347 15348 -- Right_Type is not a class-wide type 15349 15350 else 15351 -- No need to check the tag of the object if Right_Typ is abstract 15352 15353 if Is_Abstract_Type (Right_Type) then 15354 Result := New_Occurrence_Of (Standard_False, Loc); 15355 15356 else 15357 Result := 15358 Make_Op_Eq (Loc, 15359 Left_Opnd => Obj_Tag, 15360 Right_Opnd => 15361 New_Occurrence_Of 15362 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc)); 15363 end if; 15364 end if; 15365 15366 -- if Left is an access object then generate test of the form: 15367 -- * if Right_Type excludes null: Left /= null and then ... 15368 -- * if Right_Type includes null: Left = null or else ... 15369 15370 if Is_Access_Type (Orig_Right_Type) then 15371 if Can_Never_Be_Null (Orig_Right_Type) then 15372 Result := Make_And_Then (Loc, 15373 Left_Opnd => 15374 Make_Op_Ne (Loc, 15375 Left_Opnd => Left, 15376 Right_Opnd => Make_Null (Loc)), 15377 Right_Opnd => Result); 15378 15379 else 15380 Result := Make_Or_Else (Loc, 15381 Left_Opnd => 15382 Make_Op_Eq (Loc, 15383 Left_Opnd => Left, 15384 Right_Opnd => Make_Null (Loc)), 15385 Right_Opnd => Result); 15386 end if; 15387 end if; 15388 end Tagged_Membership; 15389 15390 ------------------------------ 15391 -- Unary_Op_Validity_Checks -- 15392 ------------------------------ 15393 15394 procedure Unary_Op_Validity_Checks (N : Node_Id) is 15395 begin 15396 if Validity_Checks_On and Validity_Check_Operands then 15397 Ensure_Valid (Right_Opnd (N)); 15398 end if; 15399 end Unary_Op_Validity_Checks; 15400 15401end Exp_Ch4; 15402