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