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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Exp_Ch4; use Exp_Ch4; 31with Exp_Ch7; use Exp_Ch7; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Code; use Exp_Code; 34with Exp_Fixd; use Exp_Fixd; 35with Exp_Util; use Exp_Util; 36with Itypes; use Itypes; 37with Namet; use Namet; 38with Nmake; use Nmake; 39with Nlists; use Nlists; 40with Restrict; use Restrict; 41with Rtsfind; use Rtsfind; 42with Sem; use Sem; 43with Sem_Eval; use Sem_Eval; 44with Sem_Res; use Sem_Res; 45with Sem_Util; use Sem_Util; 46with Sinfo; use Sinfo; 47with Sinput; use Sinput; 48with Snames; use Snames; 49with Stand; use Stand; 50with Stringt; use Stringt; 51with Tbuild; use Tbuild; 52with Uintp; use Uintp; 53with Urealp; use Urealp; 54 55package body Exp_Intr is 56 57 ----------------------- 58 -- Local Subprograms -- 59 ----------------------- 60 61 procedure Expand_Is_Negative (N : Node_Id); 62 -- Expand a call to the intrinsic Is_Negative function 63 64 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); 65 -- Expand a call to Exception_Information/Message/Name. The first 66 -- parameter, N, is the node for the function call, and Ent is the 67 -- entity for the corresponding routine in the Ada.Exceptions package. 68 69 procedure Expand_Import_Call (N : Node_Id); 70 -- Expand a call to Import_Address/Longest_Integer/Value. The parameter 71 -- N is the node for the function call. 72 73 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); 74 -- Expand an intrinsic shift operation, N and E are from the call to 75 -- Expand_Instrinsic_Call (call node and subprogram spec entity) and 76 -- K is the kind for the shift node 77 78 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); 79 -- Expand a call to an instantiation of Unchecked_Convertion into a node 80 -- N_Unchecked_Type_Conversion. 81 82 procedure Expand_Unc_Deallocation (N : Node_Id); 83 -- Expand a call to an instantiation of Unchecked_Deallocation into a node 84 -- N_Free_Statement and appropriate context. 85 86 procedure Expand_To_Address (N : Node_Id); 87 procedure Expand_To_Pointer (N : Node_Id); 88 -- Expand a call to corresponding function, declared in an instance of 89 -- System.Addess_To_Access_Conversions. 90 91 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); 92 -- Rewrite the node by the appropriate string or positive constant. 93 -- Nam can be one of the following: 94 -- Name_File - expand string that is the name of source file 95 -- Name_Line - expand integer line number 96 -- Name_Source_Location - expand string of form file:line 97 -- Name_Enclosing_Entity - expand string with name of enclosing entity 98 99 --------------------------- 100 -- Expand_Exception_Call -- 101 --------------------------- 102 103 -- If the function call is not within an exception handler, then the 104 -- call is replaced by a null string. Otherwise the appropriate routine 105 -- in Ada.Exceptions is called passing the choice parameter specification 106 -- from the enclosing handler. If the enclosing handler lacks a choice 107 -- parameter, then one is supplied. 108 109 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is 110 Loc : constant Source_Ptr := Sloc (N); 111 P : Node_Id; 112 E : Entity_Id; 113 S : String_Id; 114 115 begin 116 -- Climb up parents to see if we are in exception handler 117 118 P := Parent (N); 119 loop 120 -- Case of not in exception handler 121 122 if No (P) then 123 Start_String; 124 S := End_String; 125 Rewrite (N, 126 Make_String_Literal (Loc, 127 Strval => S)); 128 exit; 129 130 -- Case of in exception handler 131 132 elsif Nkind (P) = N_Exception_Handler then 133 if No (Choice_Parameter (P)) then 134 135 -- If no choice parameter present, then put one there. Note 136 -- that we do not need to put it on the entity chain, since 137 -- no one will be referencing it by normal visibility methods. 138 139 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); 140 Set_Choice_Parameter (P, E); 141 Set_Ekind (E, E_Variable); 142 Set_Etype (E, RTE (RE_Exception_Occurrence)); 143 Set_Scope (E, Current_Scope); 144 end if; 145 146 Rewrite (N, 147 Make_Function_Call (Loc, 148 Name => New_Occurrence_Of (RTE (Ent), Loc), 149 Parameter_Associations => New_List ( 150 New_Occurrence_Of (Choice_Parameter (P), Loc)))); 151 exit; 152 153 -- Keep climbing! 154 155 else 156 P := Parent (P); 157 end if; 158 end loop; 159 160 Analyze_And_Resolve (N, Standard_String); 161 end Expand_Exception_Call; 162 163 ------------------------ 164 -- Expand_Import_Call -- 165 ------------------------ 166 167 -- The function call must have a static string as its argument. We create 168 -- a dummy variable which uses this string as the external name in an 169 -- Import pragma. The result is then obtained as the address of this 170 -- dummy variable, converted to the appropriate target type. 171 172 procedure Expand_Import_Call (N : Node_Id) is 173 Loc : constant Source_Ptr := Sloc (N); 174 Ent : constant Entity_Id := Entity (Name (N)); 175 Str : constant Node_Id := First_Actual (N); 176 Dum : Entity_Id; 177 178 begin 179 Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); 180 181 Insert_Actions (N, New_List ( 182 Make_Object_Declaration (Loc, 183 Defining_Identifier => Dum, 184 Object_Definition => 185 New_Occurrence_Of (Standard_Character, Loc)), 186 187 Make_Pragma (Loc, 188 Chars => Name_Import, 189 Pragma_Argument_Associations => New_List ( 190 Make_Pragma_Argument_Association (Loc, 191 Expression => Make_Identifier (Loc, Name_Ada)), 192 193 Make_Pragma_Argument_Association (Loc, 194 Expression => Make_Identifier (Loc, Chars (Dum))), 195 196 Make_Pragma_Argument_Association (Loc, 197 Chars => Name_Link_Name, 198 Expression => Relocate_Node (Str)))))); 199 200 Rewrite (N, 201 Unchecked_Convert_To (Etype (Ent), 202 Make_Attribute_Reference (Loc, 203 Attribute_Name => Name_Address, 204 Prefix => Make_Identifier (Loc, Chars (Dum))))); 205 206 Analyze_And_Resolve (N, Etype (Ent)); 207 end Expand_Import_Call; 208 209 --------------------------- 210 -- Expand_Intrinsic_Call -- 211 --------------------------- 212 213 procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is 214 Nam : Name_Id; 215 216 begin 217 -- If the intrinsic subprogram is generic, gets its original name. 218 219 if Present (Parent (E)) 220 and then Present (Generic_Parent (Parent (E))) 221 then 222 Nam := Chars (Generic_Parent (Parent (E))); 223 else 224 Nam := Chars (E); 225 end if; 226 227 if Nam = Name_Asm then 228 Expand_Asm_Call (N); 229 230 elsif Nam = Name_Divide then 231 Expand_Decimal_Divide_Call (N); 232 233 elsif Nam = Name_Exception_Information then 234 Expand_Exception_Call (N, RE_Exception_Information); 235 236 elsif Nam = Name_Exception_Message then 237 Expand_Exception_Call (N, RE_Exception_Message); 238 239 elsif Nam = Name_Exception_Name then 240 Expand_Exception_Call (N, RE_Exception_Name_Simple); 241 242 elsif Nam = Name_Import_Address 243 or else 244 Nam = Name_Import_Largest_Value 245 or else 246 Nam = Name_Import_Value 247 then 248 Expand_Import_Call (N); 249 250 elsif Nam = Name_Is_Negative then 251 Expand_Is_Negative (N); 252 253 elsif Nam = Name_Rotate_Left then 254 Expand_Shift (N, E, N_Op_Rotate_Left); 255 256 elsif Nam = Name_Rotate_Right then 257 Expand_Shift (N, E, N_Op_Rotate_Right); 258 259 elsif Nam = Name_Shift_Left then 260 Expand_Shift (N, E, N_Op_Shift_Left); 261 262 elsif Nam = Name_Shift_Right then 263 Expand_Shift (N, E, N_Op_Shift_Right); 264 265 elsif Nam = Name_Shift_Right_Arithmetic then 266 Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); 267 268 elsif Nam = Name_Unchecked_Conversion then 269 Expand_Unc_Conversion (N, E); 270 271 elsif Nam = Name_Unchecked_Deallocation then 272 Expand_Unc_Deallocation (N); 273 274 elsif Nam = Name_To_Address then 275 Expand_To_Address (N); 276 277 elsif Nam = Name_To_Pointer then 278 Expand_To_Pointer (N); 279 280 elsif Nam = Name_File 281 or else Nam = Name_Line 282 or else Nam = Name_Source_Location 283 or else Nam = Name_Enclosing_Entity 284 then 285 Expand_Source_Info (N, Nam); 286 287 else 288 -- Only other possibility is a renaming, in which case we expand 289 -- the call to the original operation (which must be intrinsic). 290 291 pragma Assert (Present (Alias (E))); 292 Expand_Intrinsic_Call (N, Alias (E)); 293 end if; 294 end Expand_Intrinsic_Call; 295 296 ------------------------ 297 -- Expand_Is_Negative -- 298 ------------------------ 299 300 procedure Expand_Is_Negative (N : Node_Id) is 301 Loc : constant Source_Ptr := Sloc (N); 302 Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); 303 304 begin 305 306 -- We replace the function call by the following expression 307 308 -- if Opnd < 0.0 then 309 -- True 310 -- else 311 -- if Opnd > 0.0 then 312 -- False; 313 -- else 314 -- Float_Unsigned!(Float (Opnd)) /= 0 315 -- end if; 316 -- end if; 317 318 Rewrite (N, 319 Make_Conditional_Expression (Loc, 320 Expressions => New_List ( 321 Make_Op_Lt (Loc, 322 Left_Opnd => Duplicate_Subexpr (Opnd), 323 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 324 325 New_Occurrence_Of (Standard_True, Loc), 326 327 Make_Conditional_Expression (Loc, 328 Expressions => New_List ( 329 Make_Op_Gt (Loc, 330 Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), 331 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), 332 333 New_Occurrence_Of (Standard_False, Loc), 334 335 Make_Op_Ne (Loc, 336 Left_Opnd => 337 Unchecked_Convert_To 338 (RTE (RE_Float_Unsigned), 339 Convert_To 340 (Standard_Float, 341 Duplicate_Subexpr_No_Checks (Opnd))), 342 Right_Opnd => 343 Make_Integer_Literal (Loc, 0))))))); 344 345 Analyze_And_Resolve (N, Standard_Boolean); 346 end Expand_Is_Negative; 347 348 ------------------ 349 -- Expand_Shift -- 350 ------------------ 351 352 -- This procedure is used to convert a call to a shift function to the 353 -- corresponding operator node. This conversion is not done by the usual 354 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to 355 -- operator nodes, because shifts are not predefined operators. 356 357 -- As a result, whenever a shift is used in the source program, it will 358 -- remain as a call until converted by this routine to the operator node 359 -- form which Gigi is expecting to see. 360 361 -- Note: it is possible for the expander to generate shift operator nodes 362 -- directly, which will be analyzed in the normal manner by calling Analyze 363 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. 364 365 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is 366 Loc : constant Source_Ptr := Sloc (N); 367 Typ : constant Entity_Id := Etype (N); 368 Left : constant Node_Id := First_Actual (N); 369 Right : constant Node_Id := Next_Actual (Left); 370 Ltyp : constant Node_Id := Etype (Left); 371 Rtyp : constant Node_Id := Etype (Right); 372 Snode : Node_Id; 373 374 begin 375 Snode := New_Node (K, Loc); 376 Set_Left_Opnd (Snode, Relocate_Node (Left)); 377 Set_Right_Opnd (Snode, Relocate_Node (Right)); 378 Set_Chars (Snode, Chars (E)); 379 Set_Etype (Snode, Base_Type (Typ)); 380 Set_Entity (Snode, E); 381 382 if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) 383 and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) 384 then 385 Set_Shift_Count_OK (Snode, True); 386 end if; 387 388 -- Do the rewrite. Note that we don't call Analyze and Resolve on 389 -- this node, because it already got analyzed and resolved when 390 -- it was a function call! 391 392 Rewrite (N, Snode); 393 Set_Analyzed (N); 394 end Expand_Shift; 395 396 ------------------------ 397 -- Expand_Source_Info -- 398 ------------------------ 399 400 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is 401 Loc : constant Source_Ptr := Sloc (N); 402 Ent : Entity_Id; 403 404 begin 405 -- Integer cases 406 407 if Nam = Name_Line then 408 Rewrite (N, 409 Make_Integer_Literal (Loc, 410 Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); 411 Analyze_And_Resolve (N, Standard_Positive); 412 413 -- String cases 414 415 else 416 case Nam is 417 when Name_File => 418 Get_Decoded_Name_String 419 (Reference_Name (Get_Source_File_Index (Loc))); 420 421 when Name_Source_Location => 422 Build_Location_String (Loc); 423 424 when Name_Enclosing_Entity => 425 Name_Len := 0; 426 427 Ent := Current_Scope; 428 429 -- Skip enclosing blocks to reach enclosing unit. 430 431 while Present (Ent) loop 432 exit when Ekind (Ent) /= E_Block 433 and then Ekind (Ent) /= E_Loop; 434 Ent := Scope (Ent); 435 end loop; 436 437 -- Ent now points to the relevant defining entity 438 439 declare 440 SDef : Source_Ptr := Sloc (Ent); 441 TDef : Source_Buffer_Ptr; 442 443 begin 444 TDef := Source_Text (Get_Source_File_Index (SDef)); 445 Name_Len := 0; 446 447 while TDef (SDef) in '0' .. '9' 448 or else TDef (SDef) >= 'A' 449 or else TDef (SDef) = ASCII.ESC 450 loop 451 Add_Char_To_Name_Buffer (TDef (SDef)); 452 SDef := SDef + 1; 453 end loop; 454 end; 455 456 when others => 457 raise Program_Error; 458 end case; 459 460 Rewrite (N, 461 Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); 462 Analyze_And_Resolve (N, Standard_String); 463 end if; 464 465 Set_Is_Static_Expression (N); 466 end Expand_Source_Info; 467 468 --------------------------- 469 -- Expand_Unc_Conversion -- 470 --------------------------- 471 472 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is 473 Func : constant Entity_Id := Entity (Name (N)); 474 Conv : Node_Id; 475 Ftyp : Entity_Id; 476 477 begin 478 -- Rewrite as unchecked conversion node. Note that we must convert 479 -- the operand to the formal type of the input parameter of the 480 -- function, so that the resulting N_Unchecked_Type_Conversion 481 -- call indicates the correct types for Gigi. 482 483 -- Right now, we only do this if a scalar type is involved. It is 484 -- not clear if it is needed in other cases. If we do attempt to 485 -- do the conversion unconditionally, it crashes 3411-018. To be 486 -- investigated further ??? 487 488 Conv := Relocate_Node (First_Actual (N)); 489 Ftyp := Etype (First_Formal (Func)); 490 491 if Is_Scalar_Type (Ftyp) then 492 Conv := Convert_To (Ftyp, Conv); 493 Set_Parent (Conv, N); 494 Analyze_And_Resolve (Conv); 495 end if; 496 497 -- We do the analysis here, because we do not want the compiler 498 -- to try to optimize or otherwise reorganize the unchecked 499 -- conversion node. 500 501 Rewrite (N, Unchecked_Convert_To (Etype (E), Conv)); 502 Set_Etype (N, Etype (E)); 503 Set_Analyzed (N); 504 505 if Nkind (N) = N_Unchecked_Type_Conversion then 506 Expand_N_Unchecked_Type_Conversion (N); 507 end if; 508 end Expand_Unc_Conversion; 509 510 ----------------------------- 511 -- Expand_Unc_Deallocation -- 512 ----------------------------- 513 514 -- Generate the following Code : 515 516 -- if Arg /= null then 517 -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types 518 -- Free (Arg); 519 -- Arg := Null; 520 -- end if; 521 522 -- For a task, we also generate a call to Free_Task to ensure that the 523 -- task itself is freed if it is terminated, ditto for a simple protected 524 -- object, with a call to Finalize_Protection. For composite types that 525 -- have tasks or simple protected objects as components, we traverse the 526 -- structures to find and terminate those components. 527 528 procedure Expand_Unc_Deallocation (N : Node_Id) is 529 Loc : constant Source_Ptr := Sloc (N); 530 Arg : constant Node_Id := First_Actual (N); 531 Typ : constant Entity_Id := Etype (Arg); 532 Stmts : constant List_Id := New_List; 533 Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); 534 Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); 535 536 Desig_T : constant Entity_Id := Designated_Type (Typ); 537 Gen_Code : Node_Id; 538 Free_Node : Node_Id; 539 Deref : Node_Id; 540 Free_Arg : Node_Id; 541 Free_Cod : List_Id; 542 Blk : Node_Id; 543 544 begin 545 if No_Pool_Assigned (Rtyp) then 546 Error_Msg_N ("?deallocation from empty storage pool", N); 547 end if; 548 549 if Controlled_Type (Desig_T) then 550 Deref := 551 Make_Explicit_Dereference (Loc, 552 Prefix => Duplicate_Subexpr_No_Checks (Arg)); 553 554 -- If the type is tagged, then we must force dispatching on the 555 -- finalization call because the designated type may not be the 556 -- actual type of the object 557 558 if Is_Tagged_Type (Desig_T) 559 and then not Is_Class_Wide_Type (Desig_T) 560 then 561 Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); 562 end if; 563 564 Free_Cod := 565 Make_Final_Call 566 (Ref => Deref, 567 Typ => Desig_T, 568 With_Detach => New_Reference_To (Standard_True, Loc)); 569 570 if Abort_Allowed then 571 Prepend_To (Free_Cod, 572 Build_Runtime_Call (Loc, RE_Abort_Defer)); 573 574 Blk := 575 Make_Block_Statement (Loc, Handled_Statement_Sequence => 576 Make_Handled_Sequence_Of_Statements (Loc, 577 Statements => Free_Cod, 578 At_End_Proc => 579 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); 580 581 -- We now expand the exception (at end) handler. We set a 582 -- temporary parent pointer since we have not attached Blk 583 -- to the tree yet. 584 585 Set_Parent (Blk, N); 586 Analyze (Blk); 587 Expand_At_End_Handler 588 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); 589 Append (Blk, Stmts); 590 591 else 592 Append_List_To (Stmts, Free_Cod); 593 end if; 594 end if; 595 596 -- For a task type, call Free_Task before freeing the ATCB 597 598 if Is_Task_Type (Desig_T) then 599 declare 600 Stat : Node_Id := Prev (N); 601 Nam1 : Node_Id; 602 Nam2 : Node_Id; 603 604 begin 605 -- An Abort followed by a Free will not do what the user 606 -- expects, because the abort is not immediate. This is 607 -- worth a friendly warning. 608 609 while Present (Stat) 610 and then not Comes_From_Source (Original_Node (Stat)) 611 loop 612 Prev (Stat); 613 end loop; 614 615 if Present (Stat) 616 and then Nkind (Original_Node (Stat)) = N_Abort_Statement 617 then 618 Stat := Original_Node (Stat); 619 Nam1 := First (Names (Stat)); 620 Nam2 := Original_Node (First (Parameter_Associations (N))); 621 622 if Nkind (Nam1) = N_Explicit_Dereference 623 and then Is_Entity_Name (Prefix (Nam1)) 624 and then Is_Entity_Name (Nam2) 625 and then Entity (Prefix (Nam1)) = Entity (Nam2) 626 then 627 Error_Msg_N ("Abort may take time to complete?", N); 628 Error_Msg_N ("\deallocation might have no effect?", N); 629 Error_Msg_N ("\safer to wait for termination.?", N); 630 end if; 631 end if; 632 end; 633 634 Append_To 635 (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); 636 637 -- For composite types that contain tasks, recurse over the structure 638 -- to build the selectors for the task subcomponents. 639 640 elsif Has_Task (Desig_T) then 641 if Is_Record_Type (Desig_T) then 642 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); 643 644 elsif Is_Array_Type (Desig_T) then 645 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); 646 end if; 647 end if; 648 649 -- Same for simple protected types. Eventually call Finalize_Protection 650 -- before freeing the PO for each protected component. 651 652 if Is_Simple_Protected_Type (Desig_T) then 653 Append_To (Stmts, 654 Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); 655 656 elsif Has_Simple_Protected_Object (Desig_T) then 657 if Is_Record_Type (Desig_T) then 658 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); 659 elsif Is_Array_Type (Desig_T) then 660 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); 661 end if; 662 end if; 663 664 -- Normal processing for non-controlled types 665 666 Free_Arg := Duplicate_Subexpr_No_Checks (Arg); 667 Free_Node := Make_Free_Statement (Loc, Empty); 668 Append_To (Stmts, Free_Node); 669 Set_Storage_Pool (Free_Node, Pool); 670 671 -- Make implicit if statement. We omit this if we are the then part 672 -- of a test of the form: 673 674 -- if not (Arg = null) then 675 676 -- i.e. if the test is explicit in the source. Arg must be a simple 677 -- identifier for the purposes of this special test. Note that the 678 -- use of /= in the source is always transformed into the above form. 679 680 declare 681 Test_Needed : Boolean := True; 682 P : constant Node_Id := Parent (N); 683 C : Node_Id; 684 685 begin 686 if Nkind (Arg) = N_Identifier 687 and then Nkind (P) = N_If_Statement 688 and then First (Then_Statements (P)) = N 689 then 690 if Nkind (Condition (P)) = N_Op_Not then 691 C := Right_Opnd (Condition (P)); 692 693 if Nkind (C) = N_Op_Eq 694 and then Nkind (Left_Opnd (C)) = N_Identifier 695 and then Chars (Arg) = Chars (Left_Opnd (C)) 696 and then Nkind (Right_Opnd (C)) = N_Null 697 then 698 Test_Needed := False; 699 end if; 700 end if; 701 end if; 702 703 -- Generate If_Statement if needed 704 705 if Test_Needed then 706 Gen_Code := 707 Make_Implicit_If_Statement (N, 708 Condition => 709 Make_Op_Ne (Loc, 710 Left_Opnd => Duplicate_Subexpr (Arg), 711 Right_Opnd => Make_Null (Loc)), 712 Then_Statements => Stmts); 713 714 else 715 Gen_Code := 716 Make_Block_Statement (Loc, 717 Handled_Statement_Sequence => 718 Make_Handled_Sequence_Of_Statements (Loc, 719 Statements => Stmts)); 720 end if; 721 end; 722 723 -- Deal with storage pool 724 725 if Present (Pool) then 726 727 -- Freeing the secondary stack is meaningless 728 729 if Is_RTE (Pool, RE_SS_Pool) then 730 null; 731 732 elsif Is_Class_Wide_Type (Etype (Pool)) then 733 Set_Procedure_To_Call (Free_Node, 734 RTE (RE_Deallocate_Any)); 735 else 736 Set_Procedure_To_Call (Free_Node, 737 Find_Prim_Op (Etype (Pool), Name_Deallocate)); 738 739 -- If the type is class wide, we generate an implicit type 740 -- with the right dynamic size, so that the deallocate call 741 -- gets the right size parameter computed by gigi 742 743 if Is_Class_Wide_Type (Desig_T) then 744 declare 745 Acc_Type : constant Entity_Id := 746 Create_Itype (E_Access_Type, N); 747 Deref : constant Node_Id := 748 Make_Explicit_Dereference (Loc, 749 Duplicate_Subexpr_No_Checks (Arg)); 750 751 begin 752 Set_Etype (Deref, Typ); 753 Set_Parent (Deref, Free_Node); 754 755 Set_Etype (Acc_Type, Acc_Type); 756 Set_Size_Info (Acc_Type, Typ); 757 Set_Directly_Designated_Type 758 (Acc_Type, Entity (Make_Subtype_From_Expr 759 (Deref, Desig_T))); 760 761 Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg); 762 end; 763 end if; 764 end if; 765 end if; 766 767 Set_Expression (Free_Node, Free_Arg); 768 769 declare 770 Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); 771 772 begin 773 Set_Assignment_OK (Lhs); 774 Append_To (Stmts, 775 Make_Assignment_Statement (Loc, 776 Name => Lhs, 777 Expression => Make_Null (Loc))); 778 end; 779 780 Rewrite (N, Gen_Code); 781 Analyze (N); 782 end Expand_Unc_Deallocation; 783 784 ----------------------- 785 -- Expand_To_Address -- 786 ----------------------- 787 788 procedure Expand_To_Address (N : Node_Id) is 789 Loc : constant Source_Ptr := Sloc (N); 790 Arg : constant Node_Id := First_Actual (N); 791 Obj : Node_Id; 792 793 begin 794 Remove_Side_Effects (Arg); 795 796 Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); 797 798 Rewrite (N, 799 Make_Conditional_Expression (Loc, 800 Expressions => New_List ( 801 Make_Op_Eq (Loc, 802 Left_Opnd => New_Copy_Tree (Arg), 803 Right_Opnd => Make_Null (Loc)), 804 New_Occurrence_Of (RTE (RE_Null_Address), Loc), 805 Make_Attribute_Reference (Loc, 806 Attribute_Name => Name_Address, 807 Prefix => Obj)))); 808 809 Analyze_And_Resolve (N, RTE (RE_Address)); 810 end Expand_To_Address; 811 812 ----------------------- 813 -- Expand_To_Pointer -- 814 ----------------------- 815 816 procedure Expand_To_Pointer (N : Node_Id) is 817 Arg : constant Node_Id := First_Actual (N); 818 819 begin 820 Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); 821 Analyze (N); 822 end Expand_To_Pointer; 823 824end Exp_Intr; 825