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 --                                                                          --
  10 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Einfo;    use Einfo;
  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 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    -- Make_Byte_Aligned_Attribute_Reference --
 112    -------------------------------------------
 113
 114    function Make_Byte_Aligned_Attribute_Reference
 115      (Sloc           : Source_Ptr;
 116       Prefix         : Node_Id;
 117       Attribute_Name : Name_Id)
 118       return           Node_Id
 119    is
 120       N : constant Node_Id :=
 121             Make_Attribute_Reference (Sloc,
 122               Prefix        => Prefix,
 123               Attribute_Name => Attribute_Name);
 124
 125    begin
 126       pragma Assert (Attribute_Name = Name_Address
 127                        or else
 128                      Attribute_Name = Name_Unrestricted_Access);
 129       Set_Must_Be_Byte_Aligned (N, True);
 130       return N;
 131    end Make_Byte_Aligned_Attribute_Reference;
 132
 133    --------------------
 134    -- Make_DT_Access --
 135    --------------------
 136
 137    function Make_DT_Access
 138      (Loc  : Source_Ptr;
 139       Rec  : Node_Id;
 140       Typ  : Entity_Id)
 141       return Node_Id
 142    is
 143       Full_Type : Entity_Id := Typ;
 144
 145    begin
 146       if Is_Private_Type (Typ) then
 147          Full_Type := Underlying_Type (Typ);
 148       end if;
 149
 150       return
 151         Unchecked_Convert_To (
 152           New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
 153           Make_Selected_Component (Loc,
 154             Prefix => New_Copy (Rec),
 155             Selector_Name =>
 156               New_Reference_To (Tag_Component (Full_Type), Loc)));
 157    end Make_DT_Access;
 158
 159    -----------------------
 160    -- Make_DT_Component --
 161    -----------------------
 162
 163    function Make_DT_Component
 164      (Loc  : Source_Ptr;
 165       Typ  : Entity_Id;
 166       I    : Positive)
 167       return Node_Id
 168    is
 169       X : Node_Id;
 170       Full_Type : Entity_Id := Typ;
 171
 172    begin
 173       if Is_Private_Type (Typ) then
 174          Full_Type := Underlying_Type (Typ);
 175       end if;
 176
 177       X := First_Component (
 178              Designated_Type (Etype (Access_Disp_Table (Full_Type))));
 179
 180       for J in 2 .. I loop
 181          X := Next_Component (X);
 182       end loop;
 183
 184       return New_Reference_To (X, Loc);
 185    end Make_DT_Component;
 186
 187    --------------------------------
 188    -- Make_Implicit_If_Statement --
 189    --------------------------------
 190
 191    function Make_Implicit_If_Statement
 192      (Node            : Node_Id;
 193       Condition       : Node_Id;
 194       Then_Statements : List_Id;
 195       Elsif_Parts     : List_Id := No_List;
 196       Else_Statements : List_Id := No_List)
 197       return            Node_Id
 198    is
 199    begin
 200       Check_Restriction (No_Implicit_Conditionals, Node);
 201       return Make_If_Statement (Sloc (Node),
 202         Condition,
 203         Then_Statements,
 204         Elsif_Parts,
 205         Else_Statements);
 206    end Make_Implicit_If_Statement;
 207
 208    -------------------------------------
 209    -- Make_Implicit_Label_Declaration --
 210    -------------------------------------
 211
 212    function Make_Implicit_Label_Declaration
 213      (Loc                 : Source_Ptr;
 214       Defining_Identifier : Node_Id;
 215       Label_Construct     : Node_Id)
 216       return                Node_Id
 217    is
 218       N : constant Node_Id :=
 219             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
 220
 221    begin
 222       Set_Label_Construct (N, Label_Construct);
 223       return N;
 224    end Make_Implicit_Label_Declaration;
 225
 226    ----------------------------------
 227    -- Make_Implicit_Loop_Statement --
 228    ----------------------------------
 229
 230    function Make_Implicit_Loop_Statement
 231      (Node                   : Node_Id;
 232       Statements             : List_Id;
 233       Identifier             : Node_Id := Empty;
 234       Iteration_Scheme       : Node_Id := Empty;
 235       Has_Created_Identifier : Boolean := False;
 236       End_Label              : Node_Id := Empty)
 237       return                   Node_Id
 238    is
 239    begin
 240       Check_Restriction (No_Implicit_Loops, Node);
 241
 242       if Present (Iteration_Scheme)
 243         and then Present (Condition (Iteration_Scheme))
 244       then
 245          Check_Restriction (No_Implicit_Conditionals, Node);
 246       end if;
 247
 248       return Make_Loop_Statement (Sloc (Node),
 249         Identifier             => Identifier,
 250         Iteration_Scheme       => Iteration_Scheme,
 251         Statements             => Statements,
 252         Has_Created_Identifier => Has_Created_Identifier,
 253         End_Label              => End_Label);
 254    end Make_Implicit_Loop_Statement;
 255
 256    --------------------------
 257    -- Make_Integer_Literal --
 258    ---------------------------
 259
 260    function Make_Integer_Literal
 261      (Loc    : Source_Ptr;
 262       Intval : Int)
 263       return   Node_Id
 264    is
 265    begin
 266       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
 267    end Make_Integer_Literal;
 268
 269    ---------------------------------
 270    -- Make_Raise_Constraint_Error --
 271    ---------------------------------
 272
 273    function Make_Raise_Constraint_Error
 274      (Sloc      : Source_Ptr;
 275       Condition : Node_Id := Empty;
 276       Reason    : RT_Exception_Code)
 277       return      Node_Id
 278    is
 279    begin
 280       pragma Assert (Reason in RT_CE_Exceptions);
 281       return
 282         Make_Raise_Constraint_Error (Sloc,
 283           Condition => Condition,
 284           Reason =>
 285             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 286    end Make_Raise_Constraint_Error;
 287
 288    ------------------------------
 289    -- Make_Raise_Program_Error --
 290    ------------------------------
 291
 292    function Make_Raise_Program_Error
 293      (Sloc      : Source_Ptr;
 294       Condition : Node_Id := Empty;
 295       Reason    : RT_Exception_Code)
 296       return      Node_Id
 297    is
 298    begin
 299       pragma Assert (Reason in RT_PE_Exceptions);
 300       return
 301         Make_Raise_Program_Error (Sloc,
 302           Condition => Condition,
 303           Reason =>
 304             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 305    end Make_Raise_Program_Error;
 306
 307    ------------------------------
 308    -- Make_Raise_Storage_Error --
 309    ------------------------------
 310
 311    function Make_Raise_Storage_Error
 312      (Sloc      : Source_Ptr;
 313       Condition : Node_Id := Empty;
 314       Reason    : RT_Exception_Code)
 315       return      Node_Id
 316    is
 317    begin
 318       pragma Assert (Reason in RT_SE_Exceptions);
 319       return
 320         Make_Raise_Storage_Error (Sloc,
 321           Condition => Condition,
 322           Reason =>
 323             UI_From_Int (RT_Exception_Code'Pos (Reason)));
 324    end Make_Raise_Storage_Error;
 325
 326    ---------------------------
 327    -- Make_Unsuppress_Block --
 328    ---------------------------
 329
 330    --  Generates the following expansion:
 331
 332    --    declare
 333    --       pragma Suppress (<check>);
 334    --    begin
 335    --       <stmts>
 336    --    end;
 337
 338    function Make_Unsuppress_Block
 339      (Loc   : Source_Ptr;
 340       Check : Name_Id;
 341       Stmts : List_Id)
 342       return  Node_Id
 343    is
 344    begin
 345       return
 346         Make_Block_Statement (Loc,
 347           Declarations => New_List (
 348             Make_Pragma (Loc,
 349               Chars => Name_Suppress,
 350               Pragma_Argument_Associations => New_List (
 351                 Make_Pragma_Argument_Association (Loc,
 352                   Expression => Make_Identifier (Loc, Check))))),
 353
 354           Handled_Statement_Sequence =>
 355             Make_Handled_Sequence_Of_Statements (Loc,
 356               Statements => Stmts));
 357    end Make_Unsuppress_Block;
 358
 359    --------------------------
 360    -- New_Constraint_Error --
 361    --------------------------
 362
 363    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
 364       Ident_Node : Node_Id;
 365       Raise_Node : Node_Id;
 366
 367    begin
 368       Ident_Node := New_Node (N_Identifier, Loc);
 369       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
 370       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
 371       Raise_Node := New_Node (N_Raise_Statement, Loc);
 372       Set_Name (Raise_Node, Ident_Node);
 373       return Raise_Node;
 374    end New_Constraint_Error;
 375
 376    -----------------------
 377    -- New_External_Name --
 378    -----------------------
 379
 380    function New_External_Name
 381      (Related_Id   : Name_Id;
 382       Suffix       : Character := ' ';
 383       Suffix_Index : Int       := 0;
 384       Prefix       : Character := ' ')
 385       return         Name_Id
 386    is
 387    begin
 388       Get_Name_String (Related_Id);
 389
 390       if Prefix /= ' ' then
 391          pragma Assert (Is_OK_Internal_Letter (Prefix));
 392
 393          for J in reverse 1 .. Name_Len loop
 394             Name_Buffer (J + 1) := Name_Buffer (J);
 395          end loop;
 396
 397          Name_Len := Name_Len + 1;
 398          Name_Buffer (1) := Prefix;
 399       end if;
 400
 401       if Suffix /= ' ' then
 402          pragma Assert (Is_OK_Internal_Letter (Suffix));
 403          Name_Len := Name_Len + 1;
 404          Name_Buffer (Name_Len) := Suffix;
 405       end if;
 406
 407       if Suffix_Index /= 0 then
 408          if Suffix_Index < 0 then
 409             Add_Unique_Serial_Number;
 410          else
 411             Add_Nat_To_Name_Buffer (Suffix_Index);
 412          end if;
 413       end if;
 414
 415       return Name_Find;
 416    end New_External_Name;
 417
 418    function New_External_Name
 419      (Related_Id   : Name_Id;
 420       Suffix       : String;
 421       Suffix_Index : Int       := 0;
 422       Prefix       : Character := ' ')
 423       return         Name_Id
 424    is
 425    begin
 426       Get_Name_String (Related_Id);
 427
 428       if Prefix /= ' ' then
 429          pragma Assert (Is_OK_Internal_Letter (Prefix));
 430
 431          for J in reverse 1 .. Name_Len loop
 432             Name_Buffer (J + 1) := Name_Buffer (J);
 433          end loop;
 434
 435          Name_Len := Name_Len + 1;
 436          Name_Buffer (1) := Prefix;
 437       end if;
 438
 439       if Suffix /= "" then
 440          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 441          Name_Len := Name_Len + Suffix'Length;
 442       end if;
 443
 444       if Suffix_Index /= 0 then
 445          if Suffix_Index < 0 then
 446             Add_Unique_Serial_Number;
 447          else
 448             Add_Nat_To_Name_Buffer (Suffix_Index);
 449          end if;
 450       end if;
 451
 452       return Name_Find;
 453    end New_External_Name;
 454
 455    function New_External_Name
 456      (Suffix       : Character;
 457       Suffix_Index : Nat)
 458       return         Name_Id
 459    is
 460    begin
 461       Name_Buffer (1) := Suffix;
 462       Name_Len := 1;
 463       Add_Nat_To_Name_Buffer (Suffix_Index);
 464       return Name_Find;
 465    end New_External_Name;
 466
 467    -----------------------
 468    -- New_Internal_Name --
 469    -----------------------
 470
 471    function New_Internal_Name (Id_Char : Character) return Name_Id is
 472    begin
 473       pragma Assert (Is_OK_Internal_Letter (Id_Char));
 474       Name_Buffer (1) := Id_Char;
 475       Name_Len := 1;
 476       Add_Unique_Serial_Number;
 477       return Name_Enter;
 478    end New_Internal_Name;
 479
 480    -----------------------
 481    -- New_Occurrence_Of --
 482    -----------------------
 483
 484    function New_Occurrence_Of
 485      (Def_Id : Entity_Id;
 486       Loc    : Source_Ptr)
 487       return   Node_Id
 488    is
 489       Occurrence : Node_Id;
 490
 491    begin
 492       Occurrence := New_Node (N_Identifier, Loc);
 493       Set_Chars (Occurrence, Chars (Def_Id));
 494       Set_Entity (Occurrence, Def_Id);
 495
 496       if Is_Type (Def_Id) then
 497          Set_Etype (Occurrence, Def_Id);
 498       else
 499          Set_Etype (Occurrence, Etype (Def_Id));
 500       end if;
 501
 502       return Occurrence;
 503    end New_Occurrence_Of;
 504
 505    ----------------------
 506    -- New_Reference_To --
 507    ----------------------
 508
 509    function New_Reference_To
 510      (Def_Id : Entity_Id;
 511       Loc    : Source_Ptr)
 512       return   Node_Id
 513    is
 514       Occurrence : Node_Id;
 515
 516    begin
 517       Occurrence := New_Node (N_Identifier, Loc);
 518       Set_Chars (Occurrence, Chars (Def_Id));
 519       Set_Entity (Occurrence, Def_Id);
 520       return Occurrence;
 521    end New_Reference_To;
 522
 523    -----------------------
 524    -- New_Suffixed_Name --
 525    -----------------------
 526
 527    function New_Suffixed_Name
 528      (Related_Id : Name_Id;
 529       Suffix     : String)
 530       return       Name_Id
 531    is
 532    begin
 533       Get_Name_String (Related_Id);
 534       Name_Len := Name_Len + 1;
 535       Name_Buffer (Name_Len) := '_';
 536       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 537       Name_Len := Name_Len + Suffix'Length;
 538       return Name_Find;
 539    end New_Suffixed_Name;
 540
 541    -------------------
 542    -- OK_Convert_To --
 543    -------------------
 544
 545    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
 546       Result : Node_Id;
 547
 548    begin
 549       Result :=
 550         Make_Type_Conversion (Sloc (Expr),
 551           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
 552           Expression   => Relocate_Node (Expr));
 553       Set_Conversion_OK (Result, True);
 554       Set_Etype (Result, Typ);
 555       return Result;
 556    end OK_Convert_To;
 557
 558    --------------------------
 559    -- Unchecked_Convert_To --
 560    --------------------------
 561
 562    function Unchecked_Convert_To
 563      (Typ  : Entity_Id;
 564       Expr : Node_Id)
 565       return Node_Id
 566    is
 567       Loc    : constant Source_Ptr := Sloc (Expr);
 568       Result : Node_Id;
 569
 570    begin
 571       --  If the expression is already of the correct type, then nothing
 572       --  to do, except for relocating the node in case this is required.
 573
 574       if Present (Etype (Expr))
 575         and then (Base_Type (Etype (Expr)) = Typ
 576                    or else Etype (Expr) = Typ)
 577       then
 578          return Relocate_Node (Expr);
 579
 580       --  Cases where the inner expression is itself an unchecked conversion
 581       --  to the same type, and we can thus eliminate the outer conversion.
 582
 583       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
 584         and then Entity (Subtype_Mark (Expr)) = Typ
 585       then
 586          Result := Relocate_Node (Expr);
 587
 588       --  All other cases
 589
 590       else
 591          Result :=
 592            Make_Unchecked_Type_Conversion (Loc,
 593              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 594              Expression   => Relocate_Node (Expr));
 595       end if;
 596
 597       Set_Etype (Result, Typ);
 598       return Result;
 599    end Unchecked_Convert_To;
 600
 601 end Tbuild;