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-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with 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. When the result 406 -- type is a class-wide interface type this conversion is required to 407 -- force the displacement of the pointer to the object to reference the 408 -- corresponding dispatch table. 409 410 Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); 411 412 -- Do not generate a run-time check on the built object if tag 413 -- checks are suppressed for the result type or tagged type expansion 414 -- is disabled or if CodePeer_Mode. 415 416 if Tag_Checks_Suppressed (Etype (Result_Typ)) 417 or else not Tagged_Type_Expansion 418 or else CodePeer_Mode 419 then 420 null; 421 422 -- Generate a class-wide membership test to ensure that the call's tag 423 -- argument denotes a type within the class. We must keep separate the 424 -- case in which the Result_Type of the constructor function is a tagged 425 -- type from the case in which it is an abstract interface because the 426 -- run-time subprogram required to check these cases differ (and have 427 -- one difference in their parameters profile). 428 429 -- Call CW_Membership if the Result_Type is a tagged type to look for 430 -- the tag in the table of ancestor tags. 431 432 elsif not Is_Interface (Result_Typ) then 433 declare 434 Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg); 435 CW_Test_Node : Node_Id; 436 437 begin 438 Build_CW_Membership (Loc, 439 Obj_Tag_Node => Obj_Tag_Node, 440 Typ_Tag_Node => 441 New_Occurrence_Of ( 442 Node (First_Elmt (Access_Disp_Table ( 443 Root_Type (Result_Typ)))), Loc), 444 Related_Nod => N, 445 New_Node => CW_Test_Node); 446 447 Insert_Action (N, 448 Make_Implicit_If_Statement (N, 449 Condition => 450 Make_Op_Not (Loc, CW_Test_Node), 451 Then_Statements => 452 New_List (Make_Raise_Statement (Loc, 453 New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); 454 end; 455 456 -- Call IW_Membership test if the Result_Type is an abstract interface 457 -- to look for the tag in the table of interface tags. 458 459 else 460 Insert_Action (N, 461 Make_Implicit_If_Statement (N, 462 Condition => 463 Make_Op_Not (Loc, 464 Make_Function_Call (Loc, 465 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), 466 Parameter_Associations => New_List ( 467 Make_Attribute_Reference (Loc, 468 Prefix => New_Copy_Tree (Tag_Arg), 469 Attribute_Name => Name_Address), 470 471 New_Occurrence_Of ( 472 Node (First_Elmt (Access_Disp_Table ( 473 Root_Type (Result_Typ)))), Loc)))), 474 Then_Statements => 475 New_List ( 476 Make_Raise_Statement (Loc, 477 Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); 478 end if; 479 480 Analyze_And_Resolve (N, Etype (Act_Constr)); 481 end Expand_Dispatching_Constructor_Call; 482 483 --------------------------- 484 -- Expand_Exception_Call -- 485 --------------------------- 486 487 -- If the function call is not within an exception handler, then the call 488 -- is replaced by a null string. Otherwise the appropriate routine in 489 -- Ada.Exceptions is called passing the choice parameter specification 490 -- from the enclosing handler. If the enclosing handler lacks a choice 491 -- parameter, then one is supplied. 492 493 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is 494 Loc : constant Source_Ptr := Sloc (N); 495 P : Node_Id; 496 E : Entity_Id; 497 498 begin 499 -- Climb up parents to see if we are in exception handler 500 501 P := Parent (N); 502 loop 503 -- Case of not in exception handler, replace by null string 504 505 if No (P) then 506 Rewrite (N, 507 Make_String_Literal (Loc, 508 Strval => "")); 509 exit; 510 511 -- Case of in exception handler 512 513 elsif Nkind (P) = N_Exception_Handler then 514 515 -- Handler cannot be used for a local raise, and furthermore, this 516 -- is a violation of the No_Exception_Propagation restriction. 517 518 Set_Local_Raise_Not_OK (P); 519 Check_Restriction (No_Exception_Propagation, N); 520 521 -- If no choice parameter present, then put one there. Note that 522 -- we do not need to put it on the entity chain, since no one will 523 -- be referencing it by normal visibility methods. 524 525 if No (Choice_Parameter (P)) then 526 E := Make_Temporary (Loc, 'E'); 527 Set_Choice_Parameter (P, E); 528 Set_Ekind (E, E_Variable); 529 Set_Etype (E, RTE (RE_Exception_Occurrence)); 530 Set_Scope (E, Current_Scope); 531 end if; 532 533 Rewrite (N, 534 Make_Function_Call (Loc, 535 Name => New_Occurrence_Of (RTE (Ent), Loc), 536 Parameter_Associations => New_List ( 537 New_Occurrence_Of (Choice_Parameter (P), Loc)))); 538 exit; 539 540 -- Keep climbing 541 542 else 543 P := Parent (P); 544 end if; 545 end loop; 546 547 Analyze_And_Resolve (N, Standard_String); 548 end Expand_Exception_Call; 549 550 ------------------------ 551 -- Expand_Import_Call -- 552 ------------------------ 553 554 -- The function call must have a static string as its argument. We create 555 -- a dummy variable which uses this string as the external name in an 556 -- Import pragma. The result is then obtained as the address of this 557 -- dummy variable, converted to the appropriate target type. 558 559 procedure Expand_Import_Call (N : Node_Id) is 560 Loc : constant Source_Ptr := Sloc (N); 561 Ent : constant Entity_Id := Entity (Name (N)); 562 Str : constant Node_Id := First_Actual (N); 563 Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); 564 565 begin 566 Insert_Actions (N, New_List ( 567 Make_Object_Declaration (Loc, 568 Defining_Identifier => Dum, 569 Object_Definition => 570 New_Occurrence_Of (Standard_Character, Loc)), 571 572 Make_Pragma (Loc, 573 Chars => Name_Import, 574 Pragma_Argument_Associations => New_List ( 575 Make_Pragma_Argument_Association (Loc, 576 Expression => Make_Identifier (Loc, Name_Ada)), 577 578 Make_Pragma_Argument_Association (Loc, 579 Expression => Make_Identifier (Loc, Chars (Dum))), 580 581 Make_Pragma_Argument_Association (Loc, 582 Chars => Name_Link_Name, 583 Expression => Relocate_Node (Str)))))); 584 585 Rewrite (N, 586 Unchecked_Convert_To (Etype (Ent), 587 Make_Attribute_Reference (Loc, 588 Prefix => Make_Identifier (Loc, Chars (Dum)), 589 Attribute_Name => Name_Address))); 590 591 Analyze_And_Resolve (N, Etype (Ent)); 592 end Expand_Import_Call; 593 594 --------------------------- 595 -- Expand_Intrinsic_Call -- 596 --------------------------- 597 598 procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is 599 Nam : Name_Id; 600 601 begin 602 -- If an external name is specified for the intrinsic, it is handled 603 -- by the back-end: leave the call node unchanged for now. 604 605 if Present (Interface_Name (E)) then 606 return; 607 end if; 608 609 -- If the intrinsic subprogram is generic, gets its original name 610 611 if Present (Parent (E)) 612 and then Present (Generic_Parent (Parent (E))) 613 then 614 Nam := Chars (Generic_Parent (Parent (E))); 615 else 616 Nam := Chars (E); 617 end if; 618 619 if Nam = Name_Asm then 620 Expand_Asm_Call (N); 621 622 elsif Nam = Name_Divide then 623 Expand_Decimal_Divide_Call (N); 624 625 elsif Nam = Name_Exception_Information then 626 Expand_Exception_Call (N, RE_Exception_Information); 627 628 elsif Nam = Name_Exception_Message then 629 Expand_Exception_Call (N, RE_Exception_Message); 630 631 elsif Nam = Name_Exception_Name then 632 Expand_Exception_Call (N, RE_Exception_Name_Simple); 633 634 elsif Nam = Name_Generic_Dispatching_Constructor then 635 Expand_Dispatching_Constructor_Call (N); 636 637 elsif Nam_In (Nam, Name_Import_Address, 638 Name_Import_Largest_Value, 639 Name_Import_Value) 640 then 641 Expand_Import_Call (N); 642 643 elsif Nam = Name_Is_Negative then 644 Expand_Is_Negative (N); 645 646 elsif Nam = Name_Rotate_Left then 647 Expand_Shift (N, E, N_Op_Rotate_Left); 648 649 elsif Nam = Name_Rotate_Right then 650 Expand_Shift (N, E, N_Op_Rotate_Right); 651 652 elsif Nam = Name_Shift_Left then 653 Expand_Shift (N, E, N_Op_Shift_Left); 654 655 elsif Nam = Name_Shift_Right then 656 Expand_Shift (N, E, N_Op_Shift_Right); 657 658 elsif Nam = Name_Shift_Right_Arithmetic then 659 Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); 660 661 elsif Nam = Name_Unchecked_Conversion then 662 Expand_Unc_Conversion (N, E); 663 664 elsif Nam = Name_Unchecked_Deallocation then 665 Expand_Unc_Deallocation (N); 666 667 elsif Nam = Name_To_Address then 668 Expand_To_Address (N); 669 670 elsif Nam = Name_To_Pointer then 671 Expand_To_Pointer (N); 672 673 elsif Nam_In (Nam, Name_File, 674 Name_Line, 675 Name_Source_Location, 676 Name_Enclosing_Entity, 677 Name_Compilation_ISO_Date, 678 Name_Compilation_Date, 679 Name_Compilation_Time) 680 then 681 Expand_Source_Info (N, Nam); 682 683 -- If we have a renaming, expand the call to the original operation, 684 -- which must itself be intrinsic, since renaming requires matching 685 -- conventions and this has already been checked. 686 687 elsif Present (Alias (E)) then 688 Expand_Intrinsic_Call (N, Alias (E)); 689 690 elsif Nkind (N) in N_Binary_Op then 691 Expand_Binary_Operator_Call (N); 692 693 -- The only other case is where an external name was specified, since 694 -- this is the only way that an otherwise unrecognized name could 695 -- escape the checking in Sem_Prag. Nothing needs to be done in such 696 -- a case, since we pass such a call to the back end unchanged. 697 698 else 699 null; 700 end if; 701 end Expand_Intrinsic_Call; 702 703 ------------------------ 704 -- Expand_Is_Negative -- 705 ------------------------ 706 707 procedure Expand_Is_Negative (N : Node_Id) is 708 Loc : constant Source_Ptr := Sloc (N); 709 Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); 710 711 begin 712 713 -- We replace the function call by the following expression 714 715 -- if Opnd < 0.0 then 716 -- True 717 -- else 718 -- if Opnd > 0.0 then 719 -- False; 720 -- else 721 -- Float_Unsigned!(Float (Opnd)) /= 0 722 -- end if; 723 -- end if; 724 725 Rewrite (N, 726 Make_If_Expression (Loc, 727 Expressions => New_List ( 728 Make_Op_Lt (Loc, 729 Left_Opnd => Duplicate_Subexpr (Opnd), 730 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 731 732 New_Occurrence_Of (Standard_True, Loc), 733 734 Make_If_Expression (Loc, 735 Expressions => New_List ( 736 Make_Op_Gt (Loc, 737 Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), 738 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 739 740 New_Occurrence_Of (Standard_False, Loc), 741 742 Make_Op_Ne (Loc, 743 Left_Opnd => 744 Unchecked_Convert_To 745 (RTE (RE_Float_Unsigned), 746 Convert_To 747 (Standard_Float, 748 Duplicate_Subexpr_No_Checks (Opnd))), 749 Right_Opnd => 750 Make_Integer_Literal (Loc, 0))))))); 751 752 Analyze_And_Resolve (N, Standard_Boolean); 753 end Expand_Is_Negative; 754 755 ------------------ 756 -- Expand_Shift -- 757 ------------------ 758 759 -- This procedure is used to convert a call to a shift function to the 760 -- corresponding operator node. This conversion is not done by the usual 761 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to 762 -- operator nodes, because shifts are not predefined operators. 763 764 -- As a result, whenever a shift is used in the source program, it will 765 -- remain as a call until converted by this routine to the operator node 766 -- form which the back end is expecting to see. 767 768 -- Note: it is possible for the expander to generate shift operator nodes 769 -- directly, which will be analyzed in the normal manner by calling Analyze 770 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. 771 772 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is 773 Entyp : constant Entity_Id := Etype (E); 774 Left : constant Node_Id := First_Actual (N); 775 Loc : constant Source_Ptr := Sloc (N); 776 Right : constant Node_Id := Next_Actual (Left); 777 Ltyp : constant Node_Id := Etype (Left); 778 Rtyp : constant Node_Id := Etype (Right); 779 Typ : constant Entity_Id := Etype (N); 780 Snode : Node_Id; 781 782 begin 783 Snode := New_Node (K, Loc); 784 Set_Right_Opnd (Snode, Relocate_Node (Right)); 785 Set_Chars (Snode, Chars (E)); 786 Set_Etype (Snode, Base_Type (Entyp)); 787 Set_Entity (Snode, E); 788 789 if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) 790 and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) 791 then 792 Set_Shift_Count_OK (Snode, True); 793 end if; 794 795 if Typ = Entyp then 796 797 -- Note that we don't call Analyze and Resolve on this node, because 798 -- it already got analyzed and resolved when it was a function call. 799 800 Set_Left_Opnd (Snode, Relocate_Node (Left)); 801 Rewrite (N, Snode); 802 Set_Analyzed (N); 803 804 -- However, we do call the expander, so that the expansion for 805 -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C 806 -- is set. 807 808 if Expander_Active then 809 Expand (N); 810 end if; 811 812 else 813 -- If the context type is not the type of the operator, it is an 814 -- inherited operator for a derived type. Wrap the node in a 815 -- conversion so that it is type-consistent for possible further 816 -- expansion (e.g. within a lock-free protected type). 817 818 Set_Left_Opnd (Snode, 819 Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left))); 820 Rewrite (N, Unchecked_Convert_To (Typ, Snode)); 821 822 -- Analyze and resolve result formed by conversion to target type 823 824 Analyze_And_Resolve (N, Typ); 825 end if; 826 end Expand_Shift; 827 828 ------------------------ 829 -- Expand_Source_Info -- 830 ------------------------ 831 832 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is 833 Loc : constant Source_Ptr := Sloc (N); 834 begin 835 -- Integer cases 836 837 if Nam = Name_Line then 838 Rewrite (N, 839 Make_Integer_Literal (Loc, 840 Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); 841 Analyze_And_Resolve (N, Standard_Positive); 842 843 -- String cases 844 845 else 846 declare 847 Buf : Bounded_String; 848 begin 849 Add_Source_Info (Buf, Loc, Nam); 850 Rewrite (N, Make_String_Literal (Loc, Strval => +Buf)); 851 Analyze_And_Resolve (N, Standard_String); 852 end; 853 end if; 854 855 Set_Is_Static_Expression (N); 856 end Expand_Source_Info; 857 858 --------------------------- 859 -- Expand_Unc_Conversion -- 860 --------------------------- 861 862 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is 863 Func : constant Entity_Id := Entity (Name (N)); 864 Conv : Node_Id; 865 Ftyp : Entity_Id; 866 Ttyp : Entity_Id; 867 868 begin 869 -- Rewrite as unchecked conversion node. Note that we must convert 870 -- the operand to the formal type of the input parameter of the 871 -- function, so that the resulting N_Unchecked_Type_Conversion 872 -- call indicates the correct types for Gigi. 873 874 -- Right now, we only do this if a scalar type is involved. It is 875 -- not clear if it is needed in other cases. If we do attempt to 876 -- do the conversion unconditionally, it crashes 3411-018. To be 877 -- investigated further ??? 878 879 Conv := Relocate_Node (First_Actual (N)); 880 Ftyp := Etype (First_Formal (Func)); 881 882 if Is_Scalar_Type (Ftyp) then 883 Conv := Convert_To (Ftyp, Conv); 884 Set_Parent (Conv, N); 885 Analyze_And_Resolve (Conv); 886 end if; 887 888 -- The instantiation of Unchecked_Conversion creates a wrapper package, 889 -- and the target type is declared as a subtype of the actual. Recover 890 -- the actual, which is the subtype indic. in the subtype declaration 891 -- for the target type. This is semantically correct, and avoids 892 -- anomalies with access subtypes. For entities, leave type as is. 893 894 -- We do the analysis here, because we do not want the compiler 895 -- to try to optimize or otherwise reorganize the unchecked 896 -- conversion node. 897 898 Ttyp := Etype (E); 899 900 if Is_Entity_Name (Conv) then 901 null; 902 903 elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then 904 Ttyp := Entity (Subtype_Indication (Parent (Etype (E)))); 905 906 elsif Is_Itype (Ttyp) then 907 Ttyp := 908 Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp))); 909 else 910 raise Program_Error; 911 end if; 912 913 Rewrite (N, Unchecked_Convert_To (Ttyp, Conv)); 914 Set_Etype (N, Ttyp); 915 Set_Analyzed (N); 916 917 if Nkind (N) = N_Unchecked_Type_Conversion then 918 Expand_N_Unchecked_Type_Conversion (N); 919 end if; 920 end Expand_Unc_Conversion; 921 922 ----------------------------- 923 -- Expand_Unc_Deallocation -- 924 ----------------------------- 925 926 procedure Expand_Unc_Deallocation (N : Node_Id) is 927 Arg : constant Node_Id := First_Actual (N); 928 Loc : constant Source_Ptr := Sloc (N); 929 Typ : constant Entity_Id := Etype (Arg); 930 Desig_Typ : constant Entity_Id := 931 Available_View (Designated_Type (Typ)); 932 Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ); 933 Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ)); 934 Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ); 935 Stmts : constant List_Id := New_List; 936 937 Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); 938 -- This captures whether we know the argument to be non-null so that 939 -- we can avoid the test. The reason that we need to capture this is 940 -- that we analyze some generated statements before properly attaching 941 -- them to the tree, and that can disturb current value settings. 942 943 Exceptions_OK : constant Boolean := 944 not Restriction_Active (No_Exception_Propagation); 945 946 Abrt_Blk : Node_Id := Empty; 947 Abrt_Blk_Id : Entity_Id; 948 Abrt_HSS : Node_Id; 949 AUD : Entity_Id; 950 Fin_Blk : Node_Id; 951 Fin_Call : Node_Id; 952 Fin_Data : Finalization_Exception_Data; 953 Free_Arg : Node_Id; 954 Free_Nod : Node_Id; 955 Gen_Code : Node_Id; 956 Obj_Ref : Node_Id; 957 958 begin 959 -- Nothing to do if we know the argument is null 960 961 if Known_Null (N) then 962 return; 963 end if; 964 965 -- Processing for pointer to controlled types. Generate: 966 967 -- Abrt : constant Boolean := ...; 968 -- Ex : Exception_Occurrence; 969 -- Raised : Boolean := False; 970 971 -- begin 972 -- Abort_Defer; 973 974 -- begin 975 -- [Deep_]Finalize (Obj_Ref); 976 977 -- exception 978 -- when others => 979 -- if not Raised then 980 -- Raised := True; 981 -- Save_Occurrence (Ex, Get_Current_Excep.all.all); 982 -- end; 983 -- at end 984 -- Abort_Undefer_Direct; 985 -- end; 986 987 -- Depending on whether exception propagation is enabled and/or aborts 988 -- are allowed, the generated code may lack block statements. 989 990 if Needs_Fin then 991 Obj_Ref := 992 Make_Explicit_Dereference (Loc, 993 Prefix => Duplicate_Subexpr_No_Checks (Arg)); 994 995 -- If the designated type is tagged, the finalization call must 996 -- dispatch because the designated type may not be the actual type 997 -- of the object. If the type is synchronized, the deallocation 998 -- applies to the corresponding record type. 999 1000 if Is_Tagged_Type (Desig_Typ) then 1001 if Is_Concurrent_Type (Desig_Typ) then 1002 Obj_Ref := 1003 Unchecked_Convert_To 1004 (Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)), 1005 Obj_Ref); 1006 1007 elsif not Is_Class_Wide_Type (Desig_Typ) then 1008 Obj_Ref := 1009 Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref); 1010 end if; 1011 1012 -- Otherwise the designated type is untagged. Set the type of the 1013 -- dereference explicitly to force a conversion when needed given 1014 -- that [Deep_]Finalize may be inherited from a parent type. 1015 1016 else 1017 Set_Etype (Obj_Ref, Desig_Typ); 1018 end if; 1019 1020 -- Generate: 1021 -- [Deep_]Finalize (Obj_Ref); 1022 1023 Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); 1024 1025 -- Generate: 1026 -- Abrt : constant Boolean := ...; 1027 -- Ex : Exception_Occurrence; 1028 -- Raised : Boolean := False; 1029 1030 -- begin 1031 -- <Fin_Call> 1032 1033 -- exception 1034 -- when others => 1035 -- if not Raised then 1036 -- Raised := True; 1037 -- Save_Occurrence (Ex, Get_Current_Excep.all.all); 1038 -- end; 1039 1040 if Exceptions_OK then 1041 Build_Object_Declarations (Fin_Data, Stmts, Loc); 1042 1043 Fin_Blk := 1044 Make_Block_Statement (Loc, 1045 Handled_Statement_Sequence => 1046 Make_Handled_Sequence_Of_Statements (Loc, 1047 Statements => New_List (Fin_Call), 1048 Exception_Handlers => New_List ( 1049 Build_Exception_Handler (Fin_Data)))); 1050 1051 -- Otherwise exception propagation is not allowed 1052 1053 else 1054 Fin_Blk := Fin_Call; 1055 end if; 1056 1057 -- The finalization action must be protected by an abort defer and 1058 -- undefer pair when aborts are allowed. Generate: 1059 1060 -- begin 1061 -- Abort_Defer; 1062 -- <Fin_Blk> 1063 -- at end 1064 -- Abort_Undefer_Direct; 1065 -- end; 1066 1067 if Abort_Allowed then 1068 AUD := RTE (RE_Abort_Undefer_Direct); 1069 1070 Abrt_HSS := 1071 Make_Handled_Sequence_Of_Statements (Loc, 1072 Statements => New_List ( 1073 Build_Runtime_Call (Loc, RE_Abort_Defer), 1074 Fin_Blk), 1075 At_End_Proc => New_Occurrence_Of (AUD, Loc)); 1076 1077 Abrt_Blk := 1078 Make_Block_Statement (Loc, 1079 Handled_Statement_Sequence => Abrt_HSS); 1080 1081 Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); 1082 Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); 1083 1084 -- Present the Abort_Undefer_Direct function to the backend so 1085 -- that it can inline the call to the function. 1086 1087 Add_Inlined_Body (AUD, N); 1088 1089 -- Otherwise aborts are not allowed 1090 1091 else 1092 Abrt_Blk := Fin_Blk; 1093 end if; 1094 1095 Append_To (Stmts, Abrt_Blk); 1096 end if; 1097 1098 -- For a task type, call Free_Task before freeing the ATCB. We used to 1099 -- detect the case of Abort followed by a Free here, because the Free 1100 -- wouldn't actually free if it happens before the aborted task actually 1101 -- terminates. The warning was removed, because Free now works properly 1102 -- (the task will be freed once it terminates). 1103 1104 if Is_Task_Type (Desig_Typ) then 1105 Append_To (Stmts, 1106 Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); 1107 1108 -- For composite types that contain tasks, recurse over the structure 1109 -- to build the selectors for the task subcomponents. 1110 1111 elsif Has_Task (Desig_Typ) then 1112 if Is_Array_Type (Desig_Typ) then 1113 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); 1114 1115 elsif Is_Record_Type (Desig_Typ) then 1116 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); 1117 end if; 1118 end if; 1119 1120 -- Same for simple protected types. Eventually call Finalize_Protection 1121 -- before freeing the PO for each protected component. 1122 1123 if Is_Simple_Protected_Type (Desig_Typ) then 1124 Append_To (Stmts, 1125 Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); 1126 1127 elsif Has_Simple_Protected_Object (Desig_Typ) then 1128 if Is_Array_Type (Desig_Typ) then 1129 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); 1130 1131 elsif Is_Record_Type (Desig_Typ) then 1132 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); 1133 end if; 1134 end if; 1135 1136 -- Normal processing for non-controlled types. The argument to free is 1137 -- a renaming rather than a constant to ensure that the original context 1138 -- is always set to null after the deallocation takes place. 1139 1140 Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); 1141 Free_Nod := Make_Free_Statement (Loc, Empty); 1142 Append_To (Stmts, Free_Nod); 1143 Set_Storage_Pool (Free_Nod, Pool); 1144 1145 -- Attach to tree before analysis of generated subtypes below 1146 1147 Set_Parent (Stmts, Parent (N)); 1148 1149 -- Deal with storage pool 1150 1151 if Present (Pool) then 1152 1153 -- Freeing the secondary stack is meaningless 1154 1155 if Is_RTE (Pool, RE_SS_Pool) then 1156 null; 1157 1158 -- If the pool object is of a simple storage pool type, then attempt 1159 -- to locate the type's Deallocate procedure, if any, and set the 1160 -- free operation's procedure to call. If the type doesn't have a 1161 -- Deallocate (which is allowed), then the actual will simply be set 1162 -- to null. 1163 1164 elsif Present 1165 (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type)) 1166 then 1167 declare 1168 Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool)); 1169 Dealloc : Entity_Id; 1170 1171 begin 1172 Dealloc := Get_Name_Entity_Id (Name_Deallocate); 1173 while Present (Dealloc) loop 1174 if Scope (Dealloc) = Scope (Pool_Typ) 1175 and then Present (First_Formal (Dealloc)) 1176 and then Etype (First_Formal (Dealloc)) = Pool_Typ 1177 then 1178 Set_Procedure_To_Call (Free_Nod, Dealloc); 1179 exit; 1180 else 1181 Dealloc := Homonym (Dealloc); 1182 end if; 1183 end loop; 1184 end; 1185 1186 -- Case of a class-wide pool type: make a dispatching call to 1187 -- Deallocate through the class-wide Deallocate_Any. 1188 1189 elsif Is_Class_Wide_Type (Etype (Pool)) then 1190 Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any)); 1191 1192 -- Case of a specific pool type: make a statically bound call 1193 1194 else 1195 Set_Procedure_To_Call 1196 (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate)); 1197 end if; 1198 end if; 1199 1200 if Present (Procedure_To_Call (Free_Nod)) then 1201 1202 -- For all cases of a Deallocate call, the back-end needs to be able 1203 -- to compute the size of the object being freed. This may require 1204 -- some adjustments for objects of dynamic size. 1205 -- 1206 -- If the type is class wide, we generate an implicit type with the 1207 -- right dynamic size, so that the deallocate call gets the right 1208 -- size parameter computed by GIGI. Same for an access to 1209 -- unconstrained packed array. 1210 1211 if Is_Class_Wide_Type (Desig_Typ) 1212 or else 1213 (Is_Array_Type (Desig_Typ) 1214 and then not Is_Constrained (Desig_Typ) 1215 and then Is_Packed (Desig_Typ)) 1216 then 1217 declare 1218 Deref : constant Node_Id := 1219 Make_Explicit_Dereference (Loc, 1220 Duplicate_Subexpr_No_Checks (Arg)); 1221 D_Subtyp : Node_Id; 1222 D_Type : Entity_Id; 1223 1224 begin 1225 -- Perform minor decoration as it is needed by the side effect 1226 -- removal mechanism. 1227 1228 Set_Etype (Deref, Desig_Typ); 1229 Set_Parent (Deref, Free_Nod); 1230 D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ); 1231 1232 if Nkind (D_Subtyp) in N_Has_Entity then 1233 D_Type := Entity (D_Subtyp); 1234 1235 else 1236 D_Type := Make_Temporary (Loc, 'A'); 1237 Insert_Action (Deref, 1238 Make_Subtype_Declaration (Loc, 1239 Defining_Identifier => D_Type, 1240 Subtype_Indication => D_Subtyp)); 1241 end if; 1242 1243 -- Force freezing at the point of the dereference. For the 1244 -- class wide case, this avoids having the subtype frozen 1245 -- before the equivalent type. 1246 1247 Freeze_Itype (D_Type, Deref); 1248 1249 Set_Actual_Designated_Subtype (Free_Nod, D_Type); 1250 end; 1251 end if; 1252 end if; 1253 1254 -- Ada 2005 (AI-251): In case of abstract interface type we must 1255 -- displace the pointer to reference the base of the object to 1256 -- deallocate its memory, unless we're targetting a VM, in which case 1257 -- no special processing is required. 1258 1259 -- Generate: 1260 -- free (Base_Address (Obj_Ptr)) 1261 1262 if Is_Interface (Directly_Designated_Type (Typ)) 1263 and then Tagged_Type_Expansion 1264 then 1265 Set_Expression (Free_Nod, 1266 Unchecked_Convert_To (Typ, 1267 Make_Function_Call (Loc, 1268 Name => 1269 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 1270 Parameter_Associations => New_List ( 1271 Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); 1272 1273 -- Generate: 1274 -- free (Obj_Ptr) 1275 1276 else 1277 Set_Expression (Free_Nod, Free_Arg); 1278 end if; 1279 1280 -- Only remaining step is to set result to null, or generate a raise of 1281 -- Constraint_Error if the target object is "not null". 1282 1283 if Can_Never_Be_Null (Etype (Arg)) then 1284 Append_To (Stmts, 1285 Make_Raise_Constraint_Error (Loc, 1286 Reason => CE_Access_Check_Failed)); 1287 1288 else 1289 declare 1290 Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); 1291 begin 1292 Set_Assignment_OK (Lhs); 1293 Append_To (Stmts, 1294 Make_Assignment_Statement (Loc, 1295 Name => Lhs, 1296 Expression => Make_Null (Loc))); 1297 end; 1298 end if; 1299 1300 -- Generate a test of whether any earlier finalization raised an 1301 -- exception, and in that case raise Program_Error with the previous 1302 -- exception occurrence. 1303 1304 -- Generate: 1305 -- if Raised and then not Abrt then 1306 -- raise Program_Error; -- for restricted RTS 1307 -- <or> 1308 -- Raise_From_Controlled_Operation (E); -- all other cases 1309 -- end if; 1310 1311 if Needs_Fin and then Exceptions_OK then 1312 Append_To (Stmts, Build_Raise_Statement (Fin_Data)); 1313 end if; 1314 1315 -- If we know the argument is non-null, then make a block statement 1316 -- that contains the required statements, no need for a test. 1317 1318 if Arg_Known_Non_Null then 1319 Gen_Code := 1320 Make_Block_Statement (Loc, 1321 Handled_Statement_Sequence => 1322 Make_Handled_Sequence_Of_Statements (Loc, 1323 Statements => Stmts)); 1324 1325 -- If the argument may be null, wrap the statements inside an IF that 1326 -- does an explicit test to exclude the null case. 1327 1328 else 1329 Gen_Code := 1330 Make_Implicit_If_Statement (N, 1331 Condition => 1332 Make_Op_Ne (Loc, 1333 Left_Opnd => Duplicate_Subexpr (Arg), 1334 Right_Opnd => Make_Null (Loc)), 1335 Then_Statements => Stmts); 1336 end if; 1337 1338 -- Rewrite the call 1339 1340 Rewrite (N, Gen_Code); 1341 Analyze (N); 1342 end Expand_Unc_Deallocation; 1343 1344 ----------------------- 1345 -- Expand_To_Address -- 1346 ----------------------- 1347 1348 procedure Expand_To_Address (N : Node_Id) is 1349 Loc : constant Source_Ptr := Sloc (N); 1350 Arg : constant Node_Id := First_Actual (N); 1351 Obj : Node_Id; 1352 1353 begin 1354 Remove_Side_Effects (Arg); 1355 1356 Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); 1357 1358 Rewrite (N, 1359 Make_If_Expression (Loc, 1360 Expressions => New_List ( 1361 Make_Op_Eq (Loc, 1362 Left_Opnd => New_Copy_Tree (Arg), 1363 Right_Opnd => Make_Null (Loc)), 1364 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 1365 Make_Attribute_Reference (Loc, 1366 Prefix => Obj, 1367 Attribute_Name => Name_Address)))); 1368 1369 Analyze_And_Resolve (N, RTE (RE_Address)); 1370 end Expand_To_Address; 1371 1372 ----------------------- 1373 -- Expand_To_Pointer -- 1374 ----------------------- 1375 1376 procedure Expand_To_Pointer (N : Node_Id) is 1377 Arg : constant Node_Id := First_Actual (N); 1378 1379 begin 1380 Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); 1381 Analyze (N); 1382 end Expand_To_Pointer; 1383 1384end Exp_Intr; 1385