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