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-2005, 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    procedure Add_Unique_Serial_Number is
  57       Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
  58
  59    begin
  60       Add_Nat_To_Name_Buffer (Increment_Serial_Number);
  61
  62       --  Add either b or s, depending on whether current unit is a spec
  63       --  or a body. This is needed because we may generate the same name
  64       --  in a spec and a body otherwise.
  65
  66       Name_Len := Name_Len + 1;
  67
  68       if Nkind (Unit_Node) = N_Package_Declaration
  69         or else Nkind (Unit_Node) = N_Subprogram_Declaration
  70         or else Nkind (Unit_Node) in N_Generic_Declaration
  71       then
  72          Name_Buffer (Name_Len) := 's';
  73       else
  74          Name_Buffer (Name_Len) := 'b';
  75       end if;
  76    end Add_Unique_Serial_Number;
  77
  78    ----------------
  79    -- Checks_Off --
  80    ----------------
  81
  82    function Checks_Off (N : Node_Id) return Node_Id is
  83    begin
  84       return
  85         Make_Unchecked_Expression (Sloc (N),
  86           Expression => N);
  87    end Checks_Off;
  88
  89    ----------------
  90    -- Convert_To --
  91    ----------------
  92
  93    function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
  94       Result : Node_Id;
  95
  96    begin
  97       if Present (Etype (Expr))
  98         and then (Etype (Expr)) = Typ
  99       then
 100          return Relocate_Node (Expr);
 101       else
 102          Result :=
 103            Make_Type_Conversion (Sloc (Expr),
 104              Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 105              Expression => Relocate_Node (Expr));
 106
 107          Set_Etype (Result, Typ);
 108          return Result;
 109       end if;
 110    end Convert_To;
 111
 112    ------------------
 113    -- Discard_List --
 114    ------------------
 115
 116    procedure Discard_List (L : List_Id) is
 117       pragma Warnings (Off, L);
 118    begin
 119       null;
 120    end Discard_List;
 121
 122    ------------------
 123    -- Discard_Node --
 124    ------------------
 125
 126    procedure Discard_Node (N : Node_Or_Entity_Id) is
 127       pragma Warnings (Off, N);
 128    begin
 129       null;
 130    end Discard_Node;
 131
 132    -------------------------------------------
 133    -- Make_Byte_Aligned_Attribute_Reference --
 134    -------------------------------------------
 135
 136    function Make_Byte_Aligned_Attribute_Reference
 137      (Sloc           : Source_Ptr;
 138       Prefix         : Node_Id;
 139       Attribute_Name : Name_Id)
 140       return           Node_Id
 141    is
 142       N : constant Node_Id :=
 143             Make_Attribute_Reference (Sloc,
 144               Prefix        => Prefix,
 145               Attribute_Name => Attribute_Name);
 146
 147    begin
 148       pragma Assert (Attribute_Name = Name_Address
 149                        or else
 150                      Attribute_Name = Name_Unrestricted_Access);
 151       Set_Must_Be_Byte_Aligned (N, True);
 152       return N;
 153    end Make_Byte_Aligned_Attribute_Reference;
 154
 155    --------------------
 156    -- Make_DT_Access --
 157    --------------------
 158
 159    function Make_DT_Access
 160      (Loc : Source_Ptr;
 161       Rec : Node_Id;
 162       Typ : Entity_Id) return Node_Id
 163    is
 164       Full_Type : Entity_Id := Typ;
 165
 166    begin
 167       if Is_Private_Type (Typ) then
 168          Full_Type := Underlying_Type (Typ);
 169       end if;
 170
 171       return
 172         Unchecked_Convert_To (
 173           New_Occurrence_Of
 174             (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
 175           Make_Selected_Component (Loc,
 176             Prefix => New_Copy (Rec),
 177             Selector_Name =>
 178               New_Reference_To (First_Tag_Component (Full_Type), Loc)));
 179    end Make_DT_Access;
 180
 181    --------------------------------
 182    -- Make_Implicit_If_Statement --
 183    --------------------------------
 184
 185    function Make_Implicit_If_Statement
 186      (Node            : Node_Id;
 187       Condition       : Node_Id;
 188       Then_Statements : List_Id;
 189       Elsif_Parts     : List_Id := No_List;
 190       Else_Statements : List_Id := No_List) return Node_Id
 191    is
 192    begin
 193       Check_Restriction (No_Implicit_Conditionals, Node);
 194
 195       return Make_If_Statement (Sloc (Node),
 196         Condition,
 197         Then_Statements,
 198         Elsif_Parts,
 199         Else_Statements);
 200    end Make_Implicit_If_Statement;
 201
 202    -------------------------------------
 203    -- Make_Implicit_Label_Declaration --
 204    -------------------------------------
 205
 206    function Make_Implicit_Label_Declaration
 207      (Loc                 : Source_Ptr;
 208       Defining_Identifier : Node_Id;
 209       Label_Construct     : Node_Id) return Node_Id
 210    is
 211       N : constant Node_Id :=
 212             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
 213    begin
 214       Set_Label_Construct (N, Label_Construct);
 215       return N;
 216    end Make_Implicit_Label_Declaration;
 217
 218    ----------------------------------
 219    -- Make_Implicit_Loop_Statement --
 220    ----------------------------------
 221
 222    function Make_Implicit_Loop_Statement
 223      (Node                   : Node_Id;
 224       Statements             : List_Id;
 225       Identifier             : Node_Id := Empty;
 226       Iteration_Scheme       : Node_Id := Empty;
 227       Has_Created_Identifier : Boolean := False;
 228       End_Label              : Node_Id := Empty) return Node_Id
 229    is
 230    begin
 231       Check_Restriction (No_Implicit_Loops, Node);
 232
 233       if Present (Iteration_Scheme)
 234         and then Present (Condition (Iteration_Scheme))
 235       then
 236          Check_Restriction (No_Implicit_Conditionals, Node);
 237       end if;
 238
 239       return Make_Loop_Statement (Sloc (Node),
 240         Identifier             => Identifier,
 241         Iteration_Scheme       => Iteration_Scheme,
 242         Statements             => Statements,
 243         Has_Created_Identifier => Has_Created_Identifier,
 244         End_Label              => End_Label);
 245    end Make_Implicit_Loop_Statement;
 246
 247    --------------------------
 248    -- Make_Integer_Literal --
 249    ---------------------------
 250
 251    function Make_Integer_Literal
 252      (Loc    : Source_Ptr;
 253       Intval : Int) return Node_Id
 254    is
 255    begin
 256       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
 257    end Make_Integer_Literal;
 258
 259    --------------------------------
 260    -- Make_Linker_Section_Pragma --
 261    --------------------------------
 262
 263    function Make_Linker_Section_Pragma
 264      (Ent : Entity_Id;
 265       Loc : Source_Ptr;
 266       Sec : String) return Node_Id
 267    is
 268       LS : Node_Id;
 269
 270    begin
 271       LS :=
 272         Make_Pragma
 273           (Loc,
 274            Name_Linker_Section,
 275            New_List
 276              (Make_Pragma_Argument_Association
 277                 (Sloc => Loc,
 278                  Expression => New_Occurrence_Of (Ent, Loc)),
 279               Make_Pragma_Argument_Association
 280                 (Sloc => Loc,
 281                  Expression =>
 282                    Make_String_Literal
 283                      (Sloc => Loc,
 284                       Strval => Sec))));
 285
 286       Set_Has_Gigi_Rep_Item (Ent);
 287       return LS;
 288    end Make_Linker_Section_Pragma;
 289
 290    ---------------------------------
 291    -- Make_Raise_Constraint_Error --
 292    ---------------------------------
 293
 294    function Make_Raise_Constraint_Error
 295      (Sloc      : Source_Ptr;
 296       Condition : Node_Id := Empty;
 297       Reason    : RT_Exception_Code) return Node_Id
 298    is
 299    begin
 300       pragma Assert (Reason in RT_CE_Exceptions);
 301       return
 302         Make_Raise_Constraint_Error (Sloc,
 303           Condition => Condition,
 304           Reason =>
 305             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 306    end Make_Raise_Constraint_Error;
 307
 308    ------------------------------
 309    -- Make_Raise_Program_Error --
 310    ------------------------------
 311
 312    function Make_Raise_Program_Error
 313      (Sloc      : Source_Ptr;
 314       Condition : Node_Id := Empty;
 315       Reason    : RT_Exception_Code) return Node_Id
 316    is
 317    begin
 318       pragma Assert (Reason in RT_PE_Exceptions);
 319       return
 320         Make_Raise_Program_Error (Sloc,
 321           Condition => Condition,
 322           Reason =>
 323             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 324    end Make_Raise_Program_Error;
 325
 326    ------------------------------
 327    -- Make_Raise_Storage_Error --
 328    ------------------------------
 329
 330    function Make_Raise_Storage_Error
 331      (Sloc      : Source_Ptr;
 332       Condition : Node_Id := Empty;
 333       Reason    : RT_Exception_Code) return Node_Id
 334    is
 335    begin
 336       pragma Assert (Reason in RT_SE_Exceptions);
 337       return
 338         Make_Raise_Storage_Error (Sloc,
 339           Condition => Condition,
 340           Reason =>
 341             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 342    end Make_Raise_Storage_Error;
 343
 344    -------------------------
 345    -- Make_String_Literal --
 346    -------------------------
 347
 348    function Make_String_Literal
 349      (Sloc   : Source_Ptr;
 350       Strval : String) return Node_Id
 351    is
 352    begin
 353       Start_String;
 354       Store_String_Chars (Strval);
 355       return
 356         Make_String_Literal (Sloc,
 357           Strval => End_String);
 358    end Make_String_Literal;
 359
 360    ---------------------------
 361    -- Make_Unsuppress_Block --
 362    ---------------------------
 363
 364    --  Generates the following expansion:
 365
 366    --    declare
 367    --       pragma Suppress (<check>);
 368    --    begin
 369    --       <stmts>
 370    --    end;
 371
 372    function Make_Unsuppress_Block
 373      (Loc   : Source_Ptr;
 374       Check : Name_Id;
 375       Stmts : List_Id) return Node_Id
 376    is
 377    begin
 378       return
 379         Make_Block_Statement (Loc,
 380           Declarations => New_List (
 381             Make_Pragma (Loc,
 382               Chars => Name_Suppress,
 383               Pragma_Argument_Associations => New_List (
 384                 Make_Pragma_Argument_Association (Loc,
 385                   Expression => Make_Identifier (Loc, Check))))),
 386
 387           Handled_Statement_Sequence =>
 388             Make_Handled_Sequence_Of_Statements (Loc,
 389               Statements => Stmts));
 390    end Make_Unsuppress_Block;
 391
 392    --------------------------
 393    -- New_Constraint_Error --
 394    --------------------------
 395
 396    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
 397       Ident_Node : Node_Id;
 398       Raise_Node : Node_Id;
 399
 400    begin
 401       Ident_Node := New_Node (N_Identifier, Loc);
 402       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
 403       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
 404       Raise_Node := New_Node (N_Raise_Statement, Loc);
 405       Set_Name (Raise_Node, Ident_Node);
 406       return Raise_Node;
 407    end New_Constraint_Error;
 408
 409    -----------------------
 410    -- New_External_Name --
 411    -----------------------
 412
 413    function New_External_Name
 414      (Related_Id   : Name_Id;
 415       Suffix       : Character := ' ';
 416       Suffix_Index : Int       := 0;
 417       Prefix       : Character := ' ') return Name_Id
 418    is
 419    begin
 420       Get_Name_String (Related_Id);
 421
 422       if Prefix /= ' ' then
 423          pragma Assert (Is_OK_Internal_Letter (Prefix));
 424
 425          for J in reverse 1 .. Name_Len loop
 426             Name_Buffer (J + 1) := Name_Buffer (J);
 427          end loop;
 428
 429          Name_Len := Name_Len + 1;
 430          Name_Buffer (1) := Prefix;
 431       end if;
 432
 433       if Suffix /= ' ' then
 434          pragma Assert (Is_OK_Internal_Letter (Suffix));
 435          Name_Len := Name_Len + 1;
 436          Name_Buffer (Name_Len) := Suffix;
 437       end if;
 438
 439       if Suffix_Index /= 0 then
 440          if Suffix_Index < 0 then
 441             Add_Unique_Serial_Number;
 442          else
 443             Add_Nat_To_Name_Buffer (Suffix_Index);
 444          end if;
 445       end if;
 446
 447       return Name_Find;
 448    end New_External_Name;
 449
 450    function New_External_Name
 451      (Related_Id   : Name_Id;
 452       Suffix       : String;
 453       Suffix_Index : Int       := 0;
 454       Prefix       : Character := ' ') return Name_Id
 455    is
 456    begin
 457       Get_Name_String (Related_Id);
 458
 459       if Prefix /= ' ' then
 460          pragma Assert (Is_OK_Internal_Letter (Prefix));
 461
 462          for J in reverse 1 .. Name_Len loop
 463             Name_Buffer (J + 1) := Name_Buffer (J);
 464          end loop;
 465
 466          Name_Len := Name_Len + 1;
 467          Name_Buffer (1) := Prefix;
 468       end if;
 469
 470       if Suffix /= "" then
 471          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 472          Name_Len := Name_Len + Suffix'Length;
 473       end if;
 474
 475       if Suffix_Index /= 0 then
 476          if Suffix_Index < 0 then
 477             Add_Unique_Serial_Number;
 478          else
 479             Add_Nat_To_Name_Buffer (Suffix_Index);
 480          end if;
 481       end if;
 482
 483       return Name_Find;
 484    end New_External_Name;
 485
 486    function New_External_Name
 487      (Suffix       : Character;
 488       Suffix_Index : Nat) return Name_Id
 489    is
 490    begin
 491       Name_Buffer (1) := Suffix;
 492       Name_Len := 1;
 493       Add_Nat_To_Name_Buffer (Suffix_Index);
 494       return Name_Find;
 495    end New_External_Name;
 496
 497    -----------------------
 498    -- New_Internal_Name --
 499    -----------------------
 500
 501    function New_Internal_Name (Id_Char : Character) return Name_Id is
 502    begin
 503       pragma Assert (Is_OK_Internal_Letter (Id_Char));
 504       Name_Buffer (1) := Id_Char;
 505       Name_Len := 1;
 506       Add_Unique_Serial_Number;
 507       return Name_Enter;
 508    end New_Internal_Name;
 509
 510    -----------------------
 511    -- New_Occurrence_Of --
 512    -----------------------
 513
 514    function New_Occurrence_Of
 515      (Def_Id : Entity_Id;
 516       Loc    : Source_Ptr) return Node_Id
 517    is
 518       Occurrence : Node_Id;
 519
 520    begin
 521       Occurrence := New_Node (N_Identifier, Loc);
 522       Set_Chars (Occurrence, Chars (Def_Id));
 523       Set_Entity (Occurrence, Def_Id);
 524
 525       if Is_Type (Def_Id) then
 526          Set_Etype (Occurrence, Def_Id);
 527       else
 528          Set_Etype (Occurrence, Etype (Def_Id));
 529       end if;
 530
 531       return Occurrence;
 532    end New_Occurrence_Of;
 533
 534    ----------------------
 535    -- New_Reference_To --
 536    ----------------------
 537
 538    function New_Reference_To
 539      (Def_Id : Entity_Id;
 540       Loc    : Source_Ptr) return Node_Id
 541    is
 542       Occurrence : Node_Id;
 543
 544    begin
 545       Occurrence := New_Node (N_Identifier, Loc);
 546       Set_Chars (Occurrence, Chars (Def_Id));
 547       Set_Entity (Occurrence, Def_Id);
 548       return Occurrence;
 549    end New_Reference_To;
 550
 551    -----------------------
 552    -- New_Suffixed_Name --
 553    -----------------------
 554
 555    function New_Suffixed_Name
 556      (Related_Id : Name_Id;
 557       Suffix     : String) return Name_Id
 558    is
 559    begin
 560       Get_Name_String (Related_Id);
 561       Name_Len := Name_Len + 1;
 562       Name_Buffer (Name_Len) := '_';
 563       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 564       Name_Len := Name_Len + Suffix'Length;
 565       return Name_Find;
 566    end New_Suffixed_Name;
 567
 568    -------------------
 569    -- OK_Convert_To --
 570    -------------------
 571
 572    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 573       Result : Node_Id;
 574    begin
 575       Result :=
 576         Make_Type_Conversion (Sloc (Expr),
 577           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 578           Expression   => Relocate_Node (Expr));
 579       Set_Conversion_OK (Result, True);
 580       Set_Etype (Result, Typ);
 581       return Result;
 582    end OK_Convert_To;
 583
 584    --------------------------
 585    -- Unchecked_Convert_To --
 586    --------------------------
 587
 588    function Unchecked_Convert_To
 589      (Typ  : Entity_Id;
 590       Expr : Node_Id) return Node_Id
 591    is
 592       Loc    : constant Source_Ptr := Sloc (Expr);
 593       Result : Node_Id;
 594
 595    begin
 596       --  If the expression is already of the correct type, then nothing
 597       --  to do, except for relocating the node in case this is required.
 598
 599       if Present (Etype (Expr))
 600         and then (Base_Type (Etype (Expr)) = Typ
 601                    or else Etype (Expr) = Typ)
 602       then
 603          return Relocate_Node (Expr);
 604
 605       --  Cases where the inner expression is itself an unchecked conversion
 606       --  to the same type, and we can thus eliminate the outer conversion.
 607
 608       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
 609         and then Entity (Subtype_Mark (Expr)) = Typ
 610       then
 611          Result := Relocate_Node (Expr);
 612
 613       elsif Nkind (Expr) = N_Null
 614         and then Is_Access_Type (Typ)
 615       then
 616          --  No need for a conversion
 617
 618          Result := Relocate_Node (Expr);
 619
 620       --  All other cases
 621
 622       else
 623          Result :=
 624            Make_Unchecked_Type_Conversion (Loc,
 625              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 626              Expression   => Relocate_Node (Expr));
 627       end if;
 628
 629       Set_Etype (Result, Typ);
 630       return Result;
 631    end Unchecked_Convert_To;
 632
 633 end Tbuild;