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