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-2004 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 Namet;   use Namet;
  28 with Osint;   use Osint;
  29 with Sdefault;
  30 with Types;   use Types;
  31
  32 with GNAT.HTable;
  33 with GNAT.OS_Lib; use GNAT.OS_Lib;
  34
  35 package body Prj.Ext is
  36
  37    Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
  38    --  Name of the env. variable that contains path name(s) of directories
  39    --  where project files may reside.
  40
  41    Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
  42    --  The path name(s) of directories where project files may reside.
  43    --  May be empty.
  44
  45    No_Project_Default_Dir : constant String := "-";
  46
  47    Current_Project_Path : String_Access;
  48    --  The project path; initialized during elaboration of package
  49    --  Contains at least the current working directory.
  50
  51    package Htable is new GNAT.HTable.Simple_HTable
  52      (Header_Num => Header_Num,
  53       Element    => Name_Id,
  54       No_Element => No_Name,
  55       Key        => Name_Id,
  56       Hash       => Hash,
  57       Equal      => "=");
  58    --  External references are stored in this hash table, either by procedure
  59    --  Add (directly or through a call to function Check) or by function
  60    --  Value_Of when an environment variable is found non empty. Value_Of
  61    --  first for external reference in this table, before checking the
  62    --  environment. Htable is emptied (reset) by procedure Reset.
  63
  64    ---------
  65    -- Add --
  66    ---------
  67
  68    procedure Add
  69      (External_Name : String;
  70       Value         : String)
  71    is
  72       The_Key   : Name_Id;
  73       The_Value : Name_Id;
  74
  75    begin
  76       Name_Len := Value'Length;
  77       Name_Buffer (1 .. Name_Len) := Value;
  78       The_Value := Name_Find;
  79       Name_Len := External_Name'Length;
  80       Name_Buffer (1 .. Name_Len) := External_Name;
  81       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
  82       The_Key := Name_Find;
  83       Htable.Set (The_Key, The_Value);
  84    end Add;
  85
  86    -----------
  87    -- Check --
  88    -----------
  89
  90    function Check (Declaration : String) return Boolean is
  91    begin
  92       for Equal_Pos in Declaration'Range loop
  93          if Declaration (Equal_Pos) = '=' then
  94             exit when Equal_Pos = Declaration'First;
  95             exit when Equal_Pos = Declaration'Last;
  96             Add
  97               (External_Name =>
  98                  Declaration (Declaration'First .. Equal_Pos - 1),
  99                Value =>
 100                  Declaration (Equal_Pos + 1 .. Declaration'Last));
 101             return True;
 102          end if;
 103       end loop;
 104
 105       return False;
 106    end Check;
 107
 108    ------------------
 109    -- Project_Path --
 110    ------------------
 111
 112    function Project_Path return String is
 113    begin
 114       return Current_Project_Path.all;
 115    end Project_Path;
 116
 117    -----------
 118    -- Reset --
 119    -----------
 120
 121    procedure Reset is
 122    begin
 123       Htable.Reset;
 124    end Reset;
 125
 126    ----------------------
 127    -- Set_Project_Path --
 128    ----------------------
 129
 130    procedure Set_Project_Path (New_Path : String) is
 131    begin
 132       Free (Current_Project_Path);
 133       Current_Project_Path := new String'(New_Path);
 134    end Set_Project_Path;
 135
 136    --------------
 137    -- Value_Of --
 138    --------------
 139
 140    function Value_Of
 141      (External_Name : Name_Id;
 142       With_Default  : Name_Id := No_Name)
 143       return          Name_Id
 144    is
 145       The_Value : Name_Id;
 146       Name      : String := Get_Name_String (External_Name);
 147
 148    begin
 149       Canonical_Case_File_Name (Name);
 150       Name_Len := Name'Length;
 151       Name_Buffer (1 .. Name_Len) := Name;
 152       The_Value := Htable.Get (Name_Find);
 153
 154       if The_Value /= No_Name then
 155          return The_Value;
 156       end if;
 157
 158       --  Find if it is an environment.
 159       --  If it is, put the value in the hash table.
 160
 161       declare
 162          Env_Value : String_Access := Getenv (Name);
 163
 164       begin
 165          if Env_Value /= null and then Env_Value'Length > 0 then
 166             Name_Len := Env_Value'Length;
 167             Name_Buffer (1 .. Name_Len) := Env_Value.all;
 168             The_Value := Name_Find;
 169             Htable.Set (External_Name, The_Value);
 170             Free (Env_Value);
 171             return The_Value;
 172
 173          else
 174             Free (Env_Value);
 175             return With_Default;
 176          end if;
 177       end;
 178    end Value_Of;
 179
 180 begin
 181    --  Initialize Current_Project_Path during package elaboration
 182
 183    declare
 184       Add_Default_Dir : Boolean := True;
 185       First           : Positive;
 186       Last            : Positive;
 187
 188    begin
 189       --  The current directory is always first
 190
 191       Name_Len := 1;
 192       Name_Buffer (Name_Len) := '.';
 193
 194       --  If env. var. is defined and not empty, add its content
 195
 196       if Prj_Path.all /= "" then
 197          Name_Len := Name_Len + 1;
 198          Name_Buffer (Name_Len) := Path_Separator;
 199
 200          Add_Str_To_Name_Buffer (Prj_Path.all);
 201
 202          --  Scan the directory path to see if "-" is one of the directories.
 203          --  Remove each occurence of "-" and set Add_Default_Dir to False.
 204
 205          First := 3;
 206          loop
 207             while First <= Name_Len
 208               and then (Name_Buffer (First) = Path_Separator)
 209             loop
 210                First := First + 1;
 211             end loop;
 212
 213             exit when First > Name_Len;
 214
 215             Last := First;
 216
 217             while Last < Name_Len
 218               and then Name_Buffer (Last + 1) /= Path_Separator
 219             loop
 220                Last := Last + 1;
 221             end loop;
 222
 223             --  If the directory is "-", set Add_Default_Dir to False and
 224             --  remove from path.
 225
 226             if Name_Buffer (First .. Last) = No_Project_Default_Dir then
 227                Add_Default_Dir := False;
 228
 229                for J in Last + 1 .. Name_Len loop
 230                   Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
 231                     Name_Buffer (J);
 232                end loop;
 233
 234                Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
 235             end if;
 236
 237             First := Last + 1;
 238          end loop;
 239       end if;
 240
 241       --  Set the initial value of Current_Project_Path
 242
 243       if Add_Default_Dir then
 244          Current_Project_Path :=
 245            new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
 246                        Sdefault.Search_Dir_Prefix.all & ".." &
 247                        Directory_Separator & ".." & Directory_Separator &
 248                        ".." & Directory_Separator & "gnat");
 249       else
 250          Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
 251       end if;
 252    end;
 253 end Prj.Ext;