gcc/ada/prj.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  P R J                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2001-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 Ada.Characters.Handling; use Ada.Characters.Handling;
  28
  29 with Namet;    use Namet;
  30 with Osint;    use Osint;
  31 with Prj.Attr;
  32 with Prj.Com;
  33 with Prj.Env;
  34 with Prj.Err;  use Prj.Err;
  35 with Scans;    use Scans;
  36 with Snames;   use Snames;
  37
  38 with GNAT.OS_Lib; use GNAT.OS_Lib;
  39
  40 package body Prj is
  41
  42    The_Empty_String : Name_Id;
  43
  44    Ada_Language     : constant Name_Id := Name_Ada;
  45
  46    subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
  47
  48    The_Casing_Images : constant array (Known_Casing) of String_Access :=
  49      (All_Lower_Case => new String'("lowercase"),
  50       All_Upper_Case => new String'("UPPERCASE"),
  51       Mixed_Case     => new String'("MixedCase"));
  52
  53    Initialized : Boolean := False;
  54
  55    Standard_Dot_Replacement      : constant Name_Id :=
  56      First_Name_Id + Character'Pos ('-');
  57
  58    Std_Naming_Data : Naming_Data :=
  59      (Current_Language          => No_Name,
  60       Dot_Replacement           => Standard_Dot_Replacement,
  61       Dot_Repl_Loc              => No_Location,
  62       Casing                    => All_Lower_Case,
  63       Spec_Suffix               => No_Array_Element,
  64       Current_Spec_Suffix       => No_Name,
  65       Spec_Suffix_Loc           => No_Location,
  66       Body_Suffix               => No_Array_Element,
  67       Current_Body_Suffix       => No_Name,
  68       Body_Suffix_Loc           => No_Location,
  69       Separate_Suffix           => No_Name,
  70       Sep_Suffix_Loc            => No_Location,
  71       Specs                     => No_Array_Element,
  72       Bodies                    => No_Array_Element,
  73       Specification_Exceptions  => No_Array_Element,
  74       Implementation_Exceptions => No_Array_Element);
  75
  76    Project_Empty : constant Project_Data :=
  77      (First_Referred_By              => No_Project,
  78       Name                           => No_Name,
  79       Path_Name                      => No_Name,
  80       Virtual                        => False,
  81       Display_Path_Name              => No_Name,
  82       Location                       => No_Location,
  83       Mains                          => Nil_String,
  84       Directory                      => No_Name,
  85       Display_Directory              => No_Name,
  86       Dir_Path                       => null,
  87       Library                        => False,
  88       Library_Dir                    => No_Name,
  89       Display_Library_Dir            => No_Name,
  90       Library_Src_Dir                => No_Name,
  91       Display_Library_Src_Dir        => No_Name,
  92       Library_Name                   => No_Name,
  93       Library_Kind                   => Static,
  94       Lib_Internal_Name              => No_Name,
  95       Lib_Elaboration                => False,
  96       Standalone_Library             => False,
  97       Lib_Interface_ALIs             => Nil_String,
  98       Lib_Auto_Init                  => False,
  99       Sources_Present                => True,
 100       Sources                        => Nil_String,
 101       Source_Dirs                    => Nil_String,
 102       Known_Order_Of_Source_Dirs     => True,
 103       Object_Directory               => No_Name,
 104       Display_Object_Dir             => No_Name,
 105       Exec_Directory                 => No_Name,
 106       Display_Exec_Dir               => No_Name,
 107       Extends                        => No_Project,
 108       Extended_By                    => No_Project,
 109       Naming                         => Std_Naming_Data,
 110       Decl                           => No_Declarations,
 111       Imported_Projects              => Empty_Project_List,
 112       Ada_Include_Path               => null,
 113       Ada_Objects_Path               => null,
 114       Include_Path_File              => No_Name,
 115       Objects_Path_File_With_Libs    => No_Name,
 116       Objects_Path_File_Without_Libs => No_Name,
 117       Config_File_Name               => No_Name,
 118       Config_File_Temp               => False,
 119       Config_Checked                 => False,
 120       Language_Independent_Checked   => False,
 121       Checked                        => False,
 122       Seen                           => False,
 123       Flag1                          => False,
 124       Flag2                          => False,
 125       Depth                          => 0);
 126
 127    -------------------
 128    -- Add_To_Buffer --
 129    -------------------
 130
 131    procedure Add_To_Buffer (S : String) is
 132    begin
 133       --  If Buffer is too small, double its size
 134
 135       if Buffer_Last + S'Length > Buffer'Last then
 136          declare
 137             New_Buffer : constant  String_Access :=
 138                            new String (1 .. 2 * Buffer'Last);
 139
 140          begin
 141             New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
 142             Free (Buffer);
 143             Buffer := New_Buffer;
 144          end;
 145       end if;
 146
 147       Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S;
 148       Buffer_Last := Buffer_Last + S'Length;
 149    end Add_To_Buffer;
 150
 151    -------------------
 152    -- Empty_Project --
 153    -------------------
 154
 155    function Empty_Project return Project_Data is
 156    begin
 157       Initialize;
 158       return Project_Empty;
 159    end Empty_Project;
 160
 161    ------------------
 162    -- Empty_String --
 163    ------------------
 164
 165    function Empty_String return Name_Id is
 166    begin
 167       return The_Empty_String;
 168    end Empty_String;
 169
 170    ------------
 171    -- Expect --
 172    ------------
 173
 174    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 175    begin
 176       if Token /= The_Token then
 177          Error_Msg (Token_Image & " expected", Token_Ptr);
 178       end if;
 179    end Expect;
 180
 181    --------------------------------
 182    -- For_Every_Project_Imported --
 183    --------------------------------
 184
 185    procedure For_Every_Project_Imported
 186      (By         : Project_Id;
 187       With_State : in out State)
 188    is
 189
 190       procedure Check (Project : Project_Id);
 191       --  Check if a project has already been seen.
 192       --  If not seen, mark it as seen, call Action,
 193       --  and check all its imported projects.
 194
 195       procedure Check (Project : Project_Id) is
 196          List : Project_List;
 197
 198       begin
 199          if not Projects.Table (Project).Seen then
 200             Projects.Table (Project).Seen := True;
 201             Action (Project, With_State);
 202
 203             List := Projects.Table (Project).Imported_Projects;
 204             while List /= Empty_Project_List loop
 205                Check (Project_Lists.Table (List).Project);
 206                List := Project_Lists.Table (List).Next;
 207             end loop;
 208          end if;
 209       end Check;
 210
 211    begin
 212       for Project in Projects.First .. Projects.Last loop
 213          Projects.Table (Project).Seen := False;
 214       end loop;
 215
 216       Check (Project => By);
 217    end For_Every_Project_Imported;
 218
 219    -----------
 220    -- Image --
 221    -----------
 222
 223    function Image (Casing : Casing_Type) return String is
 224    begin
 225       return The_Casing_Images (Casing).all;
 226    end Image;
 227
 228    ----------------
 229    -- Initialize --
 230    ----------------
 231
 232    procedure Initialize is
 233    begin
 234       if not Initialized then
 235          Initialized := True;
 236          Name_Len := 0;
 237          The_Empty_String := Name_Find;
 238          Empty_Name := The_Empty_String;
 239          Name_Len := 4;
 240          Name_Buffer (1 .. 4) := ".ads";
 241          Default_Ada_Spec_Suffix := Name_Find;
 242          Name_Len := 4;
 243          Name_Buffer (1 .. 4) := ".adb";
 244          Default_Ada_Body_Suffix := Name_Find;
 245          Name_Len := 1;
 246          Name_Buffer (1) := '/';
 247          Slash := Name_Find;
 248          Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
 249          Std_Naming_Data.Current_Body_Suffix := Default_Ada_Body_Suffix;
 250          Std_Naming_Data.Separate_Suffix     := Default_Ada_Body_Suffix;
 251          Register_Default_Naming_Scheme
 252            (Language            => Ada_Language,
 253             Default_Spec_Suffix => Default_Ada_Spec_Suffix,
 254             Default_Body_Suffix => Default_Ada_Body_Suffix);
 255          Prj.Env.Initialize;
 256          Prj.Attr.Initialize;
 257          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 258          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 259          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 260       end if;
 261    end Initialize;
 262
 263    ------------------------------------
 264    -- Register_Default_Naming_Scheme --
 265    ------------------------------------
 266
 267    procedure Register_Default_Naming_Scheme
 268      (Language            : Name_Id;
 269       Default_Spec_Suffix : Name_Id;
 270       Default_Body_Suffix : Name_Id)
 271    is
 272       Lang : Name_Id;
 273       Suffix : Array_Element_Id;
 274       Found : Boolean := False;
 275       Element : Array_Element;
 276
 277    begin
 278       --  Get the language name in small letters
 279
 280       Get_Name_String (Language);
 281       Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
 282       Lang := Name_Find;
 283
 284       Suffix := Std_Naming_Data.Spec_Suffix;
 285       Found := False;
 286
 287       --  Look for an element of the spec sufix array indexed by the language
 288       --  name. If one is found, put the default value.
 289
 290       while Suffix /= No_Array_Element and then not Found loop
 291          Element := Array_Elements.Table (Suffix);
 292
 293          if Element.Index = Lang then
 294             Found := True;
 295             Element.Value.Value := Default_Spec_Suffix;
 296             Array_Elements.Table (Suffix) := Element;
 297
 298          else
 299             Suffix := Element.Next;
 300          end if;
 301       end loop;
 302
 303       --  If none can be found, create a new one.
 304
 305       if not Found then
 306          Element :=
 307            (Index => Lang,
 308             Index_Case_Sensitive => False,
 309             Value => (Project  => No_Project,
 310                       Kind     => Single,
 311                       Location => No_Location,
 312                       Default  => False,
 313                       Value    => Default_Spec_Suffix),
 314             Next  => Std_Naming_Data.Spec_Suffix);
 315          Array_Elements.Increment_Last;
 316          Array_Elements.Table (Array_Elements.Last) := Element;
 317          Std_Naming_Data.Spec_Suffix := Array_Elements.Last;
 318       end if;
 319
 320       Suffix := Std_Naming_Data.Body_Suffix;
 321       Found := False;
 322
 323       --  Look for an element of the body sufix array indexed by the language
 324       --  name. If one is found, put the default value.
 325
 326       while Suffix /= No_Array_Element and then not Found loop
 327          Element := Array_Elements.Table (Suffix);
 328
 329          if Element.Index = Lang then
 330             Found := True;
 331             Element.Value.Value := Default_Body_Suffix;
 332             Array_Elements.Table (Suffix) := Element;
 333
 334          else
 335             Suffix := Element.Next;
 336          end if;
 337       end loop;
 338
 339       --  If none can be found, create a new one.
 340
 341       if not Found then
 342          Element :=
 343            (Index => Lang,
 344             Index_Case_Sensitive => False,
 345             Value => (Project  => No_Project,
 346                       Kind     => Single,
 347                       Location => No_Location,
 348                       Default  => False,
 349                       Value    => Default_Body_Suffix),
 350             Next  => Std_Naming_Data.Body_Suffix);
 351          Array_Elements.Increment_Last;
 352          Array_Elements.Table (Array_Elements.Last) := Element;
 353          Std_Naming_Data.Body_Suffix := Array_Elements.Last;
 354       end if;
 355    end Register_Default_Naming_Scheme;
 356
 357    ------------
 358    --  Reset --
 359    ------------
 360
 361    procedure Reset is
 362    begin
 363       Projects.Init;
 364       Project_Lists.Init;
 365       Packages.Init;
 366       Arrays.Init;
 367       Variable_Elements.Init;
 368       String_Elements.Init;
 369       Prj.Com.Units.Init;
 370       Prj.Com.Units_Htable.Reset;
 371    end Reset;
 372
 373    ------------------------
 374    -- Same_Naming_Scheme --
 375    ------------------------
 376
 377    function Same_Naming_Scheme
 378      (Left, Right : Naming_Data)
 379       return        Boolean
 380    is
 381    begin
 382       return Left.Dot_Replacement = Right.Dot_Replacement
 383         and then Left.Casing = Right.Casing
 384         and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
 385         and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
 386         and then Left.Separate_Suffix = Right.Separate_Suffix;
 387    end Same_Naming_Scheme;
 388
 389    ----------
 390    -- Scan --
 391    ----------
 392
 393    procedure Scan is
 394    begin
 395       Scanner.Scan;
 396    end Scan;
 397
 398    --------------------------
 399    -- Standard_Naming_Data --
 400    --------------------------
 401
 402    function Standard_Naming_Data return Naming_Data is
 403    begin
 404       Initialize;
 405       return Std_Naming_Data;
 406    end Standard_Naming_Data;
 407
 408    -----------
 409    -- Value --
 410    -----------
 411
 412    function Value (Image : String) return Casing_Type is
 413    begin
 414       for Casing in The_Casing_Images'Range loop
 415          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
 416             return Casing;
 417          end if;
 418       end loop;
 419
 420       raise Constraint_Error;
 421    end Value;
 422
 423 begin
 424    --  Make sure that the standard project file extension is compatible
 425    --  with canonical case file naming.
 426
 427    Canonical_Case_File_Name (Project_File_Extension);
 428 end Prj;