gcc/ada/prj-ext.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . E X T                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2000-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Hostparm;
  28 with Makeutl;  use Makeutl;
  29 with Output;   use Output;
  30 with Osint;    use Osint;
  31 with Sdefault;
  32 with Table;
  33
  34 with GNAT.HTable;
  35
  36 package body Prj.Ext is
  37
  38    Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
  39    --  Name of alternate env. variable that contain path name(s) of directories
  40    --  where project files may reside. GPR_PROJECT_PATH has precedence over
  41    --  ADA_PROJECT_PATH.
  42
  43    Gpr_Prj_Path : constant String_Access := Getenv (Gpr_Project_Path);
  44    Ada_Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
  45    --  The path name(s) of directories where project files may reside.
  46    --  May be empty.
  47
  48    No_Project_Default_Dir : constant String := "-";
  49
  50    Current_Project_Path : String_Access;
  51    --  The project path. Initialized by procedure Initialize_Project_Path
  52    --  below.
  53
  54    procedure Initialize_Project_Path;
  55    --  Initialize Current_Project_Path
  56
  57    package Htable is new GNAT.HTable.Simple_HTable
  58      (Header_Num => Header_Num,
  59       Element    => Name_Id,
  60       No_Element => No_Name,
  61       Key        => Name_Id,
  62       Hash       => Hash,
  63       Equal      => "=");
  64    --  External references are stored in this hash table, either by procedure
  65    --  Add (directly or through a call to function Check) or by function
  66    --  Value_Of when an environment variable is found non empty. Value_Of
  67    --  first for external reference in this table, before checking the
  68    --  environment. Htable is emptied (reset) by procedure Reset.
  69
  70    ---------
  71    package Search_Directories is new Table.Table
  72      (Table_Component_Type => Name_Id,
  73       Table_Index_Type     => Natural,
  74       Table_Low_Bound      => 1,
  75       Table_Initial        => 4,
  76       Table_Increment      => 100,
  77       Table_Name           => "Prj.Ext.Search_Directories");
  78    --  The table for the directories specified with -aP switches
  79
  80    -- Add --
  81    ---------
  82
  83    procedure Add
  84      (External_Name : String;
  85       Value         : String)
  86    is
  87       The_Key   : Name_Id;
  88       The_Value : Name_Id;
  89    begin
  90       Name_Len := Value'Length;
  91       Name_Buffer (1 .. Name_Len) := Value;
  92       The_Value := Name_Find;
  93       Name_Len := External_Name'Length;
  94       Name_Buffer (1 .. Name_Len) := External_Name;
  95       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
  96       The_Key := Name_Find;
  97       Htable.Set (The_Key, The_Value);
  98    end Add;
  99
 100    -----------
 101    ----------------------------------
 102    -- Add_Search_Project_Directory --
 103    ----------------------------------
 104
 105    procedure Add_Search_Project_Directory (Path : String) is
 106    begin
 107       Name_Len := 0;
 108       Add_Str_To_Name_Buffer (Path);
 109       Search_Directories.Append (Name_Find);
 110    end Add_Search_Project_Directory;
 111
 112    -- Check --
 113    -----------
 114
 115    function Check (Declaration : String) return Boolean is
 116    begin
 117       for Equal_Pos in Declaration'Range loop
 118          if Declaration (Equal_Pos) = '=' then
 119             exit when Equal_Pos = Declaration'First;
 120             exit when Equal_Pos = Declaration'Last;
 121             Add
 122               (External_Name =>
 123                  Declaration (Declaration'First .. Equal_Pos - 1),
 124                Value =>
 125                  Declaration (Equal_Pos + 1 .. Declaration'Last));
 126             return True;
 127          end if;
 128       end loop;
 129
 130       return False;
 131    end Check;
 132
 133    -----------------------------
 134    -- Initialize_Project_Path --
 135    -----------------------------
 136
 137    procedure Initialize_Project_Path is
 138       Add_Default_Dir : Boolean := True;
 139       First           : Positive;
 140       Last            : Positive;
 141       New_Len         : Positive;
 142       New_Last        : Positive;
 143       Prj_Path        : String_Access := Gpr_Prj_Path;
 144
 145    begin
 146       if Get_Mode = Ada_Only then
 147          if Gpr_Prj_Path.all /= "" then
 148
 149             --  Warn if both environment variables are defined
 150
 151             if Ada_Prj_Path.all /= "" then
 152                Write_Line
 153                  ("Warning: ADA_PROJECT_PATH is not taken into account");
 154                Write_Line ("         when GPR_PROJECT_PATH is defined");
 155             end if;
 156
 157          else
 158             Prj_Path := Ada_Prj_Path;
 159          end if;
 160       end if;
 161
 162       --  The current directory is always first
 163
 164       Name_Len := 1;
 165       Name_Buffer (Name_Len) := '.';
 166
 167       --  If there are directories in the Search_Directories table, add them
 168
 169       for J in 1 .. Search_Directories.Last loop
 170          Name_Len := Name_Len + 1;
 171          Name_Buffer (Name_Len) := Path_Separator;
 172          Add_Str_To_Name_Buffer
 173            (Get_Name_String (Search_Directories.Table (J)));
 174       end loop;
 175
 176       --  If environment variable is defined and not empty, add its content
 177
 178       if Prj_Path.all /= "" then
 179          Name_Len := Name_Len + 1;
 180          Name_Buffer (Name_Len) := Path_Separator;
 181
 182          Add_Str_To_Name_Buffer (Prj_Path.all);
 183       end if;
 184
 185       --  Scan the directory path to see if "-" is one of the directories.
 186       --  Remove each occurence of "-" and set Add_Default_Dir to False.
 187       --  Also resolve relative paths and symbolic links.
 188
 189       First := 3;
 190       loop
 191          while First <= Name_Len
 192            and then (Name_Buffer (First) = Path_Separator)
 193          loop
 194             First := First + 1;
 195          end loop;
 196
 197          exit when First > Name_Len;
 198
 199          Last := First;
 200
 201          while Last < Name_Len
 202            and then Name_Buffer (Last + 1) /= Path_Separator
 203          loop
 204             Last := Last + 1;
 205          end loop;
 206
 207          --  If the directory is "-", set Add_Default_Dir to False and
 208          --  remove from path.
 209
 210          if Name_Buffer (First .. Last) = No_Project_Default_Dir then
 211             Add_Default_Dir := False;
 212
 213             for J in Last + 1 .. Name_Len loop
 214                Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
 215                  Name_Buffer (J);
 216             end loop;
 217
 218             Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
 219
 220             --  After removing the '-', go back one character to get the next
 221             --  directory corectly.
 222
 223             Last := Last - 1;
 224
 225          elsif not Hostparm.OpenVMS
 226            or else not Is_Absolute_Path (Name_Buffer (First .. Last))
 227          then
 228             --  On VMS, only expand relative path names, as absolute paths
 229             --  may correspond to multi-valued VMS logical names.
 230
 231             declare
 232                New_Dir : constant String :=
 233                            Normalize_Pathname (Name_Buffer (First .. Last));
 234
 235             begin
 236                --  If the absolute path was resolved and is different from
 237                --  the original, replace original with the resolved path.
 238
 239                if New_Dir /= Name_Buffer (First .. Last)
 240                  and then New_Dir'Length /= 0
 241                then
 242                   New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
 243                   New_Last := First + New_Dir'Length - 1;
 244                   Name_Buffer (New_Last + 1 .. New_Len) :=
 245                     Name_Buffer (Last + 1 .. Name_Len);
 246                   Name_Buffer (First .. New_Last) := New_Dir;
 247                   Name_Len := New_Len;
 248                   Last := New_Last;
 249                end if;
 250             end;
 251          end if;
 252
 253          First := Last + 1;
 254       end loop;
 255
 256       --  Set the initial value of Current_Project_Path
 257
 258       if Add_Default_Dir then
 259          declare
 260             Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
 261          begin
 262             if Prefix = null then
 263                Prefix := new String'(Executable_Prefix_Path);
 264
 265                if Prefix.all /= "" then
 266                   if Get_Mode = Ada_Only then
 267                      Current_Project_Path :=
 268                        new String'(Name_Buffer (1 .. Name_Len) &
 269                                    Path_Separator &
 270                                    Prefix.all & Directory_Separator & "gnat");
 271
 272                   else
 273                      Current_Project_Path :=
 274                        new String'(Name_Buffer (1 .. Name_Len) &
 275                                    Path_Separator &
 276                                    Prefix.all & Directory_Separator &
 277                                    "share" & Directory_Separator & "gpr");
 278                   end if;
 279                end if;
 280
 281             else
 282                Current_Project_Path :=
 283                  new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
 284                              Prefix.all &
 285                              ".." &  Directory_Separator &
 286                              ".." & Directory_Separator &
 287                              ".." & Directory_Separator & "gnat");
 288             end if;
 289          end;
 290       end if;
 291
 292       if Current_Project_Path = null then
 293          Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
 294       end if;
 295    end Initialize_Project_Path;
 296
 297    ------------------
 298    -- Project_Path --
 299    ------------------
 300
 301    function Project_Path return String is
 302    begin
 303       if Current_Project_Path = null then
 304          Initialize_Project_Path;
 305       end if;
 306
 307       return Current_Project_Path.all;
 308    end Project_Path;
 309
 310    -----------
 311    -- Reset --
 312    -----------
 313
 314    procedure Reset is
 315    begin
 316       Htable.Reset;
 317    end Reset;
 318
 319    ----------------------
 320    -- Set_Project_Path --
 321    ----------------------
 322
 323    procedure Set_Project_Path (New_Path : String) is
 324    begin
 325       Free (Current_Project_Path);
 326       Current_Project_Path := new String'(New_Path);
 327    end Set_Project_Path;
 328
 329    --------------
 330    -- Value_Of --
 331    --------------
 332
 333    function Value_Of
 334      (External_Name : Name_Id;
 335       With_Default  : Name_Id := No_Name)
 336       return          Name_Id
 337    is
 338       The_Value : Name_Id;
 339       Name      : String := Get_Name_String (External_Name);
 340
 341    begin
 342       Canonical_Case_File_Name (Name);
 343       Name_Len := Name'Length;
 344       Name_Buffer (1 .. Name_Len) := Name;
 345       The_Value := Htable.Get (Name_Find);
 346
 347       if The_Value /= No_Name then
 348          return The_Value;
 349       end if;
 350
 351       --  Find if it is an environment, if it is, put value in the hash table
 352
 353       declare
 354          Env_Value : String_Access := Getenv (Name);
 355
 356       begin
 357          if Env_Value /= null and then Env_Value'Length > 0 then
 358             Name_Len := Env_Value'Length;
 359             Name_Buffer (1 .. Name_Len) := Env_Value.all;
 360             The_Value := Name_Find;
 361             Htable.Set (External_Name, The_Value);
 362             Free (Env_Value);
 363             return The_Value;
 364
 365          else
 366             Free (Env_Value);
 367             return With_Default;
 368          end if;
 369       end;
 370    end Value_Of;
 371
 372 end Prj.Ext;