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 992 -- Ada 2005 (AI-251): In case of abstract interface type we displace 993 -- the pointer to reference the base of the object to deallocate its 994 -- memory, unless we're targetting a VM, in which case no special 995 -- processing is required. 996 997 if Is_Interface (Directly_Designated_Type (Typ)) 998 and then Tagged_Type_Expansion 999 then 1000 Obj_Ref := 1001 Make_Explicit_Dereference (Loc, 1002 Prefix => 1003 Unchecked_Convert_To (Typ, 1004 Make_Function_Call (Loc, 1005 Name => 1006 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 1007 Parameter_Associations => New_List ( 1008 Unchecked_Convert_To (RTE (RE_Address), 1009 Duplicate_Subexpr_No_Checks (Arg)))))); 1010 1011 else 1012 Obj_Ref := 1013 Make_Explicit_Dereference (Loc, 1014 Prefix => Duplicate_Subexpr_No_Checks (Arg)); 1015 end if; 1016 1017 -- If the designated type is tagged, the finalization call must 1018 -- dispatch because the designated type may not be the actual type 1019 -- of the object. If the type is synchronized, the deallocation 1020 -- applies to the corresponding record type. 1021 1022 if Is_Tagged_Type (Desig_Typ) then 1023 if Is_Concurrent_Type (Desig_Typ) then 1024 Obj_Ref := 1025 Unchecked_Convert_To 1026 (Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)), 1027 Obj_Ref); 1028 1029 elsif not Is_Class_Wide_Type (Desig_Typ) then 1030 Obj_Ref := 1031 Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref); 1032 end if; 1033 1034 -- Otherwise the designated type is untagged. Set the type of the 1035 -- dereference explicitly to force a conversion when needed given 1036 -- that [Deep_]Finalize may be inherited from a parent type. 1037 1038 else 1039 Set_Etype (Obj_Ref, Desig_Typ); 1040 end if; 1041 1042 -- Generate: 1043 -- [Deep_]Finalize (Obj_Ref); 1044 1045 Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); 1046 1047 -- Generate: 1048 -- Abrt : constant Boolean := ...; 1049 -- Ex : Exception_Occurrence; 1050 -- Raised : Boolean := False; 1051 1052 -- begin 1053 -- <Fin_Call> 1054 1055 -- exception 1056 -- when others => 1057 -- if not Raised then 1058 -- Raised := True; 1059 -- Save_Occurrence (Ex, Get_Current_Excep.all.all); 1060 -- end; 1061 1062 if Exceptions_OK then 1063 Build_Object_Declarations (Fin_Data, Stmts, Loc); 1064 1065 Fin_Blk := 1066 Make_Block_Statement (Loc, 1067 Handled_Statement_Sequence => 1068 Make_Handled_Sequence_Of_Statements (Loc, 1069 Statements => New_List (Fin_Call), 1070 Exception_Handlers => New_List ( 1071 Build_Exception_Handler (Fin_Data)))); 1072 1073 -- Otherwise exception propagation is not allowed 1074 1075 else 1076 Fin_Blk := Fin_Call; 1077 end if; 1078 1079 -- The finalization action must be protected by an abort defer and 1080 -- undefer pair when aborts are allowed. Generate: 1081 1082 -- begin 1083 -- Abort_Defer; 1084 -- <Fin_Blk> 1085 -- at end 1086 -- Abort_Undefer_Direct; 1087 -- end; 1088 1089 if Abort_Allowed then 1090 AUD := RTE (RE_Abort_Undefer_Direct); 1091 1092 Abrt_HSS := 1093 Make_Handled_Sequence_Of_Statements (Loc, 1094 Statements => New_List ( 1095 Build_Runtime_Call (Loc, RE_Abort_Defer), 1096 Fin_Blk), 1097 At_End_Proc => New_Occurrence_Of (AUD, Loc)); 1098 1099 Abrt_Blk := 1100 Make_Block_Statement (Loc, 1101 Handled_Statement_Sequence => Abrt_HSS); 1102 1103 Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); 1104 Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); 1105 1106 -- Present the Abort_Undefer_Direct function to the backend so 1107 -- that it can inline the call to the function. 1108 1109 Add_Inlined_Body (AUD, N); 1110 1111 -- Otherwise aborts are not allowed 1112 1113 else 1114 Abrt_Blk := Fin_Blk; 1115 end if; 1116 1117 Append_To (Stmts, Abrt_Blk); 1118 end if; 1119 1120 -- For a task type, call Free_Task before freeing the ATCB. We used to 1121 -- detect the case of Abort followed by a Free here, because the Free 1122 -- wouldn't actually free if it happens before the aborted task actually 1123 -- terminates. The warning was removed, because Free now works properly 1124 -- (the task will be freed once it terminates). 1125 1126 if Is_Task_Type (Desig_Typ) then 1127 Append_To (Stmts, 1128 Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); 1129 1130 -- For composite types that contain tasks, recurse over the structure 1131 -- to build the selectors for the task subcomponents. 1132 1133 elsif Has_Task (Desig_Typ) then 1134 if Is_Array_Type (Desig_Typ) then 1135 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); 1136 1137 elsif Is_Record_Type (Desig_Typ) then 1138 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); 1139 end if; 1140 end if; 1141 1142 -- Same for simple protected types. Eventually call Finalize_Protection 1143 -- before freeing the PO for each protected component. 1144 1145 if Is_Simple_Protected_Type (Desig_Typ) then 1146 Append_To (Stmts, 1147 Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); 1148 1149 elsif Has_Simple_Protected_Object (Desig_Typ) then 1150 if Is_Array_Type (Desig_Typ) then 1151 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); 1152 1153 elsif Is_Record_Type (Desig_Typ) then 1154 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); 1155 end if; 1156 end if; 1157 1158 -- Normal processing for non-controlled types. The argument to free is 1159 -- a renaming rather than a constant to ensure that the original context 1160 -- is always set to null after the deallocation takes place. 1161 1162 Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); 1163 Free_Nod := Make_Free_Statement (Loc, Empty); 1164 Append_To (Stmts, Free_Nod); 1165 Set_Storage_Pool (Free_Nod, Pool); 1166 1167 -- Attach to tree before analysis of generated subtypes below 1168 1169 Set_Parent (Stmts, Parent (N)); 1170 1171 -- Deal with storage pool 1172 1173 if Present (Pool) then 1174 1175 -- Freeing the secondary stack is meaningless 1176 1177 if Is_RTE (Pool, RE_SS_Pool) then 1178 null; 1179 1180 -- If the pool object is of a simple storage pool type, then attempt 1181 -- to locate the type's Deallocate procedure, if any, and set the 1182 -- free operation's procedure to call. If the type doesn't have a 1183 -- Deallocate (which is allowed), then the actual will simply be set 1184 -- to null. 1185 1186 elsif Present 1187 (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type)) 1188 then 1189 declare 1190 Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool)); 1191 Dealloc : Entity_Id; 1192 1193 begin 1194 Dealloc := Get_Name_Entity_Id (Name_Deallocate); 1195 while Present (Dealloc) loop 1196 if Scope (Dealloc) = Scope (Pool_Typ) 1197 and then Present (First_Formal (Dealloc)) 1198 and then Etype (First_Formal (Dealloc)) = Pool_Typ 1199 then 1200 Set_Procedure_To_Call (Free_Nod, Dealloc); 1201 exit; 1202 else 1203 Dealloc := Homonym (Dealloc); 1204 end if; 1205 end loop; 1206 end; 1207 1208 -- Case of a class-wide pool type: make a dispatching call to 1209 -- Deallocate through the class-wide Deallocate_Any. 1210 1211 elsif Is_Class_Wide_Type (Etype (Pool)) then 1212 Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any)); 1213 1214 -- Case of a specific pool type: make a statically bound call 1215 1216 else 1217 Set_Procedure_To_Call 1218 (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate)); 1219 end if; 1220 end if; 1221 1222 if Present (Procedure_To_Call (Free_Nod)) then 1223 1224 -- For all cases of a Deallocate call, the back-end needs to be able 1225 -- to compute the size of the object being freed. This may require 1226 -- some adjustments for objects of dynamic size. 1227 -- 1228 -- If the type is class wide, we generate an implicit type with the 1229 -- right dynamic size, so that the deallocate call gets the right 1230 -- size parameter computed by GIGI. Same for an access to 1231 -- unconstrained packed array. 1232 1233 if Is_Class_Wide_Type (Desig_Typ) 1234 or else 1235 (Is_Array_Type (Desig_Typ) 1236 and then not Is_Constrained (Desig_Typ) 1237 and then Is_Packed (Desig_Typ)) 1238 then 1239 declare 1240 Deref : constant Node_Id := 1241 Make_Explicit_Dereference (Loc, 1242 Duplicate_Subexpr_No_Checks (Arg)); 1243 D_Subtyp : Node_Id; 1244 D_Type : Entity_Id; 1245 1246 begin 1247 -- Perform minor decoration as it is needed by the side effect 1248 -- removal mechanism. 1249 1250 Set_Etype (Deref, Desig_Typ); 1251 Set_Parent (Deref, Free_Nod); 1252 D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ); 1253 1254 if Nkind (D_Subtyp) in N_Has_Entity then 1255 D_Type := Entity (D_Subtyp); 1256 1257 else 1258 D_Type := Make_Temporary (Loc, 'A'); 1259 Insert_Action (Deref, 1260 Make_Subtype_Declaration (Loc, 1261 Defining_Identifier => D_Type, 1262 Subtype_Indication => D_Subtyp)); 1263 end if; 1264 1265 -- Force freezing at the point of the dereference. For the 1266 -- class wide case, this avoids having the subtype frozen 1267 -- before the equivalent type. 1268 1269 Freeze_Itype (D_Type, Deref); 1270 1271 Set_Actual_Designated_Subtype (Free_Nod, D_Type); 1272 end; 1273 end if; 1274 end if; 1275 1276 -- Ada 2005 (AI-251): In case of abstract interface type we must 1277 -- displace the pointer to reference the base of the object to 1278 -- deallocate its memory, unless we're targetting a VM, in which case 1279 -- no special processing is required. 1280 1281 -- Generate: 1282 -- free (Base_Address (Obj_Ptr)) 1283 1284 if Is_Interface (Directly_Designated_Type (Typ)) 1285 and then Tagged_Type_Expansion 1286 then 1287 Set_Expression (Free_Nod, 1288 Unchecked_Convert_To (Typ, 1289 Make_Function_Call (Loc, 1290 Name => 1291 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 1292 Parameter_Associations => New_List ( 1293 Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); 1294 1295 -- Generate: 1296 -- free (Obj_Ptr) 1297 1298 else 1299 Set_Expression (Free_Nod, Free_Arg); 1300 end if; 1301 1302 -- Only remaining step is to set result to null, or generate a raise of 1303 -- Constraint_Error if the target object is "not null". 1304 1305 if Can_Never_Be_Null (Etype (Arg)) then 1306 Append_To (Stmts, 1307 Make_Raise_Constraint_Error (Loc, 1308 Reason => CE_Access_Check_Failed)); 1309 1310 else 1311 declare 1312 Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); 1313 begin 1314 Set_Assignment_OK (Lhs); 1315 Append_To (Stmts, 1316 Make_Assignment_Statement (Loc, 1317 Name => Lhs, 1318 Expression => Make_Null (Loc))); 1319 end; 1320 end if; 1321 1322 -- Generate a test of whether any earlier finalization raised an 1323 -- exception, and in that case raise Program_Error with the previous 1324 -- exception occurrence. 1325 1326 -- Generate: 1327 -- if Raised and then not Abrt then 1328 -- raise Program_Error; -- for restricted RTS 1329 -- <or> 1330 -- Raise_From_Controlled_Operation (E); -- all other cases 1331 -- end if; 1332 1333 if Needs_Fin and then Exceptions_OK then 1334 Append_To (Stmts, Build_Raise_Statement (Fin_Data)); 1335 end if; 1336 1337 -- If we know the argument is non-null, then make a block statement 1338 -- that contains the required statements, no need for a test. 1339 1340 if Arg_Known_Non_Null then 1341 Gen_Code := 1342 Make_Block_Statement (Loc, 1343 Handled_Statement_Sequence => 1344 Make_Handled_Sequence_Of_Statements (Loc, 1345 Statements => Stmts)); 1346 1347 -- If the argument may be null, wrap the statements inside an IF that 1348 -- does an explicit test to exclude the null case. 1349 1350 else 1351 Gen_Code := 1352 Make_Implicit_If_Statement (N, 1353 Condition => 1354 Make_Op_Ne (Loc, 1355 Left_Opnd => Duplicate_Subexpr (Arg), 1356 Right_Opnd => Make_Null (Loc)), 1357 Then_Statements => Stmts); 1358 end if; 1359 1360 -- Rewrite the call 1361 1362 Rewrite (N, Gen_Code); 1363 Analyze (N); 1364 end Expand_Unc_Deallocation; 1365 1366 ----------------------- 1367 -- Expand_To_Address -- 1368 ----------------------- 1369 1370 procedure Expand_To_Address (N : Node_Id) is 1371 Loc : constant Source_Ptr := Sloc (N); 1372 Arg : constant Node_Id := First_Actual (N); 1373 Obj : Node_Id; 1374 1375 begin 1376 Remove_Side_Effects (Arg); 1377 1378 Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); 1379 1380 Rewrite (N, 1381 Make_If_Expression (Loc, 1382 Expressions => New_List ( 1383 Make_Op_Eq (Loc, 1384 Left_Opnd => New_Copy_Tree (Arg), 1385 Right_Opnd => Make_Null (Loc)), 1386 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 1387 Make_Attribute_Reference (Loc, 1388 Prefix => Obj, 1389 Attribute_Name => Name_Address)))); 1390 1391 Analyze_And_Resolve (N, RTE (RE_Address)); 1392 end Expand_To_Address; 1393 1394 ----------------------- 1395 -- Expand_To_Pointer -- 1396 ----------------------- 1397 1398 procedure Expand_To_Pointer (N : Node_Id) is 1399 Arg : constant Node_Id := First_Actual (N); 1400 1401 begin 1402 Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); 1403 Analyze (N); 1404 end Expand_To_Pointer; 1405 1406end Exp_Intr; 1407