gcc/ada/prj.adb

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