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