gcc/ada/prj.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  P R J                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --             Copyright (C) 2001 Free Software Foundation, Inc.            --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.Characters.Handling; use Ada.Characters.Handling;
  29 with Errout;      use Errout;
  30 with GNAT.OS_Lib; use GNAT.OS_Lib;
  31 with Namet;       use Namet;
  32 with Osint;       use Osint;
  33 with Prj.Attr;
  34 with Prj.Com;
  35 with Prj.Env;
  36 with Scans;       use Scans;
  37 with Scn;
  38 with Stringt;     use Stringt;
  39 with Sinfo.CN;
  40 with Snames;      use Snames;
  41
  42 package body Prj is
  43
  44    The_Empty_String : String_Id;
  45
  46    Ada_Language     : constant Name_Id := Name_Ada;
  47
  48    subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
  49
  50    The_Casing_Images : array (Known_Casing) of String_Access :=
  51      (All_Lower_Case => new String'("lowercase"),
  52       All_Upper_Case => new String'("UPPERCASE"),
  53       Mixed_Case     => new String'("MixedCase"));
  54
  55    Initialized : Boolean := False;
  56
  57    Standard_Dot_Replacement      : constant Name_Id :=
  58      First_Name_Id + Character'Pos ('-');
  59
  60    Std_Naming_Data : Naming_Data :=
  61      (Current_Language          => No_Name,
  62       Dot_Replacement           => Standard_Dot_Replacement,
  63       Dot_Repl_Loc              => No_Location,
  64       Casing                    => All_Lower_Case,
  65       Specification_Suffix      => No_Array_Element,
  66       Current_Spec_Suffix       => No_Name,
  67       Spec_Suffix_Loc           => No_Location,
  68       Implementation_Suffix     => No_Array_Element,
  69       Current_Impl_Suffix       => No_Name,
  70       Impl_Suffix_Loc           => No_Location,
  71       Separate_Suffix           => No_Name,
  72       Sep_Suffix_Loc            => No_Location,
  73       Specifications            => No_Array_Element,
  74       Bodies                    => No_Array_Element,
  75       Specification_Exceptions  => No_Array_Element,
  76       Implementation_Exceptions => No_Array_Element);
  77
  78    Project_Empty : constant Project_Data :=
  79      (First_Referred_By            => No_Project,
  80       Name                         => No_Name,
  81       Path_Name                    => No_Name,
  82       Location                     => No_Location,
  83       Directory                    => No_Name,
  84       Library                      => False,
  85       Library_Dir                  => No_Name,
  86       Library_Name                 => No_Name,
  87       Library_Kind                 => Static,
  88       Lib_Internal_Name            => No_Name,
  89       Lib_Elaboration              => False,
  90       Sources_Present              => True,
  91       Sources                      => Nil_String,
  92       Source_Dirs                  => Nil_String,
  93       Object_Directory             => No_Name,
  94       Exec_Directory               => No_Name,
  95       Modifies                     => No_Project,
  96       Modified_By                  => No_Project,
  97       Naming                       => Std_Naming_Data,
  98       Decl                         => No_Declarations,
  99       Imported_Projects            => Empty_Project_List,
 100       Include_Path                 => null,
 101       Objects_Path                 => null,
 102       Config_File_Name             => No_Name,
 103       Config_File_Temp             => False,
 104       Config_Checked               => False,
 105       Language_Independent_Checked => False,
 106       Checked                      => False,
 107       Seen                         => False,
 108       Flag1                        => False,
 109       Flag2                        => False);
 110
 111    -------------------
 112    -- Empty_Project --
 113    -------------------
 114
 115    function Empty_Project return Project_Data is
 116    begin
 117       Initialize;
 118       return Project_Empty;
 119    end Empty_Project;
 120
 121    ------------------
 122    -- Empty_String --
 123    ------------------
 124
 125    function Empty_String return String_Id is
 126    begin
 127       return The_Empty_String;
 128    end Empty_String;
 129
 130    ------------
 131    -- Expect --
 132    ------------
 133
 134    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 135    begin
 136       if Token /= The_Token then
 137          Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
 138       end if;
 139    end Expect;
 140
 141    --------------------------------
 142    -- For_Every_Project_Imported --
 143    --------------------------------
 144
 145    procedure For_Every_Project_Imported
 146      (By         : Project_Id;
 147       With_State : in out State)
 148    is
 149
 150       procedure Check (Project : Project_Id);
 151       --  Check if a project has already been seen.
 152       --  If not seen, mark it as seen, call Action,
 153       --  and check all its imported projects.
 154
 155       procedure Check (Project : Project_Id) is
 156          List : Project_List;
 157
 158       begin
 159          if not Projects.Table (Project).Seen then
 160             Projects.Table (Project).Seen := True;
 161             Action (Project, With_State);
 162
 163             List := Projects.Table (Project).Imported_Projects;
 164             while List /= Empty_Project_List loop
 165                Check (Project_Lists.Table (List).Project);
 166                List := Project_Lists.Table (List).Next;
 167             end loop;
 168          end if;
 169       end Check;
 170
 171    begin
 172       for Project in Projects.First .. Projects.Last loop
 173          Projects.Table (Project).Seen := False;
 174       end loop;
 175
 176       Check (Project => By);
 177    end For_Every_Project_Imported;
 178
 179    -----------
 180    -- Image --
 181    -----------
 182
 183    function Image (Casing : Casing_Type) return String is
 184    begin
 185       return The_Casing_Images (Casing).all;
 186    end Image;
 187
 188    ----------------
 189    -- Initialize --
 190    ----------------
 191
 192    procedure Initialize is
 193    begin
 194       if not Initialized then
 195          Initialized := True;
 196          Stringt.Initialize;
 197          Start_String;
 198          The_Empty_String := End_String;
 199          Name_Len := 4;
 200          Name_Buffer (1 .. 4) := ".ads";
 201          Default_Ada_Spec_Suffix := Name_Find;
 202          Name_Len := 4;
 203          Name_Buffer (1 .. 4) := ".adb";
 204          Default_Ada_Impl_Suffix := Name_Find;
 205          Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
 206          Std_Naming_Data.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
 207          Std_Naming_Data.Separate_Suffix     := Default_Ada_Impl_Suffix;
 208          Register_Default_Naming_Scheme
 209            (Language            => Ada_Language,
 210             Default_Spec_Suffix => Default_Ada_Spec_Suffix,
 211             Default_Impl_Suffix => Default_Ada_Impl_Suffix);
 212          Prj.Env.Initialize;
 213          Prj.Attr.Initialize;
 214          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 215          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 216          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 217       end if;
 218    end Initialize;
 219
 220    ------------------------------------
 221    -- Register_Default_Naming_Scheme --
 222    ------------------------------------
 223
 224    procedure Register_Default_Naming_Scheme
 225      (Language            : Name_Id;
 226       Default_Spec_Suffix : Name_Id;
 227       Default_Impl_Suffix : Name_Id)
 228    is
 229       Lang : Name_Id;
 230       Suffix : Array_Element_Id;
 231       Found : Boolean := False;
 232       Element : Array_Element;
 233
 234       Spec_Str : String_Id;
 235       Impl_Str : String_Id;
 236
 237    begin
 238       --  The following code is completely uncommented ???
 239
 240       Get_Name_String (Language);
 241       Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
 242       Lang := Name_Find;
 243
 244       Get_Name_String (Default_Spec_Suffix);
 245       Start_String;
 246       Store_String_Chars (Name_Buffer (1 .. Name_Len));
 247       Spec_Str := End_String;
 248
 249       Get_Name_String (Default_Impl_Suffix);
 250       Start_String;
 251       Store_String_Chars (Name_Buffer (1 .. Name_Len));
 252       Impl_Str := End_String;
 253
 254       Suffix := Std_Naming_Data.Specification_Suffix;
 255       Found := False;
 256
 257       while Suffix /= No_Array_Element and then not Found loop
 258          Element := Array_Elements.Table (Suffix);
 259
 260          if Element.Index = Lang then
 261             Found := True;
 262             Element.Value.Value := Spec_Str;
 263             Array_Elements.Table (Suffix) := Element;
 264
 265          else
 266             Suffix := Element.Next;
 267          end if;
 268       end loop;
 269
 270       if not Found then
 271          Element :=
 272            (Index => Lang,
 273             Value => (Kind     => Single,
 274                       Location => No_Location,
 275                       Default  => False,
 276                       Value    => Spec_Str),
 277             Next  => Std_Naming_Data.Specification_Suffix);
 278          Array_Elements.Increment_Last;
 279          Array_Elements.Table (Array_Elements.Last) := Element;
 280          Std_Naming_Data.Specification_Suffix := Array_Elements.Last;
 281       end if;
 282
 283       Suffix := Std_Naming_Data.Implementation_Suffix;
 284       Found := False;
 285
 286       while Suffix /= No_Array_Element and then not Found loop
 287          Element := Array_Elements.Table (Suffix);
 288
 289          if Element.Index = Lang then
 290             Found := True;
 291             Element.Value.Value := Impl_Str;
 292             Array_Elements.Table (Suffix) := Element;
 293
 294          else
 295             Suffix := Element.Next;
 296          end if;
 297       end loop;
 298
 299       if not Found then
 300          Element :=
 301            (Index => Lang,
 302             Value => (Kind     => Single,
 303                       Location => No_Location,
 304                       Default  => False,
 305                       Value    => Impl_Str),
 306             Next  => Std_Naming_Data.Implementation_Suffix);
 307          Array_Elements.Increment_Last;
 308          Array_Elements.Table (Array_Elements.Last) := Element;
 309          Std_Naming_Data.Implementation_Suffix := Array_Elements.Last;
 310       end if;
 311    end Register_Default_Naming_Scheme;
 312
 313    ------------
 314    --  Reset --
 315    ------------
 316
 317    procedure Reset is
 318    begin
 319       Projects.Init;
 320       Project_Lists.Init;
 321       Packages.Init;
 322       Arrays.Init;
 323       Variable_Elements.Init;
 324       String_Elements.Init;
 325       Prj.Com.Units.Init;
 326       Prj.Com.Units_Htable.Reset;
 327    end Reset;
 328
 329    ------------------------
 330    -- Same_Naming_Scheme --
 331    ------------------------
 332
 333    function Same_Naming_Scheme
 334      (Left, Right : Naming_Data)
 335       return        Boolean
 336    is
 337    begin
 338       return Left.Dot_Replacement = Right.Dot_Replacement
 339         and then Left.Casing = Right.Casing
 340         and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
 341         and then Left.Current_Impl_Suffix = Right.Current_Impl_Suffix
 342         and then Left.Separate_Suffix = Right.Separate_Suffix;
 343    end Same_Naming_Scheme;
 344
 345    ----------
 346    -- Scan --
 347    ----------
 348
 349    procedure Scan is
 350    begin
 351       Scn.Scan;
 352
 353       --  Change operator symbol to literal strings, since that's the way
 354       --  we treat all strings in a project file.
 355
 356       if Token = Tok_Operator_Symbol then
 357          Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
 358          Token := Tok_String_Literal;
 359       end if;
 360    end Scan;
 361
 362    --------------------------
 363    -- Standard_Naming_Data --
 364    --------------------------
 365
 366    function Standard_Naming_Data return Naming_Data is
 367    begin
 368       Initialize;
 369       return Std_Naming_Data;
 370    end Standard_Naming_Data;
 371
 372    -----------
 373    -- Value --
 374    -----------
 375
 376    function Value (Image : String) return Casing_Type is
 377    begin
 378       for Casing in The_Casing_Images'Range loop
 379          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
 380             return Casing;
 381          end if;
 382       end loop;
 383
 384       raise Constraint_Error;
 385    end Value;
 386
 387 begin
 388    --  Make sure that the standard project file extension is compatible
 389    --  with canonical case file naming.
 390
 391    Canonical_Case_File_Name (Project_File_Extension);
 392 end Prj;