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