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