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