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 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    Default_Ada_Spec_Suffix : Name_Id := No_Name;
  47    Default_Ada_Impl_Suffix : Name_Id := No_Name;
  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       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    -- Ada_Default_Spec_Suffix --
 113    -----------------------------
 114
 115    function Ada_Default_Spec_Suffix return Name_Id is
 116    begin
 117       return Default_Ada_Spec_Suffix;
 118    end Ada_Default_Spec_Suffix;
 119
 120    -----------------------------
 121    -- Ada_Default_Impl_Suffix --
 122    -----------------------------
 123
 124    function Ada_Default_Impl_Suffix return Name_Id is
 125    begin
 126       return Default_Ada_Impl_Suffix;
 127    end Ada_Default_Impl_Suffix;
 128
 129    -------------------
 130    -- Empty_Project --
 131    -------------------
 132
 133    function Empty_Project return Project_Data is
 134    begin
 135       Initialize;
 136       return Project_Empty;
 137    end Empty_Project;
 138
 139    ------------------
 140    -- Empty_String --
 141    ------------------
 142
 143    function Empty_String return String_Id is
 144    begin
 145       return The_Empty_String;
 146    end Empty_String;
 147
 148    ------------
 149    -- Expect --
 150    ------------
 151
 152    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 153    begin
 154       if Token /= The_Token then
 155          Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
 156       end if;
 157    end Expect;
 158
 159    --------------------------------
 160    -- For_Every_Project_Imported --
 161    --------------------------------
 162
 163    procedure For_Every_Project_Imported
 164      (By         : Project_Id;
 165       With_State : in out State)
 166    is
 167
 168       procedure Check (Project : Project_Id);
 169       --  Check if a project has already been seen.
 170       --  If not seen, mark it as seen, call Action,
 171       --  and check all its imported projects.
 172
 173       procedure Check (Project : Project_Id) is
 174          List : Project_List;
 175
 176       begin
 177          if not Projects.Table (Project).Seen then
 178             Projects.Table (Project).Seen := False;
 179             Action (Project, With_State);
 180
 181             List := Projects.Table (Project).Imported_Projects;
 182             while List /= Empty_Project_List loop
 183                Check (Project_Lists.Table (List).Project);
 184                List := Project_Lists.Table (List).Next;
 185             end loop;
 186          end if;
 187       end Check;
 188
 189    begin
 190       for Project in Projects.First .. Projects.Last loop
 191          Projects.Table (Project).Seen := False;
 192       end loop;
 193
 194       Check (Project => By);
 195    end For_Every_Project_Imported;
 196
 197    -----------
 198    -- Image --
 199    -----------
 200
 201    function Image (Casing : Casing_Type) return String is
 202    begin
 203       return The_Casing_Images (Casing).all;
 204    end Image;
 205
 206    ----------------
 207    -- Initialize --
 208    ----------------
 209
 210    procedure Initialize is
 211    begin
 212       if not Initialized then
 213          Initialized := True;
 214          Stringt.Initialize;
 215          Start_String;
 216          The_Empty_String := End_String;
 217          Name_Len := 4;
 218          Name_Buffer (1 .. 4) := ".ads";
 219          Default_Ada_Spec_Suffix := Name_Find;
 220          Name_Len := 4;
 221          Name_Buffer (1 .. 4) := ".adb";
 222          Default_Ada_Impl_Suffix := Name_Find;
 223          Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
 224          Std_Naming_Data.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
 225          Std_Naming_Data.Separate_Suffix     := Default_Ada_Impl_Suffix;
 226          Prj.Env.Initialize;
 227          Prj.Attr.Initialize;
 228          Set_Name_Table_Byte (Name_Project,   Token_Type'Pos (Tok_Project));
 229          Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying));
 230          Set_Name_Table_Byte (Name_External,  Token_Type'Pos (Tok_External));
 231       end if;
 232    end Initialize;
 233
 234    ------------
 235    --  Reset --
 236    ------------
 237
 238    procedure Reset is
 239    begin
 240       Projects.Init;
 241       Project_Lists.Init;
 242       Packages.Init;
 243       Arrays.Init;
 244       Variable_Elements.Init;
 245       String_Elements.Init;
 246       Prj.Com.Units.Init;
 247       Prj.Com.Units_Htable.Reset;
 248    end Reset;
 249
 250    ------------------------
 251    -- Same_Naming_Scheme --
 252    ------------------------
 253
 254    function Same_Naming_Scheme
 255      (Left, Right : Naming_Data)
 256       return        Boolean
 257    is
 258    begin
 259       return Left.Dot_Replacement = Right.Dot_Replacement
 260         and then Left.Casing = Right.Casing
 261         and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
 262         and then Left.Current_Impl_Suffix = Right.Current_Impl_Suffix
 263         and then Left.Separate_Suffix = Right.Separate_Suffix;
 264    end Same_Naming_Scheme;
 265
 266    ----------
 267    -- Scan --
 268    ----------
 269
 270    procedure Scan is
 271    begin
 272       Scn.Scan;
 273
 274       --  Change operator symbol to literal strings, since that's the way
 275       --  we treat all strings in a project file.
 276
 277       if Token = Tok_Operator_Symbol then
 278          Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
 279          Token := Tok_String_Literal;
 280       end if;
 281    end Scan;
 282
 283    --------------------------
 284    -- Standard_Naming_Data --
 285    --------------------------
 286
 287    function Standard_Naming_Data return Naming_Data is
 288    begin
 289       Initialize;
 290       return Std_Naming_Data;
 291    end Standard_Naming_Data;
 292
 293    -----------
 294    -- Value --
 295    -----------
 296
 297    function Value (Image : String) return Casing_Type is
 298    begin
 299       for Casing in The_Casing_Images'Range loop
 300          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
 301             return Casing;
 302          end if;
 303       end loop;
 304
 305       raise Constraint_Error;
 306    end Value;
 307
 308 end Prj;