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-2011, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Osint;    use Osint;
  27
  28 with Ada.Unchecked_Deallocation;
  29
  30 package body Prj.Ext is
  31
  32    ----------------
  33    -- Initialize --
  34    ----------------
  35
  36    procedure Initialize
  37      (Self      : out External_References;
  38       Copy_From : External_References := No_External_Refs)
  39    is
  40       N  : Name_To_Name_Ptr;
  41       N2 : Name_To_Name_Ptr;
  42    begin
  43       if Self.Refs = null then
  44          Self.Refs := new Name_To_Name_HTable.Instance;
  45
  46          if Copy_From.Refs /= null then
  47             N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
  48             while N /= null loop
  49                N2 := new Name_To_Name'
  50                            (Key    => N.Key,
  51                             Value  => N.Value,
  52                             Source => N.Source,
  53                             Next   => null);
  54                Name_To_Name_HTable.Set (Self.Refs.all, N2);
  55                N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
  56             end loop;
  57          end if;
  58       end if;
  59    end Initialize;
  60
  61    ---------
  62    -- Add --
  63    ---------
  64
  65    procedure Add
  66      (Self          : External_References;
  67       External_Name : String;
  68       Value         : String;
  69       Source        : External_Source := External_Source'First)
  70    is
  71       Key : Name_Id;
  72       N   : Name_To_Name_Ptr;
  73
  74    begin
  75       Name_Len := External_Name'Length;
  76       Name_Buffer (1 .. Name_Len) := External_Name;
  77       Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
  78       Key := Name_Find;
  79
  80       --  Check whether the value is already defined, to properly respect the
  81       --  overriding order.
  82
  83       if Source /= External_Source'First then
  84          N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
  85
  86          if N /= null then
  87             if External_Source'Pos (N.Source) <
  88                External_Source'Pos (Source)
  89             then
  90                if Current_Verbosity = High then
  91                   Debug_Output
  92                     ("Not overridding existing variable '" & External_Name
  93                      & "', value was defined in " & N.Source'Img);
  94                end if;
  95                return;
  96             end if;
  97          end if;
  98       end if;
  99
 100       Name_Len := Value'Length;
 101       Name_Buffer (1 .. Name_Len) := Value;
 102       N := new Name_To_Name'
 103                  (Key    => Key,
 104                   Source => Source,
 105                   Value  => Name_Find,
 106                   Next   => null);
 107
 108       if Current_Verbosity = High then
 109          Debug_Output ("Add external (" & External_Name & ") is", N.Value);
 110       end if;
 111
 112       Name_To_Name_HTable.Set (Self.Refs.all, N);
 113    end Add;
 114
 115    -----------
 116    -- Check --
 117    -----------
 118
 119    function Check
 120      (Self        : External_References;
 121       Declaration : String) return Boolean
 122    is
 123    begin
 124       for Equal_Pos in Declaration'Range loop
 125          if Declaration (Equal_Pos) = '=' then
 126             exit when Equal_Pos = Declaration'First;
 127             Add
 128               (Self          => Self,
 129                External_Name =>
 130                  Declaration (Declaration'First .. Equal_Pos - 1),
 131                Value         =>
 132                  Declaration (Equal_Pos + 1 .. Declaration'Last),
 133                Source        => From_Command_Line);
 134             return True;
 135          end if;
 136       end loop;
 137
 138       return False;
 139    end Check;
 140
 141    -----------
 142    -- Reset --
 143    -----------
 144
 145    procedure Reset (Self : External_References) is
 146    begin
 147       if Self.Refs /= null then
 148          Debug_Output ("Reset external references");
 149          Name_To_Name_HTable.Reset (Self.Refs.all);
 150       end if;
 151    end Reset;
 152
 153    --------------
 154    -- Value_Of --
 155    --------------
 156
 157    function Value_Of
 158      (Self          : External_References;
 159       External_Name : Name_Id;
 160       With_Default  : Name_Id := No_Name)
 161       return          Name_Id
 162    is
 163       Value : Name_To_Name_Ptr;
 164       Val   : Name_Id;
 165       Name  : String := Get_Name_String (External_Name);
 166
 167    begin
 168       Canonical_Case_Env_Var_Name (Name);
 169
 170       if Self.Refs /= null then
 171          Name_Len := Name'Length;
 172          Name_Buffer (1 .. Name_Len) := Name;
 173          Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
 174
 175          if Value /= null then
 176             Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
 177             return Value.Value;
 178          end if;
 179       end if;
 180
 181       --  Find if it is an environment, if it is, put value in the hash table
 182
 183       declare
 184          Env_Value : String_Access := Getenv (Name);
 185
 186       begin
 187          if Env_Value /= null and then Env_Value'Length > 0 then
 188             Name_Len := Env_Value'Length;
 189             Name_Buffer (1 .. Name_Len) := Env_Value.all;
 190             Val := Name_Find;
 191
 192             if Current_Verbosity = High then
 193                Debug_Output ("Value_Of (" & Name & ") is", Val);
 194             end if;
 195
 196             if Self.Refs /= null then
 197                Value := new Name_To_Name'
 198                  (Key    => External_Name,
 199                   Value  => Val,
 200                   Source => From_Environment,
 201                   Next   => null);
 202                Name_To_Name_HTable.Set (Self.Refs.all, Value);
 203             end if;
 204
 205             Free (Env_Value);
 206             return Val;
 207
 208          else
 209             if Current_Verbosity = High then
 210                Debug_Output
 211                  ("Value_Of (" & Name & ") is default", With_Default);
 212             end if;
 213
 214             Free (Env_Value);
 215             return With_Default;
 216          end if;
 217       end;
 218    end Value_Of;
 219
 220    ----------
 221    -- Free --
 222    ----------
 223
 224    procedure Free (Self : in out External_References) is
 225       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 226         (Name_To_Name_HTable.Instance, Instance_Access);
 227    begin
 228       if Self.Refs /= null then
 229          Reset (Self);
 230          Unchecked_Free (Self.Refs);
 231       end if;
 232    end Free;
 233
 234    --------------
 235    -- Set_Next --
 236    --------------
 237
 238    procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
 239    begin
 240       E.Next := Next;
 241    end Set_Next;
 242
 243    ----------
 244    -- Next --
 245    ----------
 246
 247    function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
 248    begin
 249       return E.Next;
 250    end Next;
 251
 252    -------------
 253    -- Get_Key --
 254    -------------
 255
 256    function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
 257    begin
 258       return E.Key;
 259    end Get_Key;
 260
 261 end Prj.Ext;