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