1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ I N T R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Expander; use Expander; 31with Exp_Atag; use Exp_Atag; 32with Exp_Ch4; use Exp_Ch4; 33with Exp_Ch7; use Exp_Ch7; 34with Exp_Ch11; use Exp_Ch11; 35with Exp_Code; use Exp_Code; 36with Exp_Fixd; use Exp_Fixd; 37with Exp_Util; use Exp_Util; 38with Freeze; use Freeze; 39with Namet; use Namet; 40with Nmake; use Nmake; 41with Nlists; use Nlists; 42with Opt; use Opt; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Rtsfind; use Rtsfind; 46with Sem; use Sem; 47with Sem_Aux; use Sem_Aux; 48with Sem_Eval; use Sem_Eval; 49with Sem_Res; use Sem_Res; 50with Sem_Type; use Sem_Type; 51with Sem_Util; use Sem_Util; 52with Sinfo; use Sinfo; 53with Sinput; use Sinput; 54with Snames; use Snames; 55with Stand; use Stand; 56with Stringt; use Stringt; 57with Targparm; use Targparm; 58with Tbuild; use Tbuild; 59with Uintp; use Uintp; 60with Urealp; use Urealp; 61 62package body Exp_Intr is 63 64 ----------------------- 65 -- Local Subprograms -- 66 ----------------------- 67 68 procedure Expand_Binary_Operator_Call (N : Node_Id); 69 -- Expand a call to an intrinsic arithmetic operator when the operand 70 -- types or sizes are not identical. 71 72 procedure Expand_Is_Negative (N : Node_Id); 73 -- Expand a call to the intrinsic Is_Negative function 74 75 procedure Expand_Dispatching_Constructor_Call (N : Node_Id); 76 -- Expand a call to an instantiation of Generic_Dispatching_Constructor 77 -- into a dispatching call to the actual subprogram associated with the 78 -- Constructor formal subprogram, passing it the Parameters actual of 79 -- the call to the instantiation and dispatching based on call's Tag 80 -- parameter. 81 82 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); 83 -- Expand a call to Exception_Information/Message/Name. The first 84 -- parameter, N, is the node for the function call, and Ent is the 85 -- entity for the corresponding routine in the Ada.Exceptions package. 86 87 procedure Expand_Import_Call (N : Node_Id); 88 -- Expand a call to Import_Address/Longest_Integer/Value. The parameter 89 -- N is the node for the function call. 90 91 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); 92 -- Expand an intrinsic shift operation, N and E are from the call to 93 -- Expand_Intrinsic_Call (call node and subprogram spec entity) and 94 -- K is the kind for the shift node 95 96 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); 97 -- Expand a call to an instantiation of Unchecked_Conversion into a node 98 -- N_Unchecked_Type_Conversion. 99 100 procedure Expand_Unc_Deallocation (N : Node_Id); 101 -- Expand a call to an instantiation of Unchecked_Deallocation into a node 102 -- N_Free_Statement and appropriate context. 103 104 procedure Expand_To_Address (N : Node_Id); 105 procedure Expand_To_Pointer (N : Node_Id); 106 -- Expand a call to corresponding function, declared in an instance of 107 -- System.Address_To_Access_Conversions. 108 109 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); 110 -- Rewrite the node by the appropriate string or positive constant. 111 -- Nam can be one of the following: 112 -- Name_File - expand string that is the name of source file 113 -- Name_Line - expand integer line number 114 -- Name_Source_Location - expand string of form file:line 115 -- Name_Enclosing_Entity - expand string with name of enclosing entity 116 117 --------------------------------- 118 -- Expand_Binary_Operator_Call -- 119 --------------------------------- 120 121 procedure Expand_Binary_Operator_Call (N : Node_Id) is 122 T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N))); 123 T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N))); 124 TR : constant Entity_Id := Etype (N); 125 T3 : Entity_Id; 126 Res : Node_Id; 127 128 Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2)); 129 -- Maximum of operand sizes 130 131 begin 132 -- Nothing to do if the operands have the same modular type 133 134 if Base_Type (T1) = Base_Type (T2) 135 and then Is_Modular_Integer_Type (T1) 136 then 137 return; 138 end if; 139 140 -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64 141 142 if Siz > 32 then 143 T3 := RTE (RE_Unsigned_64); 144 else 145 T3 := RTE (RE_Unsigned_32); 146 end if; 147 148 -- Copy operator node, and reset type and entity fields, for 149 -- subsequent reanalysis. 150 151 Res := New_Copy (N); 152 Set_Etype (Res, T3); 153 154 case Nkind (N) is 155 when N_Op_And => 156 Set_Entity (Res, Standard_Op_And); 157 when N_Op_Or => 158 Set_Entity (Res, Standard_Op_Or); 159 when N_Op_Xor => 160 Set_Entity (Res, Standard_Op_Xor); 161 when others => 162 raise Program_Error; 163 end case; 164 165 -- Convert operands to large enough intermediate type 166 167 Set_Left_Opnd (Res, 168 Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N)))); 169 Set_Right_Opnd (Res, 170 Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N)))); 171 172 -- Analyze and resolve result formed by conversion to target type 173 174 Rewrite (N, Unchecked_Convert_To (TR, Res)); 175 Analyze_And_Resolve (N, TR); 176 end Expand_Binary_Operator_Call; 177 178 ----------------------------------------- 179 -- Expand_Dispatching_Constructor_Call -- 180 ----------------------------------------- 181 182 -- Transform a call to an instantiation of Generic_Dispatching_Constructor 183 -- of the form: 184 185 -- GDC_Instance (The_Tag, Parameters'Access) 186 187 -- to a class-wide conversion of a dispatching call to the actual 188 -- associated with the formal subprogram Construct, designating The_Tag 189 -- as the controlling tag of the call: 190 191 -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag 192 193 -- which will eventually be expanded to the following: 194 195 -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params)) 196 197 -- A class-wide membership test is also generated, preceding the call, to 198 -- ensure that the controlling tag denotes a type in T'Class. 199 200 procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is 201 Loc : constant Source_Ptr := Sloc (N); 202 Tag_Arg : constant Node_Id := First_Actual (N); 203 Param_Arg : constant Node_Id := Next_Actual (Tag_Arg); 204 Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N)))); 205 Inst_Pkg : constant Node_Id := Parent (Subp_Decl); 206 Act_Rename : Node_Id; 207 Act_Constr : Entity_Id; 208 Iface_Tag : Node_Id := Empty; 209 Cnstr_Call : Node_Id; 210 Result_Typ : Entity_Id; 211 212 begin 213 -- Remove side effects from tag argument early, before rewriting 214 -- the dispatching constructor call, as Remove_Side_Effects relies 215 -- on Tag_Arg's Parent link properly attached to the tree (once the 216 -- call is rewritten, the Parent is inconsistent as it points to the 217 -- rewritten node, which is not the syntactic parent of the Tag_Arg 218 -- anymore). 219 220 Remove_Side_Effects (Tag_Arg); 221 222 -- The subprogram is the third actual in the instantiation, and is 223 -- retrieved from the corresponding renaming declaration. However, 224 -- freeze nodes may appear before, so we retrieve the declaration 225 -- with an explicit loop. 226 227 Act_Rename := First (Visible_Declarations (Inst_Pkg)); 228 while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop 229 Next (Act_Rename); 230 end loop; 231 232 Act_Constr := Entity (Name (Act_Rename)); 233 Result_Typ := Class_Wide_Type (Etype (Act_Constr)); 234 235 if Is_Interface (Etype (Act_Constr)) then 236 237 -- If the result type is not known to be a parent of Tag_Arg then we 238 -- need to locate the tag of the secondary dispatch table. 239 240 if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg), 241 Use_Full_View => True) 242 and then Tagged_Type_Expansion 243 then 244 -- Obtain the reference to the Ada.Tags service before generating 245 -- the Object_Declaration node to ensure that if this service is 246 -- not available in the runtime then we generate a clear error. 247 248 declare 249 Fname : constant Node_Id := 250 New_Occurrence_Of (RTE (RE_Secondary_Tag), Loc); 251 252 begin 253 pragma Assert (not Is_Interface (Etype (Tag_Arg))); 254 255 Iface_Tag := 256 Make_Object_Declaration (Loc, 257 Defining_Identifier => Make_Temporary (Loc, 'V'), 258 Object_Definition => 259 New_Occurrence_Of (RTE (RE_Tag), Loc), 260 Expression => 261 Make_Function_Call (Loc, 262 Name => Fname, 263 Parameter_Associations => New_List ( 264 Relocate_Node (Tag_Arg), 265 New_Occurrence_Of 266 (Node (First_Elmt (Access_Disp_Table 267 (Etype (Etype (Act_Constr))))), 268 Loc)))); 269 Insert_Action (N, Iface_Tag); 270 end; 271 end if; 272 end if; 273 274 -- Create the call to the actual Constructor function 275 276 Cnstr_Call := 277 Make_Function_Call (Loc, 278 Name => New_Occurrence_Of (Act_Constr, Loc), 279 Parameter_Associations => New_List (Relocate_Node (Param_Arg))); 280 281 -- Establish its controlling tag from the tag passed to the instance 282 -- The tag may be given by a function call, in which case a temporary 283 -- should be generated now, to prevent out-of-order insertions during 284 -- the expansion of that call when stack-checking is enabled. 285 286 if Present (Iface_Tag) then 287 Set_Controlling_Argument (Cnstr_Call, 288 New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc)); 289 else 290 Set_Controlling_Argument (Cnstr_Call, 291 Relocate_Node (Tag_Arg)); 292 end if; 293 294 -- Rewrite and analyze the call to the instance as a class-wide 295 -- conversion of the call to the actual constructor. 296 297 Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); 298 Analyze_And_Resolve (N, Etype (Act_Constr)); 299 300 -- Do not generate a run-time check on the built object if tag 301 -- checks are suppressed for the result type or VM_Target /= No_VM 302 303 if Tag_Checks_Suppressed (Etype (Result_Typ)) 304 or else not Tagged_Type_Expansion 305 then 306 null; 307 308 -- Generate a class-wide membership test to ensure that the call's tag 309 -- argument denotes a type within the class. We must keep separate the 310 -- case in which the Result_Type of the constructor function is a tagged 311 -- type from the case in which it is an abstract interface because the 312 -- run-time subprogram required to check these cases differ (and have 313 -- one difference in their parameters profile). 314 315 -- Call CW_Membership if the Result_Type is a tagged type to look for 316 -- the tag in the table of ancestor tags. 317 318 elsif not Is_Interface (Result_Typ) then 319 declare 320 Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg); 321 CW_Test_Node : Node_Id; 322 323 begin 324 Build_CW_Membership (Loc, 325 Obj_Tag_Node => Obj_Tag_Node, 326 Typ_Tag_Node => 327 New_Occurrence_Of ( 328 Node (First_Elmt (Access_Disp_Table ( 329 Root_Type (Result_Typ)))), Loc), 330 Related_Nod => N, 331 New_Node => CW_Test_Node); 332 333 Insert_Action (N, 334 Make_Implicit_If_Statement (N, 335 Condition => 336 Make_Op_Not (Loc, CW_Test_Node), 337 Then_Statements => 338 New_List (Make_Raise_Statement (Loc, 339 New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); 340 end; 341 342 -- Call IW_Membership test if the Result_Type is an abstract interface 343 -- to look for the tag in the table of interface tags. 344 345 else 346 Insert_Action (N, 347 Make_Implicit_If_Statement (N, 348 Condition => 349 Make_Op_Not (Loc, 350 Make_Function_Call (Loc, 351 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), 352 Parameter_Associations => New_List ( 353 Make_Attribute_Reference (Loc, 354 Prefix => New_Copy_Tree (Tag_Arg), 355 Attribute_Name => Name_Address), 356 357 New_Occurrence_Of ( 358 Node (First_Elmt (Access_Disp_Table ( 359 Root_Type (Result_Typ)))), Loc)))), 360 Then_Statements => 361 New_List ( 362 Make_Raise_Statement (Loc, 363 Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); 364 end if; 365 end Expand_Dispatching_Constructor_Call; 366 367 --------------------------- 368 -- Expand_Exception_Call -- 369 --------------------------- 370 371 -- If the function call is not within an exception handler, then the call 372 -- is replaced by a null string. Otherwise the appropriate routine in 373 -- Ada.Exceptions is called passing the choice parameter specification 374 -- from the enclosing handler. If the enclosing handler lacks a choice 375 -- parameter, then one is supplied. 376 377 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is 378 Loc : constant Source_Ptr := Sloc (N); 379 P : Node_Id; 380 E : Entity_Id; 381 382 begin 383 -- Climb up parents to see if we are in exception handler 384 385 P := Parent (N); 386 loop 387 -- Case of not in exception handler, replace by null string 388 389 if No (P) then 390 Rewrite (N, 391 Make_String_Literal (Loc, 392 Strval => "")); 393 exit; 394 395 -- Case of in exception handler 396 397 elsif Nkind (P) = N_Exception_Handler then 398 399 -- Handler cannot be used for a local raise, and furthermore, this 400 -- is a violation of the No_Exception_Propagation restriction. 401 402 Set_Local_Raise_Not_OK (P); 403 Check_Restriction (No_Exception_Propagation, N); 404 405 -- If no choice parameter present, then put one there. Note that 406 -- we do not need to put it on the entity chain, since no one will 407 -- be referencing it by normal visibility methods. 408 409 if No (Choice_Parameter (P)) then 410 E := Make_Temporary (Loc, 'E'); 411 Set_Choice_Parameter (P, E); 412 Set_Ekind (E, E_Variable); 413 Set_Etype (E, RTE (RE_Exception_Occurrence)); 414 Set_Scope (E, Current_Scope); 415 end if; 416 417 Rewrite (N, 418 Make_Function_Call (Loc, 419 Name => New_Occurrence_Of (RTE (Ent), Loc), 420 Parameter_Associations => New_List ( 421 New_Occurrence_Of (Choice_Parameter (P), Loc)))); 422 exit; 423 424 -- Keep climbing 425 426 else 427 P := Parent (P); 428 end if; 429 end loop; 430 431 Analyze_And_Resolve (N, Standard_String); 432 end Expand_Exception_Call; 433 434 ------------------------ 435 -- Expand_Import_Call -- 436 ------------------------ 437 438 -- The function call must have a static string as its argument. We create 439 -- a dummy variable which uses this string as the external name in an 440 -- Import pragma. The result is then obtained as the address of this 441 -- dummy variable, converted to the appropriate target type. 442 443 procedure Expand_Import_Call (N : Node_Id) is 444 Loc : constant Source_Ptr := Sloc (N); 445 Ent : constant Entity_Id := Entity (Name (N)); 446 Str : constant Node_Id := First_Actual (N); 447 Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); 448 449 begin 450 Insert_Actions (N, New_List ( 451 Make_Object_Declaration (Loc, 452 Defining_Identifier => Dum, 453 Object_Definition => 454 New_Occurrence_Of (Standard_Character, Loc)), 455 456 Make_Pragma (Loc, 457 Chars => Name_Import, 458 Pragma_Argument_Associations => New_List ( 459 Make_Pragma_Argument_Association (Loc, 460 Expression => Make_Identifier (Loc, Name_Ada)), 461 462 Make_Pragma_Argument_Association (Loc, 463 Expression => Make_Identifier (Loc, Chars (Dum))), 464 465 Make_Pragma_Argument_Association (Loc, 466 Chars => Name_Link_Name, 467 Expression => Relocate_Node (Str)))))); 468 469 Rewrite (N, 470 Unchecked_Convert_To (Etype (Ent), 471 Make_Attribute_Reference (Loc, 472 Prefix => Make_Identifier (Loc, Chars (Dum)), 473 Attribute_Name => Name_Address))); 474 475 Analyze_And_Resolve (N, Etype (Ent)); 476 end Expand_Import_Call; 477 478 --------------------------- 479 -- Expand_Intrinsic_Call -- 480 --------------------------- 481 482 procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is 483 Nam : Name_Id; 484 485 begin 486 -- If an external name is specified for the intrinsic, it is handled 487 -- by the back-end: leave the call node unchanged for now. 488 489 if Present (Interface_Name (E)) then 490 return; 491 end if; 492 493 -- If the intrinsic subprogram is generic, gets its original name 494 495 if Present (Parent (E)) 496 and then Present (Generic_Parent (Parent (E))) 497 then 498 Nam := Chars (Generic_Parent (Parent (E))); 499 else 500 Nam := Chars (E); 501 end if; 502 503 if Nam = Name_Asm then 504 Expand_Asm_Call (N); 505 506 elsif Nam = Name_Divide then 507 Expand_Decimal_Divide_Call (N); 508 509 elsif Nam = Name_Exception_Information then 510 Expand_Exception_Call (N, RE_Exception_Information); 511 512 elsif Nam = Name_Exception_Message then 513 Expand_Exception_Call (N, RE_Exception_Message); 514 515 elsif Nam = Name_Exception_Name then 516 Expand_Exception_Call (N, RE_Exception_Name_Simple); 517 518 elsif Nam = Name_Generic_Dispatching_Constructor then 519 Expand_Dispatching_Constructor_Call (N); 520 521 elsif Nam_In (Nam, Name_Import_Address, 522 Name_Import_Largest_Value, 523 Name_Import_Value) 524 then 525 Expand_Import_Call (N); 526 527 elsif Nam = Name_Is_Negative then 528 Expand_Is_Negative (N); 529 530 elsif Nam = Name_Rotate_Left then 531 Expand_Shift (N, E, N_Op_Rotate_Left); 532 533 elsif Nam = Name_Rotate_Right then 534 Expand_Shift (N, E, N_Op_Rotate_Right); 535 536 elsif Nam = Name_Shift_Left then 537 Expand_Shift (N, E, N_Op_Shift_Left); 538 539 elsif Nam = Name_Shift_Right then 540 Expand_Shift (N, E, N_Op_Shift_Right); 541 542 elsif Nam = Name_Shift_Right_Arithmetic then 543 Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); 544 545 elsif Nam = Name_Unchecked_Conversion then 546 Expand_Unc_Conversion (N, E); 547 548 elsif Nam = Name_Unchecked_Deallocation then 549 Expand_Unc_Deallocation (N); 550 551 elsif Nam = Name_To_Address then 552 Expand_To_Address (N); 553 554 elsif Nam = Name_To_Pointer then 555 Expand_To_Pointer (N); 556 557 elsif Nam_In (Nam, Name_File, 558 Name_Line, 559 Name_Source_Location, 560 Name_Enclosing_Entity) 561 then 562 Expand_Source_Info (N, Nam); 563 564 -- If we have a renaming, expand the call to the original operation, 565 -- which must itself be intrinsic, since renaming requires matching 566 -- conventions and this has already been checked. 567 568 elsif Present (Alias (E)) then 569 Expand_Intrinsic_Call (N, Alias (E)); 570 571 elsif Nkind (N) in N_Binary_Op then 572 Expand_Binary_Operator_Call (N); 573 574 -- The only other case is where an external name was specified, since 575 -- this is the only way that an otherwise unrecognized name could 576 -- escape the checking in Sem_Prag. Nothing needs to be done in such 577 -- a case, since we pass such a call to the back end unchanged. 578 579 else 580 null; 581 end if; 582 end Expand_Intrinsic_Call; 583 584 ------------------------ 585 -- Expand_Is_Negative -- 586 ------------------------ 587 588 procedure Expand_Is_Negative (N : Node_Id) is 589 Loc : constant Source_Ptr := Sloc (N); 590 Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); 591 592 begin 593 594 -- We replace the function call by the following expression 595 596 -- if Opnd < 0.0 then 597 -- True 598 -- else 599 -- if Opnd > 0.0 then 600 -- False; 601 -- else 602 -- Float_Unsigned!(Float (Opnd)) /= 0 603 -- end if; 604 -- end if; 605 606 Rewrite (N, 607 Make_If_Expression (Loc, 608 Expressions => New_List ( 609 Make_Op_Lt (Loc, 610 Left_Opnd => Duplicate_Subexpr (Opnd), 611 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 612 613 New_Occurrence_Of (Standard_True, Loc), 614 615 Make_If_Expression (Loc, 616 Expressions => New_List ( 617 Make_Op_Gt (Loc, 618 Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), 619 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 620 621 New_Occurrence_Of (Standard_False, Loc), 622 623 Make_Op_Ne (Loc, 624 Left_Opnd => 625 Unchecked_Convert_To 626 (RTE (RE_Float_Unsigned), 627 Convert_To 628 (Standard_Float, 629 Duplicate_Subexpr_No_Checks (Opnd))), 630 Right_Opnd => 631 Make_Integer_Literal (Loc, 0))))))); 632 633 Analyze_And_Resolve (N, Standard_Boolean); 634 end Expand_Is_Negative; 635 636 ------------------ 637 -- Expand_Shift -- 638 ------------------ 639 640 -- This procedure is used to convert a call to a shift function to the 641 -- corresponding operator node. This conversion is not done by the usual 642 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to 643 -- operator nodes, because shifts are not predefined operators. 644 645 -- As a result, whenever a shift is used in the source program, it will 646 -- remain as a call until converted by this routine to the operator node 647 -- form which the back end is expecting to see. 648 649 -- Note: it is possible for the expander to generate shift operator nodes 650 -- directly, which will be analyzed in the normal manner by calling Analyze 651 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. 652 653 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is 654 Entyp : constant Entity_Id := Etype (E); 655 Left : constant Node_Id := First_Actual (N); 656 Loc : constant Source_Ptr := Sloc (N); 657 Right : constant Node_Id := Next_Actual (Left); 658 Ltyp : constant Node_Id := Etype (Left); 659 Rtyp : constant Node_Id := Etype (Right); 660 Typ : constant Entity_Id := Etype (N); 661 Snode : Node_Id; 662 663 begin 664 Snode := New_Node (K, Loc); 665 Set_Right_Opnd (Snode, Relocate_Node (Right)); 666 Set_Chars (Snode, Chars (E)); 667 Set_Etype (Snode, Base_Type (Entyp)); 668 Set_Entity (Snode, E); 669 670 if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) 671 and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) 672 then 673 Set_Shift_Count_OK (Snode, True); 674 end if; 675 676 if Typ = Entyp then 677 678 -- Note that we don't call Analyze and Resolve on this node, because 679 -- it already got analyzed and resolved when it was a function call. 680 681 Set_Left_Opnd (Snode, Relocate_Node (Left)); 682 Rewrite (N, Snode); 683 Set_Analyzed (N); 684 685 -- However, we do call the expander, so that the expansion for 686 -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C 687 -- is set. 688 689 if Expander_Active then 690 Expand (N); 691 end if; 692 693 else 694 -- If the context type is not the type of the operator, it is an 695 -- inherited operator for a derived type. Wrap the node in a 696 -- conversion so that it is type-consistent for possible further 697 -- expansion (e.g. within a lock-free protected type). 698 699 Set_Left_Opnd (Snode, 700 Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left))); 701 Rewrite (N, Unchecked_Convert_To (Typ, Snode)); 702 703 -- Analyze and resolve result formed by conversion to target type 704 705 Analyze_And_Resolve (N, Typ); 706 end if; 707 end Expand_Shift; 708 709 ------------------------ 710 -- Expand_Source_Info -- 711 ------------------------ 712 713 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is 714 Loc : constant Source_Ptr := Sloc (N); 715 Ent : Entity_Id; 716 717 procedure Write_Entity_Name (E : Entity_Id); 718 -- Recursive procedure to construct string for qualified name of 719 -- enclosing program unit. The qualification stops at an enclosing 720 -- scope has no source name (block or loop). If entity is a subprogram 721 -- instance, skip enclosing wrapper package. 722 723 ----------------------- 724 -- Write_Entity_Name -- 725 ----------------------- 726 727 procedure Write_Entity_Name (E : Entity_Id) is 728 SDef : Source_Ptr; 729 TDef : constant Source_Buffer_Ptr := 730 Source_Text (Get_Source_File_Index (Sloc (E))); 731 732 begin 733 -- Nothing to do if at outer level 734 735 if Scope (E) = Standard_Standard then 736 null; 737 738 -- If scope comes from source, write its name 739 740 elsif Comes_From_Source (Scope (E)) then 741 Write_Entity_Name (Scope (E)); 742 Add_Char_To_Name_Buffer ('.'); 743 744 -- If in wrapper package skip past it 745 746 elsif Is_Wrapper_Package (Scope (E)) then 747 Write_Entity_Name (Scope (Scope (E))); 748 Add_Char_To_Name_Buffer ('.'); 749 750 -- Otherwise nothing to output (happens in unnamed block statements) 751 752 else 753 null; 754 end if; 755 756 -- Loop to output the name 757 758 -- This is not right wrt wide char encodings ??? () 759 760 SDef := Sloc (E); 761 while TDef (SDef) in '0' .. '9' 762 or else TDef (SDef) >= 'A' 763 or else TDef (SDef) = ASCII.ESC 764 loop 765 Add_Char_To_Name_Buffer (TDef (SDef)); 766 SDef := SDef + 1; 767 end loop; 768 end Write_Entity_Name; 769 770 -- Start of processing for Expand_Source_Info 771 772 begin 773 -- Integer cases 774 775 if Nam = Name_Line then 776 Rewrite (N, 777 Make_Integer_Literal (Loc, 778 Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); 779 Analyze_And_Resolve (N, Standard_Positive); 780 781 -- String cases 782 783 else 784 Name_Len := 0; 785 786 case Nam is 787 when Name_File => 788 Get_Decoded_Name_String 789 (Reference_Name (Get_Source_File_Index (Loc))); 790 791 when Name_Source_Location => 792 Build_Location_String (Loc); 793 794 when Name_Enclosing_Entity => 795 796 -- Skip enclosing blocks to reach enclosing unit 797 798 Ent := Current_Scope; 799 while Present (Ent) loop 800 exit when Ekind (Ent) /= E_Block 801 and then Ekind (Ent) /= E_Loop; 802 Ent := Scope (Ent); 803 end loop; 804 805 -- Ent now points to the relevant defining entity 806 807 Write_Entity_Name (Ent); 808 809 when others => 810 raise Program_Error; 811 end case; 812 813 Rewrite (N, 814 Make_String_Literal (Loc, 815 Strval => String_From_Name_Buffer)); 816 Analyze_And_Resolve (N, Standard_String); 817 end if; 818 819 Set_Is_Static_Expression (N); 820 end Expand_Source_Info; 821 822 --------------------------- 823 -- Expand_Unc_Conversion -- 824 --------------------------- 825 826 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is 827 Func : constant Entity_Id := Entity (Name (N)); 828 Conv : Node_Id; 829 Ftyp : Entity_Id; 830 Ttyp : Entity_Id; 831 832 begin 833 -- Rewrite as unchecked conversion node. Note that we must convert 834 -- the operand to the formal type of the input parameter of the 835 -- function, so that the resulting N_Unchecked_Type_Conversion 836 -- call indicates the correct types for Gigi. 837 838 -- Right now, we only do this if a scalar type is involved. It is 839 -- not clear if it is needed in other cases. If we do attempt to 840 -- do the conversion unconditionally, it crashes 3411-018. To be 841 -- investigated further ??? 842 843 Conv := Relocate_Node (First_Actual (N)); 844 Ftyp := Etype (First_Formal (Func)); 845 846 if Is_Scalar_Type (Ftyp) then 847 Conv := Convert_To (Ftyp, Conv); 848 Set_Parent (Conv, N); 849 Analyze_And_Resolve (Conv); 850 end if; 851 852 -- The instantiation of Unchecked_Conversion creates a wrapper package, 853 -- and the target type is declared as a subtype of the actual. Recover 854 -- the actual, which is the subtype indic. in the subtype declaration 855 -- for the target type. This is semantically correct, and avoids 856 -- anomalies with access subtypes. For entities, leave type as is. 857 858 -- We do the analysis here, because we do not want the compiler 859 -- to try to optimize or otherwise reorganize the unchecked 860 -- conversion node. 861 862 Ttyp := Etype (E); 863 864 if Is_Entity_Name (Conv) then 865 null; 866 867 elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then 868 Ttyp := Entity (Subtype_Indication (Parent (Etype (E)))); 869 870 elsif Is_Itype (Ttyp) then 871 Ttyp := 872 Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp))); 873 else 874 raise Program_Error; 875 end if; 876 877 Rewrite (N, Unchecked_Convert_To (Ttyp, Conv)); 878 Set_Etype (N, Ttyp); 879 Set_Analyzed (N); 880 881 if Nkind (N) = N_Unchecked_Type_Conversion then 882 Expand_N_Unchecked_Type_Conversion (N); 883 end if; 884 end Expand_Unc_Conversion; 885 886 ----------------------------- 887 -- Expand_Unc_Deallocation -- 888 ----------------------------- 889 890 -- Generate the following Code : 891 892 -- if Arg /= null then 893 -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types 894 -- Free (Arg); 895 -- Arg := Null; 896 -- end if; 897 898 -- For a task, we also generate a call to Free_Task to ensure that the 899 -- task itself is freed if it is terminated, ditto for a simple protected 900 -- object, with a call to Finalize_Protection. For composite types that 901 -- have tasks or simple protected objects as components, we traverse the 902 -- structures to find and terminate those components. 903 904 procedure Expand_Unc_Deallocation (N : Node_Id) is 905 Arg : constant Node_Id := First_Actual (N); 906 Loc : constant Source_Ptr := Sloc (N); 907 Typ : constant Entity_Id := Etype (Arg); 908 Desig_T : constant Entity_Id := Designated_Type (Typ); 909 Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); 910 Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); 911 Stmts : constant List_Id := New_List; 912 Needs_Fin : constant Boolean := Needs_Finalization (Desig_T); 913 914 Finalizer_Data : Finalization_Exception_Data; 915 916 Blk : Node_Id := Empty; 917 Deref : Node_Id; 918 Final_Code : List_Id; 919 Free_Arg : Node_Id; 920 Free_Node : Node_Id; 921 Gen_Code : Node_Id; 922 923 Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); 924 -- This captures whether we know the argument to be non-null so that 925 -- we can avoid the test. The reason that we need to capture this is 926 -- that we analyze some generated statements before properly attaching 927 -- them to the tree, and that can disturb current value settings. 928 929 begin 930 -- Nothing to do if we know the argument is null 931 932 if Known_Null (N) then 933 return; 934 end if; 935 936 -- Processing for pointer to controlled type 937 938 if Needs_Fin then 939 Deref := 940 Make_Explicit_Dereference (Loc, 941 Prefix => Duplicate_Subexpr_No_Checks (Arg)); 942 943 -- If the type is tagged, then we must force dispatching on the 944 -- finalization call because the designated type may not be the 945 -- actual type of the object. 946 947 if Is_Tagged_Type (Desig_T) 948 and then not Is_Class_Wide_Type (Desig_T) 949 then 950 Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); 951 952 elsif not Is_Tagged_Type (Desig_T) then 953 954 -- Set type of result, to force a conversion when needed (see 955 -- exp_ch7, Convert_View), given that Deep_Finalize may be 956 -- inherited from the parent type, and we need the type of the 957 -- expression to see whether the conversion is in fact needed. 958 959 Set_Etype (Deref, Desig_T); 960 end if; 961 962 -- The finalization call is expanded wrapped in a block to catch any 963 -- possible exception. If an exception does occur, then Program_Error 964 -- must be raised following the freeing of the object and its removal 965 -- from the finalization collection's list. We set a flag to record 966 -- that an exception was raised, and save its occurrence for use in 967 -- the later raise. 968 -- 969 -- Generate: 970 -- Abort : constant Boolean := 971 -- Exception_Occurrence (Get_Current_Excep.all.all) = 972 -- Standard'Abort_Signal'Identity; 973 -- <or> 974 -- Abort : constant Boolean := False; -- no abort 975 976 -- E : Exception_Occurrence; 977 -- Raised : Boolean := False; 978 -- 979 -- begin 980 -- [Deep_]Finalize (Obj); 981 -- exception 982 -- when others => 983 -- Raised := True; 984 -- Save_Occurrence (E, Get_Current_Excep.all.all); 985 -- end; 986 987 Build_Object_Declarations (Finalizer_Data, Stmts, Loc); 988 989 Final_Code := New_List ( 990 Make_Block_Statement (Loc, 991 Handled_Statement_Sequence => 992 Make_Handled_Sequence_Of_Statements (Loc, 993 Statements => New_List ( 994 Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)), 995 Exception_Handlers => New_List ( 996 Build_Exception_Handler (Finalizer_Data))))); 997 998 -- For .NET/JVM, detach the object from the containing finalization 999 -- collection before finalizing it. 1000 1001 if VM_Target /= No_VM and then Is_Controlled (Desig_T) then 1002 Prepend_To (Final_Code, 1003 Make_Detach_Call (New_Copy_Tree (Arg))); 1004 end if; 1005 1006 -- If aborts are allowed, then the finalization code must be 1007 -- protected by an abort defer/undefer pair. 1008 1009 if Abort_Allowed then 1010 Prepend_To (Final_Code, 1011 Build_Runtime_Call (Loc, RE_Abort_Defer)); 1012 1013 Blk := 1014 Make_Block_Statement (Loc, Handled_Statement_Sequence => 1015 Make_Handled_Sequence_Of_Statements (Loc, 1016 Statements => Final_Code, 1017 At_End_Proc => 1018 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); 1019 1020 Append (Blk, Stmts); 1021 else 1022 Append_List_To (Stmts, Final_Code); 1023 end if; 1024 end if; 1025 1026 -- For a task type, call Free_Task before freeing the ATCB 1027 1028 if Is_Task_Type (Desig_T) then 1029 1030 -- We used to detect the case of Abort followed by a Free here, 1031 -- because the Free wouldn't actually free if it happens before 1032 -- the aborted task actually terminates. The warning was removed, 1033 -- because Free now works properly (the task will be freed once 1034 -- it terminates). 1035 1036 Append_To 1037 (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); 1038 1039 -- For composite types that contain tasks, recurse over the structure 1040 -- to build the selectors for the task subcomponents. 1041 1042 elsif Has_Task (Desig_T) then 1043 if Is_Record_Type (Desig_T) then 1044 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); 1045 1046 elsif Is_Array_Type (Desig_T) then 1047 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); 1048 end if; 1049 end if; 1050 1051 -- Same for simple protected types. Eventually call Finalize_Protection 1052 -- before freeing the PO for each protected component. 1053 1054 if Is_Simple_Protected_Type (Desig_T) then 1055 Append_To (Stmts, 1056 Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); 1057 1058 elsif Has_Simple_Protected_Object (Desig_T) then 1059 if Is_Record_Type (Desig_T) then 1060 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); 1061 elsif Is_Array_Type (Desig_T) then 1062 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); 1063 end if; 1064 end if; 1065 1066 -- Normal processing for non-controlled types 1067 1068 Free_Arg := Duplicate_Subexpr_No_Checks (Arg); 1069 Free_Node := Make_Free_Statement (Loc, Empty); 1070 Append_To (Stmts, Free_Node); 1071 Set_Storage_Pool (Free_Node, Pool); 1072 1073 -- Attach to tree before analysis of generated subtypes below 1074 1075 Set_Parent (Stmts, Parent (N)); 1076 1077 -- Deal with storage pool 1078 1079 if Present (Pool) then 1080 1081 -- Freeing the secondary stack is meaningless 1082 1083 if Is_RTE (Pool, RE_SS_Pool) then 1084 null; 1085 1086 -- If the pool object is of a simple storage pool type, then attempt 1087 -- to locate the type's Deallocate procedure, if any, and set the 1088 -- free operation's procedure to call. If the type doesn't have a 1089 -- Deallocate (which is allowed), then the actual will simply be set 1090 -- to null. 1091 1092 elsif Present (Get_Rep_Pragma 1093 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 1094 then 1095 declare 1096 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); 1097 Dealloc_Op : Entity_Id; 1098 begin 1099 Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate); 1100 while Present (Dealloc_Op) loop 1101 if Scope (Dealloc_Op) = Scope (Pool_Type) 1102 and then Present (First_Formal (Dealloc_Op)) 1103 and then Etype (First_Formal (Dealloc_Op)) = Pool_Type 1104 then 1105 Set_Procedure_To_Call (Free_Node, Dealloc_Op); 1106 exit; 1107 else 1108 Dealloc_Op := Homonym (Dealloc_Op); 1109 end if; 1110 end loop; 1111 end; 1112 1113 -- Case of a class-wide pool type: make a dispatching call to 1114 -- Deallocate through the class-wide Deallocate_Any. 1115 1116 elsif Is_Class_Wide_Type (Etype (Pool)) then 1117 Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any)); 1118 1119 -- Case of a specific pool type: make a statically bound call 1120 1121 else 1122 Set_Procedure_To_Call (Free_Node, 1123 Find_Prim_Op (Etype (Pool), Name_Deallocate)); 1124 end if; 1125 end if; 1126 1127 if Present (Procedure_To_Call (Free_Node)) then 1128 1129 -- For all cases of a Deallocate call, the back-end needs to be able 1130 -- to compute the size of the object being freed. This may require 1131 -- some adjustments for objects of dynamic size. 1132 -- 1133 -- If the type is class wide, we generate an implicit type with the 1134 -- right dynamic size, so that the deallocate call gets the right 1135 -- size parameter computed by GIGI. Same for an access to 1136 -- unconstrained packed array. 1137 1138 if Is_Class_Wide_Type (Desig_T) 1139 or else 1140 (Is_Array_Type (Desig_T) 1141 and then not Is_Constrained (Desig_T) 1142 and then Is_Packed (Desig_T)) 1143 then 1144 declare 1145 Deref : constant Node_Id := 1146 Make_Explicit_Dereference (Loc, 1147 Duplicate_Subexpr_No_Checks (Arg)); 1148 D_Subtyp : Node_Id; 1149 D_Type : Entity_Id; 1150 1151 begin 1152 -- Perform minor decoration as it is needed by the side effect 1153 -- removal mechanism. 1154 1155 Set_Etype (Deref, Desig_T); 1156 Set_Parent (Deref, Free_Node); 1157 D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); 1158 1159 if Nkind (D_Subtyp) in N_Has_Entity then 1160 D_Type := Entity (D_Subtyp); 1161 1162 else 1163 D_Type := Make_Temporary (Loc, 'A'); 1164 Insert_Action (Deref, 1165 Make_Subtype_Declaration (Loc, 1166 Defining_Identifier => D_Type, 1167 Subtype_Indication => D_Subtyp)); 1168 end if; 1169 1170 -- Force freezing at the point of the dereference. For the 1171 -- class wide case, this avoids having the subtype frozen 1172 -- before the equivalent type. 1173 1174 Freeze_Itype (D_Type, Deref); 1175 1176 Set_Actual_Designated_Subtype (Free_Node, D_Type); 1177 end; 1178 1179 end if; 1180 end if; 1181 1182 -- Ada 2005 (AI-251): In case of abstract interface type we must 1183 -- displace the pointer to reference the base of the object to 1184 -- deallocate its memory, unless we're targetting a VM, in which case 1185 -- no special processing is required. 1186 1187 -- Generate: 1188 -- free (Base_Address (Obj_Ptr)) 1189 1190 if Is_Interface (Directly_Designated_Type (Typ)) 1191 and then Tagged_Type_Expansion 1192 then 1193 Set_Expression (Free_Node, 1194 Unchecked_Convert_To (Typ, 1195 Make_Function_Call (Loc, 1196 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc), 1197 Parameter_Associations => New_List ( 1198 Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); 1199 1200 -- Generate: 1201 -- free (Obj_Ptr) 1202 1203 else 1204 Set_Expression (Free_Node, Free_Arg); 1205 end if; 1206 1207 -- Only remaining step is to set result to null, or generate a raise of 1208 -- Constraint_Error if the target object is "not null". 1209 1210 if Can_Never_Be_Null (Etype (Arg)) then 1211 Append_To (Stmts, 1212 Make_Raise_Constraint_Error (Loc, 1213 Reason => CE_Access_Check_Failed)); 1214 1215 else 1216 declare 1217 Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); 1218 begin 1219 Set_Assignment_OK (Lhs); 1220 Append_To (Stmts, 1221 Make_Assignment_Statement (Loc, 1222 Name => Lhs, 1223 Expression => Make_Null (Loc))); 1224 end; 1225 end if; 1226 1227 -- Generate a test of whether any earlier finalization raised an 1228 -- exception, and in that case raise Program_Error with the previous 1229 -- exception occurrence. 1230 1231 -- Generate: 1232 -- if Raised and then not Abort then 1233 -- raise Program_Error; -- for .NET and 1234 -- -- restricted RTS 1235 -- <or> 1236 -- Raise_From_Controlled_Operation (E); -- all other cases 1237 -- end if; 1238 1239 if Needs_Fin then 1240 Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); 1241 end if; 1242 1243 -- If we know the argument is non-null, then make a block statement 1244 -- that contains the required statements, no need for a test. 1245 1246 if Arg_Known_Non_Null then 1247 Gen_Code := 1248 Make_Block_Statement (Loc, 1249 Handled_Statement_Sequence => 1250 Make_Handled_Sequence_Of_Statements (Loc, 1251 Statements => Stmts)); 1252 1253 -- If the argument may be null, wrap the statements inside an IF that 1254 -- does an explicit test to exclude the null case. 1255 1256 else 1257 Gen_Code := 1258 Make_Implicit_If_Statement (N, 1259 Condition => 1260 Make_Op_Ne (Loc, 1261 Left_Opnd => Duplicate_Subexpr (Arg), 1262 Right_Opnd => Make_Null (Loc)), 1263 Then_Statements => Stmts); 1264 end if; 1265 1266 -- Rewrite the call 1267 1268 Rewrite (N, Gen_Code); 1269 Analyze (N); 1270 1271 -- If we generated a block with an At_End_Proc, expand the exception 1272 -- handler. We need to wait until after everything else is analyzed. 1273 1274 if Present (Blk) then 1275 Expand_At_End_Handler 1276 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); 1277 end if; 1278 end Expand_Unc_Deallocation; 1279 1280 ----------------------- 1281 -- Expand_To_Address -- 1282 ----------------------- 1283 1284 procedure Expand_To_Address (N : Node_Id) is 1285 Loc : constant Source_Ptr := Sloc (N); 1286 Arg : constant Node_Id := First_Actual (N); 1287 Obj : Node_Id; 1288 1289 begin 1290 Remove_Side_Effects (Arg); 1291 1292 Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); 1293 1294 Rewrite (N, 1295 Make_If_Expression (Loc, 1296 Expressions => New_List ( 1297 Make_Op_Eq (Loc, 1298 Left_Opnd => New_Copy_Tree (Arg), 1299 Right_Opnd => Make_Null (Loc)), 1300 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 1301 Make_Attribute_Reference (Loc, 1302 Prefix => Obj, 1303 Attribute_Name => Name_Address)))); 1304 1305 Analyze_And_Resolve (N, RTE (RE_Address)); 1306 end Expand_To_Address; 1307 1308 ----------------------- 1309 -- Expand_To_Pointer -- 1310 ----------------------- 1311 1312 procedure Expand_To_Pointer (N : Node_Id) is 1313 Arg : constant Node_Id := First_Actual (N); 1314 1315 begin 1316 Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); 1317 Analyze (N); 1318 end Expand_To_Pointer; 1319 1320end Exp_Intr; 1321