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