1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- T B U I L D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, 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 Einfo; use Einfo; 28with Elists; use Elists; 29with Lib; use Lib; 30with Nlists; use Nlists; 31with Nmake; use Nmake; 32with Opt; use Opt; 33with Restrict; use Restrict; 34with Rident; use Rident; 35with Sem_Aux; use Sem_Aux; 36with Snames; use Snames; 37with Stand; use Stand; 38with Stringt; use Stringt; 39with Urealp; use Urealp; 40 41package body Tbuild is 42 43 ----------------------- 44 -- Local Subprograms -- 45 ----------------------- 46 47 procedure Add_Unique_Serial_Number; 48 -- Add a unique serialization to the string in the Name_Buffer. This 49 -- consists of a unit specific serial number, and b/s for body/spec. 50 51 ------------------------------ 52 -- Add_Unique_Serial_Number -- 53 ------------------------------ 54 55 Config_Serial_Number : Nat := 0; 56 -- Counter for use in config pragmas, see comment below 57 58 procedure Add_Unique_Serial_Number is 59 begin 60 -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will 61 -- not be set yet. This happens for example when analyzing static 62 -- string expressions in configuration pragmas. For this case, we 63 -- just maintain a local counter, defined above and we do not need 64 -- to add a b or s indication in this case. 65 66 if No (Cunit (Current_Sem_Unit)) then 67 Config_Serial_Number := Config_Serial_Number + 1; 68 Add_Nat_To_Name_Buffer (Config_Serial_Number); 69 return; 70 71 -- Normal case, within a unit 72 73 else 74 declare 75 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); 76 77 begin 78 Add_Nat_To_Name_Buffer (Increment_Serial_Number); 79 80 -- Add either b or s, depending on whether current unit is a spec 81 -- or a body. This is needed because we may generate the same name 82 -- in a spec and a body otherwise. 83 84 Name_Len := Name_Len + 1; 85 86 if Nkind (Unit_Node) = N_Package_Declaration 87 or else Nkind (Unit_Node) = N_Subprogram_Declaration 88 or else Nkind (Unit_Node) in N_Generic_Declaration 89 then 90 Name_Buffer (Name_Len) := 's'; 91 else 92 Name_Buffer (Name_Len) := 'b'; 93 end if; 94 end; 95 end if; 96 end Add_Unique_Serial_Number; 97 98 ---------------- 99 -- Checks_Off -- 100 ---------------- 101 102 function Checks_Off (N : Node_Id) return Node_Id is 103 begin 104 return 105 Make_Unchecked_Expression (Sloc (N), 106 Expression => N); 107 end Checks_Off; 108 109 ---------------- 110 -- Convert_To -- 111 ---------------- 112 113 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is 114 Result : Node_Id; 115 116 begin 117 if Present (Etype (Expr)) 118 and then (Etype (Expr)) = Typ 119 then 120 return Relocate_Node (Expr); 121 else 122 Result := 123 Make_Type_Conversion (Sloc (Expr), 124 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), 125 Expression => Relocate_Node (Expr)); 126 127 Set_Etype (Result, Typ); 128 return Result; 129 end if; 130 end Convert_To; 131 132 ---------------------------- 133 -- Convert_To_And_Rewrite -- 134 ---------------------------- 135 136 procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id) is 137 begin 138 Rewrite (Expr, Convert_To (Typ, Expr)); 139 end Convert_To_And_Rewrite; 140 141 ------------------ 142 -- Discard_List -- 143 ------------------ 144 145 procedure Discard_List (L : List_Id) is 146 pragma Warnings (Off, L); 147 begin 148 null; 149 end Discard_List; 150 151 ------------------ 152 -- Discard_Node -- 153 ------------------ 154 155 procedure Discard_Node (N : Node_Or_Entity_Id) is 156 pragma Warnings (Off, N); 157 begin 158 null; 159 end Discard_Node; 160 161 ------------------------------------------- 162 -- Make_Byte_Aligned_Attribute_Reference -- 163 ------------------------------------------- 164 165 function Make_Byte_Aligned_Attribute_Reference 166 (Sloc : Source_Ptr; 167 Prefix : Node_Id; 168 Attribute_Name : Name_Id) 169 return Node_Id 170 is 171 N : constant Node_Id := 172 Make_Attribute_Reference (Sloc, 173 Prefix => Prefix, 174 Attribute_Name => Attribute_Name); 175 176 begin 177 pragma Assert (Attribute_Name = Name_Address 178 or else 179 Attribute_Name = Name_Unrestricted_Access); 180 Set_Must_Be_Byte_Aligned (N, True); 181 return N; 182 end Make_Byte_Aligned_Attribute_Reference; 183 184 -------------------- 185 -- Make_DT_Access -- 186 -------------------- 187 188 function Make_DT_Access 189 (Loc : Source_Ptr; 190 Rec : Node_Id; 191 Typ : Entity_Id) return Node_Id 192 is 193 Full_Type : Entity_Id := Typ; 194 195 begin 196 if Is_Private_Type (Typ) then 197 Full_Type := Underlying_Type (Typ); 198 end if; 199 200 return 201 Unchecked_Convert_To ( 202 New_Occurrence_Of 203 (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc), 204 Make_Selected_Component (Loc, 205 Prefix => New_Copy (Rec), 206 Selector_Name => 207 New_Reference_To (First_Tag_Component (Full_Type), Loc))); 208 end Make_DT_Access; 209 210 ------------------------ 211 -- Make_Float_Literal -- 212 ------------------------ 213 214 function Make_Float_Literal 215 (Loc : Source_Ptr; 216 Radix : Uint; 217 Significand : Uint; 218 Exponent : Uint) return Node_Id 219 is 220 begin 221 if Radix = 2 and then abs Significand /= 1 then 222 return 223 Make_Float_Literal 224 (Loc, Uint_16, 225 Significand * Radix**(Exponent mod 4), 226 Exponent / 4); 227 228 else 229 declare 230 N : constant Node_Id := New_Node (N_Real_Literal, Loc); 231 232 begin 233 Set_Realval (N, 234 UR_From_Components 235 (Num => abs Significand, 236 Den => -Exponent, 237 Rbase => UI_To_Int (Radix), 238 Negative => Significand < 0)); 239 return N; 240 end; 241 end if; 242 end Make_Float_Literal; 243 244 ------------------------------------- 245 -- Make_Implicit_Exception_Handler -- 246 ------------------------------------- 247 248 function Make_Implicit_Exception_Handler 249 (Sloc : Source_Ptr; 250 Choice_Parameter : Node_Id := Empty; 251 Exception_Choices : List_Id; 252 Statements : List_Id) return Node_Id 253 is 254 Handler : Node_Id; 255 Loc : Source_Ptr; 256 257 begin 258 -- Set the source location only when debugging the expanded code 259 260 -- When debugging the source code directly, we do not want the compiler 261 -- to associate this implicit exception handler with any specific source 262 -- line, because it can potentially confuse the debugger. The most 263 -- damaging situation would arise when the debugger tries to insert a 264 -- breakpoint at a certain line. If the code of the associated implicit 265 -- exception handler is generated before the code of that line, then the 266 -- debugger will end up inserting the breakpoint inside the exception 267 -- handler, rather than the code the user intended to break on. As a 268 -- result, it is likely that the program will not hit the breakpoint 269 -- as expected. 270 271 if Debug_Generated_Code then 272 Loc := Sloc; 273 else 274 Loc := No_Location; 275 end if; 276 277 Handler := 278 Make_Exception_Handler 279 (Loc, Choice_Parameter, Exception_Choices, Statements); 280 Set_Local_Raise_Statements (Handler, No_Elist); 281 return Handler; 282 end Make_Implicit_Exception_Handler; 283 284 -------------------------------- 285 -- Make_Implicit_If_Statement -- 286 -------------------------------- 287 288 function Make_Implicit_If_Statement 289 (Node : Node_Id; 290 Condition : Node_Id; 291 Then_Statements : List_Id; 292 Elsif_Parts : List_Id := No_List; 293 Else_Statements : List_Id := No_List) return Node_Id 294 is 295 begin 296 Check_Restriction (No_Implicit_Conditionals, Node); 297 298 return Make_If_Statement (Sloc (Node), 299 Condition, 300 Then_Statements, 301 Elsif_Parts, 302 Else_Statements); 303 end Make_Implicit_If_Statement; 304 305 ------------------------------------- 306 -- Make_Implicit_Label_Declaration -- 307 ------------------------------------- 308 309 function Make_Implicit_Label_Declaration 310 (Loc : Source_Ptr; 311 Defining_Identifier : Node_Id; 312 Label_Construct : Node_Id) return Node_Id 313 is 314 N : constant Node_Id := 315 Make_Implicit_Label_Declaration (Loc, Defining_Identifier); 316 begin 317 Set_Label_Construct (N, Label_Construct); 318 return N; 319 end Make_Implicit_Label_Declaration; 320 321 ---------------------------------- 322 -- Make_Implicit_Loop_Statement -- 323 ---------------------------------- 324 325 function Make_Implicit_Loop_Statement 326 (Node : Node_Id; 327 Statements : List_Id; 328 Identifier : Node_Id := Empty; 329 Iteration_Scheme : Node_Id := Empty; 330 Has_Created_Identifier : Boolean := False; 331 End_Label : Node_Id := Empty) return Node_Id 332 is 333 begin 334 Check_Restriction (No_Implicit_Loops, Node); 335 336 if Present (Iteration_Scheme) 337 and then Present (Condition (Iteration_Scheme)) 338 then 339 Check_Restriction (No_Implicit_Conditionals, Node); 340 end if; 341 342 return Make_Loop_Statement (Sloc (Node), 343 Identifier => Identifier, 344 Iteration_Scheme => Iteration_Scheme, 345 Statements => Statements, 346 Has_Created_Identifier => Has_Created_Identifier, 347 End_Label => End_Label); 348 end Make_Implicit_Loop_Statement; 349 350 -------------------------- 351 -- Make_Integer_Literal -- 352 --------------------------- 353 354 function Make_Integer_Literal 355 (Loc : Source_Ptr; 356 Intval : Int) return Node_Id 357 is 358 begin 359 return Make_Integer_Literal (Loc, UI_From_Int (Intval)); 360 end Make_Integer_Literal; 361 362 -------------------------------- 363 -- Make_Linker_Section_Pragma -- 364 -------------------------------- 365 366 function Make_Linker_Section_Pragma 367 (Ent : Entity_Id; 368 Loc : Source_Ptr; 369 Sec : String) return Node_Id 370 is 371 LS : Node_Id; 372 373 begin 374 LS := 375 Make_Pragma 376 (Loc, 377 Name_Linker_Section, 378 New_List 379 (Make_Pragma_Argument_Association 380 (Sloc => Loc, 381 Expression => New_Occurrence_Of (Ent, Loc)), 382 Make_Pragma_Argument_Association 383 (Sloc => Loc, 384 Expression => 385 Make_String_Literal 386 (Sloc => Loc, 387 Strval => Sec)))); 388 389 Set_Has_Gigi_Rep_Item (Ent); 390 return LS; 391 end Make_Linker_Section_Pragma; 392 393 ----------------- 394 -- Make_Pragma -- 395 ----------------- 396 397 function Make_Pragma 398 (Sloc : Source_Ptr; 399 Chars : Name_Id; 400 Pragma_Argument_Associations : List_Id := No_List) return Node_Id 401 is 402 begin 403 return 404 Make_Pragma (Sloc, 405 Pragma_Argument_Associations => Pragma_Argument_Associations, 406 Pragma_Identifier => Make_Identifier (Sloc, Chars)); 407 end Make_Pragma; 408 409 --------------------------------- 410 -- Make_Raise_Constraint_Error -- 411 --------------------------------- 412 413 function Make_Raise_Constraint_Error 414 (Sloc : Source_Ptr; 415 Condition : Node_Id := Empty; 416 Reason : RT_Exception_Code) return Node_Id 417 is 418 begin 419 pragma Assert (Reason in RT_CE_Exceptions); 420 return 421 Make_Raise_Constraint_Error (Sloc, 422 Condition => Condition, 423 Reason => 424 UI_From_Int (RT_Exception_Code'Pos (Reason))); 425 end Make_Raise_Constraint_Error; 426 427 ------------------------------ 428 -- Make_Raise_Program_Error -- 429 ------------------------------ 430 431 function Make_Raise_Program_Error 432 (Sloc : Source_Ptr; 433 Condition : Node_Id := Empty; 434 Reason : RT_Exception_Code) return Node_Id 435 is 436 begin 437 pragma Assert (Reason in RT_PE_Exceptions); 438 return 439 Make_Raise_Program_Error (Sloc, 440 Condition => Condition, 441 Reason => 442 UI_From_Int (RT_Exception_Code'Pos (Reason))); 443 end Make_Raise_Program_Error; 444 445 ------------------------------ 446 -- Make_Raise_Storage_Error -- 447 ------------------------------ 448 449 function Make_Raise_Storage_Error 450 (Sloc : Source_Ptr; 451 Condition : Node_Id := Empty; 452 Reason : RT_Exception_Code) return Node_Id 453 is 454 begin 455 pragma Assert (Reason in RT_SE_Exceptions); 456 return 457 Make_Raise_Storage_Error (Sloc, 458 Condition => Condition, 459 Reason => 460 UI_From_Int (RT_Exception_Code'Pos (Reason))); 461 end Make_Raise_Storage_Error; 462 463 ------------------------- 464 -- Make_String_Literal -- 465 ------------------------- 466 467 function Make_String_Literal 468 (Sloc : Source_Ptr; 469 Strval : String) return Node_Id 470 is 471 begin 472 Start_String; 473 Store_String_Chars (Strval); 474 return 475 Make_String_Literal (Sloc, 476 Strval => End_String); 477 end Make_String_Literal; 478 479 -------------------- 480 -- Make_Temporary -- 481 -------------------- 482 483 function Make_Temporary 484 (Loc : Source_Ptr; 485 Id : Character; 486 Related_Node : Node_Id := Empty) return Entity_Id 487 is 488 Temp : constant Entity_Id := 489 Make_Defining_Identifier (Loc, 490 Chars => New_Internal_Name (Id)); 491 begin 492 Set_Related_Expression (Temp, Related_Node); 493 return Temp; 494 end Make_Temporary; 495 496 --------------------------- 497 -- Make_Unsuppress_Block -- 498 --------------------------- 499 500 -- Generates the following expansion: 501 502 -- declare 503 -- pragma Suppress (<check>); 504 -- begin 505 -- <stmts> 506 -- end; 507 508 function Make_Unsuppress_Block 509 (Loc : Source_Ptr; 510 Check : Name_Id; 511 Stmts : List_Id) return Node_Id 512 is 513 begin 514 return 515 Make_Block_Statement (Loc, 516 Declarations => New_List ( 517 Make_Pragma (Loc, 518 Chars => Name_Suppress, 519 Pragma_Argument_Associations => New_List ( 520 Make_Pragma_Argument_Association (Loc, 521 Expression => Make_Identifier (Loc, Check))))), 522 523 Handled_Statement_Sequence => 524 Make_Handled_Sequence_Of_Statements (Loc, 525 Statements => Stmts)); 526 end Make_Unsuppress_Block; 527 528 -------------------------- 529 -- New_Constraint_Error -- 530 -------------------------- 531 532 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is 533 Ident_Node : Node_Id; 534 Raise_Node : Node_Id; 535 536 begin 537 Ident_Node := New_Node (N_Identifier, Loc); 538 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); 539 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); 540 Raise_Node := New_Node (N_Raise_Statement, Loc); 541 Set_Name (Raise_Node, Ident_Node); 542 return Raise_Node; 543 end New_Constraint_Error; 544 545 ----------------------- 546 -- New_External_Name -- 547 ----------------------- 548 549 function New_External_Name 550 (Related_Id : Name_Id; 551 Suffix : Character := ' '; 552 Suffix_Index : Int := 0; 553 Prefix : Character := ' ') return Name_Id 554 is 555 begin 556 Get_Name_String (Related_Id); 557 558 if Prefix /= ' ' then 559 pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_'); 560 561 for J in reverse 1 .. Name_Len loop 562 Name_Buffer (J + 1) := Name_Buffer (J); 563 end loop; 564 565 Name_Len := Name_Len + 1; 566 Name_Buffer (1) := Prefix; 567 end if; 568 569 if Suffix /= ' ' then 570 pragma Assert (Is_OK_Internal_Letter (Suffix)); 571 Add_Char_To_Name_Buffer (Suffix); 572 end if; 573 574 if Suffix_Index /= 0 then 575 if Suffix_Index < 0 then 576 Add_Unique_Serial_Number; 577 else 578 Add_Nat_To_Name_Buffer (Suffix_Index); 579 end if; 580 end if; 581 582 return Name_Find; 583 end New_External_Name; 584 585 function New_External_Name 586 (Related_Id : Name_Id; 587 Suffix : String; 588 Suffix_Index : Int := 0; 589 Prefix : Character := ' ') return Name_Id 590 is 591 begin 592 Get_Name_String (Related_Id); 593 594 if Prefix /= ' ' then 595 pragma Assert (Is_OK_Internal_Letter (Prefix)); 596 597 for J in reverse 1 .. Name_Len loop 598 Name_Buffer (J + 1) := Name_Buffer (J); 599 end loop; 600 601 Name_Len := Name_Len + 1; 602 Name_Buffer (1) := Prefix; 603 end if; 604 605 if Suffix /= "" then 606 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; 607 Name_Len := Name_Len + Suffix'Length; 608 end if; 609 610 if Suffix_Index /= 0 then 611 if Suffix_Index < 0 then 612 Add_Unique_Serial_Number; 613 else 614 Add_Nat_To_Name_Buffer (Suffix_Index); 615 end if; 616 end if; 617 618 return Name_Find; 619 end New_External_Name; 620 621 function New_External_Name 622 (Suffix : Character; 623 Suffix_Index : Nat) return Name_Id 624 is 625 begin 626 Name_Buffer (1) := Suffix; 627 Name_Len := 1; 628 Add_Nat_To_Name_Buffer (Suffix_Index); 629 return Name_Find; 630 end New_External_Name; 631 632 ----------------------- 633 -- New_Internal_Name -- 634 ----------------------- 635 636 function New_Internal_Name (Id_Char : Character) return Name_Id is 637 begin 638 pragma Assert (Is_OK_Internal_Letter (Id_Char)); 639 Name_Buffer (1) := Id_Char; 640 Name_Len := 1; 641 Add_Unique_Serial_Number; 642 return Name_Enter; 643 end New_Internal_Name; 644 645 ----------------------- 646 -- New_Occurrence_Of -- 647 ----------------------- 648 649 function New_Occurrence_Of 650 (Def_Id : Entity_Id; 651 Loc : Source_Ptr) return Node_Id 652 is 653 Occurrence : Node_Id; 654 655 begin 656 Occurrence := New_Node (N_Identifier, Loc); 657 Set_Chars (Occurrence, Chars (Def_Id)); 658 Set_Entity (Occurrence, Def_Id); 659 660 if Is_Type (Def_Id) then 661 Set_Etype (Occurrence, Def_Id); 662 else 663 Set_Etype (Occurrence, Etype (Def_Id)); 664 end if; 665 666 return Occurrence; 667 end New_Occurrence_Of; 668 669 ----------------- 670 -- New_Op_Node -- 671 ----------------- 672 673 function New_Op_Node 674 (New_Node_Kind : Node_Kind; 675 New_Sloc : Source_Ptr) return Node_Id 676 is 677 type Name_Of_Type is array (N_Op) of Name_Id; 678 Name_Of : constant Name_Of_Type := Name_Of_Type'( 679 N_Op_And => Name_Op_And, 680 N_Op_Or => Name_Op_Or, 681 N_Op_Xor => Name_Op_Xor, 682 N_Op_Eq => Name_Op_Eq, 683 N_Op_Ne => Name_Op_Ne, 684 N_Op_Lt => Name_Op_Lt, 685 N_Op_Le => Name_Op_Le, 686 N_Op_Gt => Name_Op_Gt, 687 N_Op_Ge => Name_Op_Ge, 688 N_Op_Add => Name_Op_Add, 689 N_Op_Subtract => Name_Op_Subtract, 690 N_Op_Concat => Name_Op_Concat, 691 N_Op_Multiply => Name_Op_Multiply, 692 N_Op_Divide => Name_Op_Divide, 693 N_Op_Mod => Name_Op_Mod, 694 N_Op_Rem => Name_Op_Rem, 695 N_Op_Expon => Name_Op_Expon, 696 N_Op_Plus => Name_Op_Add, 697 N_Op_Minus => Name_Op_Subtract, 698 N_Op_Abs => Name_Op_Abs, 699 N_Op_Not => Name_Op_Not, 700 701 -- We don't really need these shift operators, since they never 702 -- appear as operators in the source, but the path of least 703 -- resistance is to put them in (the aggregate must be complete). 704 705 N_Op_Rotate_Left => Name_Rotate_Left, 706 N_Op_Rotate_Right => Name_Rotate_Right, 707 N_Op_Shift_Left => Name_Shift_Left, 708 N_Op_Shift_Right => Name_Shift_Right, 709 N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); 710 711 Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc); 712 713 begin 714 if New_Node_Kind in Name_Of'Range then 715 Set_Chars (Nod, Name_Of (New_Node_Kind)); 716 end if; 717 718 return Nod; 719 end New_Op_Node; 720 721 ---------------------- 722 -- New_Reference_To -- 723 ---------------------- 724 725 function New_Reference_To 726 (Def_Id : Entity_Id; 727 Loc : Source_Ptr) return Node_Id 728 is 729 pragma Assert (Nkind (Def_Id) in N_Entity); 730 Occurrence : Node_Id; 731 begin 732 Occurrence := New_Node (N_Identifier, Loc); 733 Set_Chars (Occurrence, Chars (Def_Id)); 734 Set_Entity (Occurrence, Def_Id); 735 return Occurrence; 736 end New_Reference_To; 737 738 ----------------------- 739 -- New_Suffixed_Name -- 740 ----------------------- 741 742 function New_Suffixed_Name 743 (Related_Id : Name_Id; 744 Suffix : String) return Name_Id 745 is 746 begin 747 Get_Name_String (Related_Id); 748 Add_Char_To_Name_Buffer ('_'); 749 Add_Str_To_Name_Buffer (Suffix); 750 return Name_Find; 751 end New_Suffixed_Name; 752 753 ------------------- 754 -- OK_Convert_To -- 755 ------------------- 756 757 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is 758 Result : Node_Id; 759 begin 760 Result := 761 Make_Type_Conversion (Sloc (Expr), 762 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)), 763 Expression => Relocate_Node (Expr)); 764 Set_Conversion_OK (Result, True); 765 Set_Etype (Result, Typ); 766 return Result; 767 end OK_Convert_To; 768 769 -------------------------- 770 -- Unchecked_Convert_To -- 771 -------------------------- 772 773 function Unchecked_Convert_To 774 (Typ : Entity_Id; 775 Expr : Node_Id) return Node_Id 776 is 777 Loc : constant Source_Ptr := Sloc (Expr); 778 Result : Node_Id; 779 Expr_Parent : Node_Id; 780 781 begin 782 -- If the expression is already of the correct type, then nothing 783 -- to do, except for relocating the node in case this is required. 784 785 if Present (Etype (Expr)) 786 and then (Base_Type (Etype (Expr)) = Typ 787 or else Etype (Expr) = Typ) 788 then 789 return Relocate_Node (Expr); 790 791 -- Cases where the inner expression is itself an unchecked conversion 792 -- to the same type, and we can thus eliminate the outer conversion. 793 794 elsif Nkind (Expr) = N_Unchecked_Type_Conversion 795 and then Entity (Subtype_Mark (Expr)) = Typ 796 then 797 Result := Relocate_Node (Expr); 798 799 elsif Nkind (Expr) = N_Null 800 and then Is_Access_Type (Typ) 801 then 802 -- No need for a conversion 803 804 Result := Relocate_Node (Expr); 805 806 -- All other cases 807 808 else 809 -- Capture the parent of the expression before relocating it and 810 -- creating the conversion, so the conversion's parent can be set 811 -- to the original parent below. 812 813 Expr_Parent := Parent (Expr); 814 815 Result := 816 Make_Unchecked_Type_Conversion (Loc, 817 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 818 Expression => Relocate_Node (Expr)); 819 820 Set_Parent (Result, Expr_Parent); 821 end if; 822 823 Set_Etype (Result, Typ); 824 return Result; 825 end Unchecked_Convert_To; 826 827end Tbuild; 828