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-2006, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Lib;      use Lib;
  31 with Namet;    use Namet;
  32 with Nlists;   use Nlists;
  33 with Nmake;    use Nmake;
  34 with Restrict; use Restrict;
  35 with Rident;   use Rident;
  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 : constant Node_Id :=
 213                   Make_Exception_Handler
 214                     (Sloc, Choice_Parameter, Exception_Choices, Statements);
 215    begin
 216       Set_Local_Raise_Statements (Handler, No_Elist);
 217       return Handler;
 218    end Make_Implicit_Exception_Handler;
 219
 220    --------------------------------
 221    -- Make_Implicit_If_Statement --
 222    --------------------------------
 223
 224    function Make_Implicit_If_Statement
 225      (Node            : Node_Id;
 226       Condition       : Node_Id;
 227       Then_Statements : List_Id;
 228       Elsif_Parts     : List_Id := No_List;
 229       Else_Statements : List_Id := No_List) return Node_Id
 230    is
 231    begin
 232       Check_Restriction (No_Implicit_Conditionals, Node);
 233
 234       return Make_If_Statement (Sloc (Node),
 235         Condition,
 236         Then_Statements,
 237         Elsif_Parts,
 238         Else_Statements);
 239    end Make_Implicit_If_Statement;
 240
 241    -------------------------------------
 242    -- Make_Implicit_Label_Declaration --
 243    -------------------------------------
 244
 245    function Make_Implicit_Label_Declaration
 246      (Loc                 : Source_Ptr;
 247       Defining_Identifier : Node_Id;
 248       Label_Construct     : Node_Id) return Node_Id
 249    is
 250       N : constant Node_Id :=
 251             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
 252    begin
 253       Set_Label_Construct (N, Label_Construct);
 254       return N;
 255    end Make_Implicit_Label_Declaration;
 256
 257    ----------------------------------
 258    -- Make_Implicit_Loop_Statement --
 259    ----------------------------------
 260
 261    function Make_Implicit_Loop_Statement
 262      (Node                   : Node_Id;
 263       Statements             : List_Id;
 264       Identifier             : Node_Id := Empty;
 265       Iteration_Scheme       : Node_Id := Empty;
 266       Has_Created_Identifier : Boolean := False;
 267       End_Label              : Node_Id := Empty) return Node_Id
 268    is
 269    begin
 270       Check_Restriction (No_Implicit_Loops, Node);
 271
 272       if Present (Iteration_Scheme)
 273         and then Present (Condition (Iteration_Scheme))
 274       then
 275          Check_Restriction (No_Implicit_Conditionals, Node);
 276       end if;
 277
 278       return Make_Loop_Statement (Sloc (Node),
 279         Identifier             => Identifier,
 280         Iteration_Scheme       => Iteration_Scheme,
 281         Statements             => Statements,
 282         Has_Created_Identifier => Has_Created_Identifier,
 283         End_Label              => End_Label);
 284    end Make_Implicit_Loop_Statement;
 285
 286    --------------------------
 287    -- Make_Integer_Literal --
 288    ---------------------------
 289
 290    function Make_Integer_Literal
 291      (Loc    : Source_Ptr;
 292       Intval : Int) return Node_Id
 293    is
 294    begin
 295       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
 296    end Make_Integer_Literal;
 297
 298    --------------------------------
 299    -- Make_Linker_Section_Pragma --
 300    --------------------------------
 301
 302    function Make_Linker_Section_Pragma
 303      (Ent : Entity_Id;
 304       Loc : Source_Ptr;
 305       Sec : String) return Node_Id
 306    is
 307       LS : Node_Id;
 308
 309    begin
 310       LS :=
 311         Make_Pragma
 312           (Loc,
 313            Name_Linker_Section,
 314            New_List
 315              (Make_Pragma_Argument_Association
 316                 (Sloc => Loc,
 317                  Expression => New_Occurrence_Of (Ent, Loc)),
 318               Make_Pragma_Argument_Association
 319                 (Sloc => Loc,
 320                  Expression =>
 321                    Make_String_Literal
 322                      (Sloc => Loc,
 323                       Strval => Sec))));
 324
 325       Set_Has_Gigi_Rep_Item (Ent);
 326       return LS;
 327    end Make_Linker_Section_Pragma;
 328
 329    ---------------------------------
 330    -- Make_Raise_Constraint_Error --
 331    ---------------------------------
 332
 333    function Make_Raise_Constraint_Error
 334      (Sloc      : Source_Ptr;
 335       Condition : Node_Id := Empty;
 336       Reason    : RT_Exception_Code) return Node_Id
 337    is
 338    begin
 339       pragma Assert (Reason in RT_CE_Exceptions);
 340       return
 341         Make_Raise_Constraint_Error (Sloc,
 342           Condition => Condition,
 343           Reason =>
 344             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 345    end Make_Raise_Constraint_Error;
 346
 347    ------------------------------
 348    -- Make_Raise_Program_Error --
 349    ------------------------------
 350
 351    function Make_Raise_Program_Error
 352      (Sloc      : Source_Ptr;
 353       Condition : Node_Id := Empty;
 354       Reason    : RT_Exception_Code) return Node_Id
 355    is
 356    begin
 357       pragma Assert (Reason in RT_PE_Exceptions);
 358       return
 359         Make_Raise_Program_Error (Sloc,
 360           Condition => Condition,
 361           Reason =>
 362             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 363    end Make_Raise_Program_Error;
 364
 365    ------------------------------
 366    -- Make_Raise_Storage_Error --
 367    ------------------------------
 368
 369    function Make_Raise_Storage_Error
 370      (Sloc      : Source_Ptr;
 371       Condition : Node_Id := Empty;
 372       Reason    : RT_Exception_Code) return Node_Id
 373    is
 374    begin
 375       pragma Assert (Reason in RT_SE_Exceptions);
 376       return
 377         Make_Raise_Storage_Error (Sloc,
 378           Condition => Condition,
 379           Reason =>
 380             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 381    end Make_Raise_Storage_Error;
 382
 383    -------------------------
 384    -- Make_String_Literal --
 385    -------------------------
 386
 387    function Make_String_Literal
 388      (Sloc   : Source_Ptr;
 389       Strval : String) return Node_Id
 390    is
 391    begin
 392       Start_String;
 393       Store_String_Chars (Strval);
 394       return
 395         Make_String_Literal (Sloc,
 396           Strval => End_String);
 397    end Make_String_Literal;
 398
 399    ---------------------------
 400    -- Make_Unsuppress_Block --
 401    ---------------------------
 402
 403    --  Generates the following expansion:
 404
 405    --    declare
 406    --       pragma Suppress (<check>);
 407    --    begin
 408    --       <stmts>
 409    --    end;
 410
 411    function Make_Unsuppress_Block
 412      (Loc   : Source_Ptr;
 413       Check : Name_Id;
 414       Stmts : List_Id) return Node_Id
 415    is
 416    begin
 417       return
 418         Make_Block_Statement (Loc,
 419           Declarations => New_List (
 420             Make_Pragma (Loc,
 421               Chars => Name_Suppress,
 422               Pragma_Argument_Associations => New_List (
 423                 Make_Pragma_Argument_Association (Loc,
 424                   Expression => Make_Identifier (Loc, Check))))),
 425
 426           Handled_Statement_Sequence =>
 427             Make_Handled_Sequence_Of_Statements (Loc,
 428               Statements => Stmts));
 429    end Make_Unsuppress_Block;
 430
 431    --------------------------
 432    -- New_Constraint_Error --
 433    --------------------------
 434
 435    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
 436       Ident_Node : Node_Id;
 437       Raise_Node : Node_Id;
 438
 439    begin
 440       Ident_Node := New_Node (N_Identifier, Loc);
 441       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
 442       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
 443       Raise_Node := New_Node (N_Raise_Statement, Loc);
 444       Set_Name (Raise_Node, Ident_Node);
 445       return Raise_Node;
 446    end New_Constraint_Error;
 447
 448    -----------------------
 449    -- New_External_Name --
 450    -----------------------
 451
 452    function New_External_Name
 453      (Related_Id   : Name_Id;
 454       Suffix       : Character := ' ';
 455       Suffix_Index : Int       := 0;
 456       Prefix       : Character := ' ') return Name_Id
 457    is
 458    begin
 459       Get_Name_String (Related_Id);
 460
 461       if Prefix /= ' ' then
 462          pragma Assert (Is_OK_Internal_Letter (Prefix));
 463
 464          for J in reverse 1 .. Name_Len loop
 465             Name_Buffer (J + 1) := Name_Buffer (J);
 466          end loop;
 467
 468          Name_Len := Name_Len + 1;
 469          Name_Buffer (1) := Prefix;
 470       end if;
 471
 472       if Suffix /= ' ' then
 473          pragma Assert (Is_OK_Internal_Letter (Suffix));
 474          Name_Len := Name_Len + 1;
 475          Name_Buffer (Name_Len) := Suffix;
 476       end if;
 477
 478       if Suffix_Index /= 0 then
 479          if Suffix_Index < 0 then
 480             Add_Unique_Serial_Number;
 481          else
 482             Add_Nat_To_Name_Buffer (Suffix_Index);
 483          end if;
 484       end if;
 485
 486       return Name_Find;
 487    end New_External_Name;
 488
 489    function New_External_Name
 490      (Related_Id   : Name_Id;
 491       Suffix       : String;
 492       Suffix_Index : Int       := 0;
 493       Prefix       : Character := ' ') return Name_Id
 494    is
 495    begin
 496       Get_Name_String (Related_Id);
 497
 498       if Prefix /= ' ' then
 499          pragma Assert (Is_OK_Internal_Letter (Prefix));
 500
 501          for J in reverse 1 .. Name_Len loop
 502             Name_Buffer (J + 1) := Name_Buffer (J);
 503          end loop;
 504
 505          Name_Len := Name_Len + 1;
 506          Name_Buffer (1) := Prefix;
 507       end if;
 508
 509       if Suffix /= "" then
 510          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 511          Name_Len := Name_Len + Suffix'Length;
 512       end if;
 513
 514       if Suffix_Index /= 0 then
 515          if Suffix_Index < 0 then
 516             Add_Unique_Serial_Number;
 517          else
 518             Add_Nat_To_Name_Buffer (Suffix_Index);
 519          end if;
 520       end if;
 521
 522       return Name_Find;
 523    end New_External_Name;
 524
 525    function New_External_Name
 526      (Suffix       : Character;
 527       Suffix_Index : Nat) return Name_Id
 528    is
 529    begin
 530       Name_Buffer (1) := Suffix;
 531       Name_Len := 1;
 532       Add_Nat_To_Name_Buffer (Suffix_Index);
 533       return Name_Find;
 534    end New_External_Name;
 535
 536    -----------------------
 537    -- New_Internal_Name --
 538    -----------------------
 539
 540    function New_Internal_Name (Id_Char : Character) return Name_Id is
 541    begin
 542       pragma Assert (Is_OK_Internal_Letter (Id_Char));
 543       Name_Buffer (1) := Id_Char;
 544       Name_Len := 1;
 545       Add_Unique_Serial_Number;
 546       return Name_Enter;
 547    end New_Internal_Name;
 548
 549    -----------------------
 550    -- New_Occurrence_Of --
 551    -----------------------
 552
 553    function New_Occurrence_Of
 554      (Def_Id : Entity_Id;
 555       Loc    : Source_Ptr) return Node_Id
 556    is
 557       Occurrence : Node_Id;
 558
 559    begin
 560       Occurrence := New_Node (N_Identifier, Loc);
 561       Set_Chars (Occurrence, Chars (Def_Id));
 562       Set_Entity (Occurrence, Def_Id);
 563
 564       if Is_Type (Def_Id) then
 565          Set_Etype (Occurrence, Def_Id);
 566       else
 567          Set_Etype (Occurrence, Etype (Def_Id));
 568       end if;
 569
 570       return Occurrence;
 571    end New_Occurrence_Of;
 572
 573    ----------------------
 574    -- New_Reference_To --
 575    ----------------------
 576
 577    function New_Reference_To
 578      (Def_Id : Entity_Id;
 579       Loc    : Source_Ptr) return Node_Id
 580    is
 581       Occurrence : Node_Id;
 582
 583    begin
 584       Occurrence := New_Node (N_Identifier, Loc);
 585       Set_Chars (Occurrence, Chars (Def_Id));
 586       Set_Entity (Occurrence, Def_Id);
 587       return Occurrence;
 588    end New_Reference_To;
 589
 590    -----------------------
 591    -- New_Suffixed_Name --
 592    -----------------------
 593
 594    function New_Suffixed_Name
 595      (Related_Id : Name_Id;
 596       Suffix     : String) return Name_Id
 597    is
 598    begin
 599       Get_Name_String (Related_Id);
 600       Name_Len := Name_Len + 1;
 601       Name_Buffer (Name_Len) := '_';
 602       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 603       Name_Len := Name_Len + Suffix'Length;
 604       return Name_Find;
 605    end New_Suffixed_Name;
 606
 607    -------------------
 608    -- OK_Convert_To --
 609    -------------------
 610
 611    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 612       Result : Node_Id;
 613    begin
 614       Result :=
 615         Make_Type_Conversion (Sloc (Expr),
 616           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 617           Expression   => Relocate_Node (Expr));
 618       Set_Conversion_OK (Result, True);
 619       Set_Etype (Result, Typ);
 620       return Result;
 621    end OK_Convert_To;
 622
 623    --------------------------
 624    -- Unchecked_Convert_To --
 625    --------------------------
 626
 627    function Unchecked_Convert_To
 628      (Typ  : Entity_Id;
 629       Expr : Node_Id) return Node_Id
 630    is
 631       Loc    : constant Source_Ptr := Sloc (Expr);
 632       Result : Node_Id;
 633
 634    begin
 635       --  If the expression is already of the correct type, then nothing
 636       --  to do, except for relocating the node in case this is required.
 637
 638       if Present (Etype (Expr))
 639         and then (Base_Type (Etype (Expr)) = Typ
 640                    or else Etype (Expr) = Typ)
 641       then
 642          return Relocate_Node (Expr);
 643
 644       --  Cases where the inner expression is itself an unchecked conversion
 645       --  to the same type, and we can thus eliminate the outer conversion.
 646
 647       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
 648         and then Entity (Subtype_Mark (Expr)) = Typ
 649       then
 650          Result := Relocate_Node (Expr);
 651
 652       elsif Nkind (Expr) = N_Null
 653         and then Is_Access_Type (Typ)
 654       then
 655          --  No need for a conversion
 656
 657          Result := Relocate_Node (Expr);
 658
 659       --  All other cases
 660
 661       else
 662          Result :=
 663            Make_Unchecked_Type_Conversion (Loc,
 664              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 665              Expression   => Relocate_Node (Expr));
 666       end if;
 667
 668       Set_Etype (Result, Typ);
 669       return Result;
 670    end Unchecked_Convert_To;
 671
 672 end Tbuild;