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