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-2007, 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 Sinfo;    use Sinfo;
  36 with Snames;   use Snames;
  37 with Stand;    use Stand;
  38 with Stringt;  use Stringt;
  39 with Uintp;    use Uintp;
  40
  41 package 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    -- Discard_List --
 134    ------------------
 135
 136    procedure Discard_List (L : List_Id) is
 137       pragma Warnings (Off, L);
 138    begin
 139       null;
 140    end Discard_List;
 141
 142    ------------------
 143    -- Discard_Node --
 144    ------------------
 145
 146    procedure Discard_Node (N : Node_Or_Entity_Id) is
 147       pragma Warnings (Off, N);
 148    begin
 149       null;
 150    end Discard_Node;
 151
 152    -------------------------------------------
 153    -- Make_Byte_Aligned_Attribute_Reference --
 154    -------------------------------------------
 155
 156    function Make_Byte_Aligned_Attribute_Reference
 157      (Sloc           : Source_Ptr;
 158       Prefix         : Node_Id;
 159       Attribute_Name : Name_Id)
 160       return           Node_Id
 161    is
 162       N : constant Node_Id :=
 163             Make_Attribute_Reference (Sloc,
 164               Prefix        => Prefix,
 165               Attribute_Name => Attribute_Name);
 166
 167    begin
 168       pragma Assert (Attribute_Name = Name_Address
 169                        or else
 170                      Attribute_Name = Name_Unrestricted_Access);
 171       Set_Must_Be_Byte_Aligned (N, True);
 172       return N;
 173    end Make_Byte_Aligned_Attribute_Reference;
 174
 175    --------------------
 176    -- Make_DT_Access --
 177    --------------------
 178
 179    function Make_DT_Access
 180      (Loc : Source_Ptr;
 181       Rec : Node_Id;
 182       Typ : Entity_Id) return Node_Id
 183    is
 184       Full_Type : Entity_Id := Typ;
 185
 186    begin
 187       if Is_Private_Type (Typ) then
 188          Full_Type := Underlying_Type (Typ);
 189       end if;
 190
 191       return
 192         Unchecked_Convert_To (
 193           New_Occurrence_Of
 194             (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
 195           Make_Selected_Component (Loc,
 196             Prefix => New_Copy (Rec),
 197             Selector_Name =>
 198               New_Reference_To (First_Tag_Component (Full_Type), Loc)));
 199    end Make_DT_Access;
 200
 201    -------------------------------------
 202    -- Make_Implicit_Exception_Handler --
 203    -------------------------------------
 204
 205    function Make_Implicit_Exception_Handler
 206      (Sloc              : Source_Ptr;
 207       Choice_Parameter  : Node_Id := Empty;
 208       Exception_Choices : List_Id;
 209       Statements        : List_Id) return Node_Id
 210    is
 211       Handler : Node_Id;
 212       Loc     : Source_Ptr;
 213
 214    begin
 215       --  Set the source location only when debugging the expanded code
 216
 217       --  When debugging the source code directly, we do not want the compiler
 218       --  to associate this implicit exception handler with any specific source
 219       --  line, because it can potentially confuse the debugger. The most
 220       --  damaging situation would arise when the debugger tries to insert a
 221       --  breakpoint at a certain line. If the code of the associated implicit
 222       --  exception handler is generated before the code of that line, then the
 223       --  debugger will end up inserting the breakpoint inside the exception
 224       --  handler, rather than the code the user intended to break on. As a
 225       --  result, it is likely that the program will not hit the breakpoint
 226       --  as expected.
 227
 228       if Debug_Generated_Code then
 229          Loc := Sloc;
 230       else
 231          Loc := No_Location;
 232       end if;
 233
 234       Handler :=
 235         Make_Exception_Handler
 236           (Loc, Choice_Parameter, Exception_Choices, Statements);
 237       Set_Local_Raise_Statements (Handler, No_Elist);
 238       return Handler;
 239    end Make_Implicit_Exception_Handler;
 240
 241    --------------------------------
 242    -- Make_Implicit_If_Statement --
 243    --------------------------------
 244
 245    function Make_Implicit_If_Statement
 246      (Node            : Node_Id;
 247       Condition       : Node_Id;
 248       Then_Statements : List_Id;
 249       Elsif_Parts     : List_Id := No_List;
 250       Else_Statements : List_Id := No_List) return Node_Id
 251    is
 252    begin
 253       Check_Restriction (No_Implicit_Conditionals, Node);
 254
 255       return Make_If_Statement (Sloc (Node),
 256         Condition,
 257         Then_Statements,
 258         Elsif_Parts,
 259         Else_Statements);
 260    end Make_Implicit_If_Statement;
 261
 262    -------------------------------------
 263    -- Make_Implicit_Label_Declaration --
 264    -------------------------------------
 265
 266    function Make_Implicit_Label_Declaration
 267      (Loc                 : Source_Ptr;
 268       Defining_Identifier : Node_Id;
 269       Label_Construct     : Node_Id) return Node_Id
 270    is
 271       N : constant Node_Id :=
 272             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
 273    begin
 274       Set_Label_Construct (N, Label_Construct);
 275       return N;
 276    end Make_Implicit_Label_Declaration;
 277
 278    ----------------------------------
 279    -- Make_Implicit_Loop_Statement --
 280    ----------------------------------
 281
 282    function Make_Implicit_Loop_Statement
 283      (Node                   : Node_Id;
 284       Statements             : List_Id;
 285       Identifier             : Node_Id := Empty;
 286       Iteration_Scheme       : Node_Id := Empty;
 287       Has_Created_Identifier : Boolean := False;
 288       End_Label              : Node_Id := Empty) return Node_Id
 289    is
 290    begin
 291       Check_Restriction (No_Implicit_Loops, Node);
 292
 293       if Present (Iteration_Scheme)
 294         and then Present (Condition (Iteration_Scheme))
 295       then
 296          Check_Restriction (No_Implicit_Conditionals, Node);
 297       end if;
 298
 299       return Make_Loop_Statement (Sloc (Node),
 300         Identifier             => Identifier,
 301         Iteration_Scheme       => Iteration_Scheme,
 302         Statements             => Statements,
 303         Has_Created_Identifier => Has_Created_Identifier,
 304         End_Label              => End_Label);
 305    end Make_Implicit_Loop_Statement;
 306
 307    --------------------------
 308    -- Make_Integer_Literal --
 309    ---------------------------
 310
 311    function Make_Integer_Literal
 312      (Loc    : Source_Ptr;
 313       Intval : Int) return Node_Id
 314    is
 315    begin
 316       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
 317    end Make_Integer_Literal;
 318
 319    --------------------------------
 320    -- Make_Linker_Section_Pragma --
 321    --------------------------------
 322
 323    function Make_Linker_Section_Pragma
 324      (Ent : Entity_Id;
 325       Loc : Source_Ptr;
 326       Sec : String) return Node_Id
 327    is
 328       LS : Node_Id;
 329
 330    begin
 331       LS :=
 332         Make_Pragma
 333           (Loc,
 334            Name_Linker_Section,
 335            New_List
 336              (Make_Pragma_Argument_Association
 337                 (Sloc => Loc,
 338                  Expression => New_Occurrence_Of (Ent, Loc)),
 339               Make_Pragma_Argument_Association
 340                 (Sloc => Loc,
 341                  Expression =>
 342                    Make_String_Literal
 343                      (Sloc => Loc,
 344                       Strval => Sec))));
 345
 346       Set_Has_Gigi_Rep_Item (Ent);
 347       return LS;
 348    end Make_Linker_Section_Pragma;
 349
 350    -----------------
 351    -- Make_Pragma --
 352    -----------------
 353
 354    function Make_Pragma
 355      (Sloc                         : Source_Ptr;
 356       Chars                        : Name_Id;
 357       Pragma_Argument_Associations : List_Id := No_List;
 358       Debug_Statement              : Node_Id := Empty) return Node_Id
 359    is
 360    begin
 361       return
 362         Make_Pragma (Sloc,
 363           Chars                        => Chars,
 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_Unsuppress_Block --
 441    ---------------------------
 442
 443    --  Generates the following expansion:
 444
 445    --    declare
 446    --       pragma Suppress (<check>);
 447    --    begin
 448    --       <stmts>
 449    --    end;
 450
 451    function Make_Unsuppress_Block
 452      (Loc   : Source_Ptr;
 453       Check : Name_Id;
 454       Stmts : List_Id) return Node_Id
 455    is
 456    begin
 457       return
 458         Make_Block_Statement (Loc,
 459           Declarations => New_List (
 460             Make_Pragma (Loc,
 461               Chars => Name_Suppress,
 462               Pragma_Argument_Associations => New_List (
 463                 Make_Pragma_Argument_Association (Loc,
 464                   Expression => Make_Identifier (Loc, Check))))),
 465
 466           Handled_Statement_Sequence =>
 467             Make_Handled_Sequence_Of_Statements (Loc,
 468               Statements => Stmts));
 469    end Make_Unsuppress_Block;
 470
 471    --------------------------
 472    -- New_Constraint_Error --
 473    --------------------------
 474
 475    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
 476       Ident_Node : Node_Id;
 477       Raise_Node : Node_Id;
 478
 479    begin
 480       Ident_Node := New_Node (N_Identifier, Loc);
 481       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
 482       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
 483       Raise_Node := New_Node (N_Raise_Statement, Loc);
 484       Set_Name (Raise_Node, Ident_Node);
 485       return Raise_Node;
 486    end New_Constraint_Error;
 487
 488    -----------------------
 489    -- New_External_Name --
 490    -----------------------
 491
 492    function New_External_Name
 493      (Related_Id   : Name_Id;
 494       Suffix       : Character := ' ';
 495       Suffix_Index : Int       := 0;
 496       Prefix       : Character := ' ') return Name_Id
 497    is
 498    begin
 499       Get_Name_String (Related_Id);
 500
 501       if Prefix /= ' ' then
 502          pragma Assert (Is_OK_Internal_Letter (Prefix));
 503
 504          for J in reverse 1 .. Name_Len loop
 505             Name_Buffer (J + 1) := Name_Buffer (J);
 506          end loop;
 507
 508          Name_Len := Name_Len + 1;
 509          Name_Buffer (1) := Prefix;
 510       end if;
 511
 512       if Suffix /= ' ' then
 513          pragma Assert (Is_OK_Internal_Letter (Suffix));
 514          Name_Len := Name_Len + 1;
 515          Name_Buffer (Name_Len) := Suffix;
 516       end if;
 517
 518       if Suffix_Index /= 0 then
 519          if Suffix_Index < 0 then
 520             Add_Unique_Serial_Number;
 521          else
 522             Add_Nat_To_Name_Buffer (Suffix_Index);
 523          end if;
 524       end if;
 525
 526       return Name_Find;
 527    end New_External_Name;
 528
 529    function New_External_Name
 530      (Related_Id   : Name_Id;
 531       Suffix       : String;
 532       Suffix_Index : Int       := 0;
 533       Prefix       : Character := ' ') return Name_Id
 534    is
 535    begin
 536       Get_Name_String (Related_Id);
 537
 538       if Prefix /= ' ' then
 539          pragma Assert (Is_OK_Internal_Letter (Prefix));
 540
 541          for J in reverse 1 .. Name_Len loop
 542             Name_Buffer (J + 1) := Name_Buffer (J);
 543          end loop;
 544
 545          Name_Len := Name_Len + 1;
 546          Name_Buffer (1) := Prefix;
 547       end if;
 548
 549       if Suffix /= "" then
 550          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 551          Name_Len := Name_Len + Suffix'Length;
 552       end if;
 553
 554       if Suffix_Index /= 0 then
 555          if Suffix_Index < 0 then
 556             Add_Unique_Serial_Number;
 557          else
 558             Add_Nat_To_Name_Buffer (Suffix_Index);
 559          end if;
 560       end if;
 561
 562       return Name_Find;
 563    end New_External_Name;
 564
 565    function New_External_Name
 566      (Suffix       : Character;
 567       Suffix_Index : Nat) return Name_Id
 568    is
 569    begin
 570       Name_Buffer (1) := Suffix;
 571       Name_Len := 1;
 572       Add_Nat_To_Name_Buffer (Suffix_Index);
 573       return Name_Find;
 574    end New_External_Name;
 575
 576    -----------------------
 577    -- New_Internal_Name --
 578    -----------------------
 579
 580    function New_Internal_Name (Id_Char : Character) return Name_Id is
 581    begin
 582       pragma Assert (Is_OK_Internal_Letter (Id_Char));
 583       Name_Buffer (1) := Id_Char;
 584       Name_Len := 1;
 585       Add_Unique_Serial_Number;
 586       return Name_Enter;
 587    end New_Internal_Name;
 588
 589    -----------------------
 590    -- New_Occurrence_Of --
 591    -----------------------
 592
 593    function New_Occurrence_Of
 594      (Def_Id : Entity_Id;
 595       Loc    : Source_Ptr) return Node_Id
 596    is
 597       Occurrence : Node_Id;
 598
 599    begin
 600       Occurrence := New_Node (N_Identifier, Loc);
 601       Set_Chars (Occurrence, Chars (Def_Id));
 602       Set_Entity (Occurrence, Def_Id);
 603
 604       if Is_Type (Def_Id) then
 605          Set_Etype (Occurrence, Def_Id);
 606       else
 607          Set_Etype (Occurrence, Etype (Def_Id));
 608       end if;
 609
 610       return Occurrence;
 611    end New_Occurrence_Of;
 612
 613    ----------------------
 614    -- New_Reference_To --
 615    ----------------------
 616
 617    function New_Reference_To
 618      (Def_Id : Entity_Id;
 619       Loc    : Source_Ptr) return Node_Id
 620    is
 621       Occurrence : Node_Id;
 622
 623    begin
 624       Occurrence := New_Node (N_Identifier, Loc);
 625       Set_Chars (Occurrence, Chars (Def_Id));
 626       Set_Entity (Occurrence, Def_Id);
 627       return Occurrence;
 628    end New_Reference_To;
 629
 630    -----------------------
 631    -- New_Suffixed_Name --
 632    -----------------------
 633
 634    function New_Suffixed_Name
 635      (Related_Id : Name_Id;
 636       Suffix     : String) return Name_Id
 637    is
 638    begin
 639       Get_Name_String (Related_Id);
 640       Name_Len := Name_Len + 1;
 641       Name_Buffer (Name_Len) := '_';
 642       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 643       Name_Len := Name_Len + Suffix'Length;
 644       return Name_Find;
 645    end New_Suffixed_Name;
 646
 647    -------------------
 648    -- OK_Convert_To --
 649    -------------------
 650
 651    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 652       Result : Node_Id;
 653    begin
 654       Result :=
 655         Make_Type_Conversion (Sloc (Expr),
 656           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 657           Expression   => Relocate_Node (Expr));
 658       Set_Conversion_OK (Result, True);
 659       Set_Etype (Result, Typ);
 660       return Result;
 661    end OK_Convert_To;
 662
 663    --------------------------
 664    -- Unchecked_Convert_To --
 665    --------------------------
 666
 667    function Unchecked_Convert_To
 668      (Typ  : Entity_Id;
 669       Expr : Node_Id) return Node_Id
 670    is
 671       Loc    : constant Source_Ptr := Sloc (Expr);
 672       Result : Node_Id;
 673
 674    begin
 675       --  If the expression is already of the correct type, then nothing
 676       --  to do, except for relocating the node in case this is required.
 677
 678       if Present (Etype (Expr))
 679         and then (Base_Type (Etype (Expr)) = Typ
 680                    or else Etype (Expr) = Typ)
 681       then
 682          return Relocate_Node (Expr);
 683
 684       --  Cases where the inner expression is itself an unchecked conversion
 685       --  to the same type, and we can thus eliminate the outer conversion.
 686
 687       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
 688         and then Entity (Subtype_Mark (Expr)) = Typ
 689       then
 690          Result := Relocate_Node (Expr);
 691
 692       elsif Nkind (Expr) = N_Null
 693         and then Is_Access_Type (Typ)
 694       then
 695          --  No need for a conversion
 696
 697          Result := Relocate_Node (Expr);
 698
 699       --  All other cases
 700
 701       else
 702          Result :=
 703            Make_Unchecked_Type_Conversion (Loc,
 704              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 705              Expression   => Relocate_Node (Expr));
 706       end if;
 707
 708       Set_Etype (Result, Typ);
 709       return Result;
 710    end Unchecked_Convert_To;
 711
 712 end Tbuild;