gcc/ada/tbuild.adb

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