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