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