gcc/ada/prj.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  P R J                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.16 $
  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    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    Standard_Specification_Append : Name_Id;
  59    Standard_Body_Append          : Name_Id;
  60
  61    Std_Naming_Data : Naming_Data :=
  62      (Dot_Replacement      => Standard_Dot_Replacement,
  63       Dot_Repl_Loc         => No_Location,
  64       Casing               => All_Lower_Case,
  65       Specification_Append => No_Name,
  66       Spec_Append_Loc      => No_Location,
  67       Body_Append          => No_Name,
  68       Body_Append_Loc      => No_Location,
  69       Separate_Append      => No_Name,
  70       Sep_Append_Loc       => No_Location,
  71       Specifications       => No_Array_Element,
  72       Bodies               => No_Array_Element);
  73
  74    Project_Empty : Project_Data :=
  75      (First_Referred_By  => No_Project,
  76       Name               => No_Name,
  77       Path_Name          => No_Name,
  78       Location           => No_Location,
  79       Directory          => No_Name,
  80       File_Name          => No_Name,
  81       Library            => False,
  82       Library_Dir        => No_Name,
  83       Library_Name       => No_Name,
  84       Library_Kind       => Static,
  85       Lib_Internal_Name  => No_Name,
  86       Lib_Elaboration    => False,
  87       Sources            => Nil_String,
  88       Source_Dirs        => Nil_String,
  89       Object_Directory   => No_Name,
  90       Modifies           => No_Project,
  91       Modified_By        => No_Project,
  92       Naming             => Std_Naming_Data,
  93       Decl               => No_Declarations,
  94       Imported_Projects  => Empty_Project_List,
  95       Include_Path       => null,
  96       Objects_Path       => null,
  97       Config_File_Name   => No_Name,
  98       Config_File_Temp   => False,
  99       Config_Checked     => False,
 100       Checked            => False,
 101       Seen               => False,
 102       Flag1              => False,
 103       Flag2              => False);
 104
 105    -------------------
 106    -- Empty_Project --
 107    -------------------
 108
 109    function Empty_Project return Project_Data is
 110    begin
 111       Initialize;
 112       return Project_Empty;
 113    end Empty_Project;
 114
 115    ------------------
 116    -- Empty_String --
 117    ------------------
 118
 119    function Empty_String return String_Id is
 120    begin
 121       return The_Empty_String;
 122    end Empty_String;
 123
 124    ------------
 125    -- Expect --
 126    ------------
 127
 128    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 129    begin
 130       if Token /= The_Token then
 131          Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
 132       end if;
 133    end Expect;
 134
 135    --------------------------------
 136    -- For_Every_Project_Imported --
 137    --------------------------------
 138
 139    procedure For_Every_Project_Imported
 140      (By         : Project_Id;
 141       With_State : in out State)
 142    is
 143
 144       procedure Check (Project : Project_Id);
 145       --  Check if a project has already been seen.
 146       --  If not seen, mark it as seen, call Action,
 147       --  and check all its imported projects.
 148
 149       procedure Check (Project : Project_Id) is
 150          List : Project_List;
 151
 152       begin
 153          if not Projects.Table (Project).Seen then
 154             Projects.Table (Project).Seen := False;
 155             Action (Project, With_State);
 156
 157             List := Projects.Table (Project).Imported_Projects;
 158             while List /= Empty_Project_List loop
 159                Check (Project_Lists.Table (List).Project);
 160                List := Project_Lists.Table (List).Next;
 161             end loop;
 162          end if;
 163       end Check;
 164
 165    begin
 166       for Project in Projects.First .. Projects.Last loop
 167          Projects.Table (Project).Seen := False;
 168       end loop;
 169
 170       Check (Project => By);
 171    end For_Every_Project_Imported;
 172
 173    -----------
 174    -- Image --
 175    -----------
 176
 177    function Image (Casing : Casing_Type) return String is
 178    begin
 179       return The_Casing_Images (Casing).all;
 180    end Image;
 181
 182    ----------------
 183    -- Initialize --
 184    ----------------
 185
 186    procedure Initialize is
 187    begin
 188       if not Initialized then
 189          Initialized := True;
 190          Stringt.Initialize;
 191          Start_String;
 192          The_Empty_String := End_String;
 193          Name_Len := 4;
 194          Name_Buffer (1 .. 4) := ".ads";
 195          Canonical_Case_File_Name (Name_Buffer (1 .. 4));
 196          Standard_Specification_Append := Name_Find;
 197          Name_Buffer (4) := 'b';
 198          Canonical_Case_File_Name (Name_Buffer (1 .. 4));
 199          Standard_Body_Append := Name_Find;
 200          Std_Naming_Data.Specification_Append := Standard_Specification_Append;
 201          Std_Naming_Data.Body_Append          := Standard_Body_Append;
 202          Std_Naming_Data.Separate_Append      := Standard_Body_Append;
 203          Project_Empty.Naming                 := Std_Naming_Data;
 204          Prj.Env.Initialize;
 205          Prj.Attr.Initialize;
 206          Set_Name_Table_Byte (Name_Project,   Token_Type'Pos (Tok_Project));
 207          Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying));
 208          Set_Name_Table_Byte (Name_External,  Token_Type'Pos (Tok_External));
 209       end if;
 210    end Initialize;
 211
 212    ------------
 213    --  Reset --
 214    ------------
 215
 216    procedure Reset is
 217    begin
 218       Projects.Init;
 219       Project_Lists.Init;
 220       Packages.Init;
 221       Arrays.Init;
 222       Variable_Elements.Init;
 223       String_Elements.Init;
 224       Prj.Com.Units.Init;
 225       Prj.Com.Units_Htable.Reset;
 226    end Reset;
 227
 228    ------------------------
 229    -- Same_Naming_Scheme --
 230    ------------------------
 231
 232    function Same_Naming_Scheme
 233      (Left, Right : Naming_Data)
 234       return        Boolean
 235    is
 236    begin
 237       return Left.Dot_Replacement = Right.Dot_Replacement
 238         and then Left.Casing = Right.Casing
 239         and then Left.Specification_Append = Right.Specification_Append
 240         and then Left.Body_Append = Right.Body_Append
 241         and then Left.Separate_Append = Right.Separate_Append;
 242    end Same_Naming_Scheme;
 243
 244    ----------
 245    -- Scan --
 246    ----------
 247
 248    procedure Scan is
 249    begin
 250       Scn.Scan;
 251
 252       --  Change operator symbol to literal strings, since that's the way
 253       --  we treat all strings in a project file.
 254
 255       if Token = Tok_Operator_Symbol then
 256          Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
 257          Token := Tok_String_Literal;
 258       end if;
 259    end Scan;
 260
 261    --------------------------
 262    -- Standard_Naming_Data --
 263    --------------------------
 264
 265    function Standard_Naming_Data return Naming_Data is
 266    begin
 267       Initialize;
 268       return Std_Naming_Data;
 269    end Standard_Naming_Data;
 270
 271    -----------
 272    -- Value --
 273    -----------
 274
 275    function Value (Image : String) return Casing_Type is
 276    begin
 277       for Casing in The_Casing_Images'Range loop
 278          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
 279             return Casing;
 280          end if;
 281       end loop;
 282
 283       raise Constraint_Error;
 284    end Value;
 285
 286 end Prj;