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