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