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-2016, 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       Silent        : Boolean := False)
  71    is
  72       Key : Name_Id;
  73       N   : Name_To_Name_Ptr;
  74
  75    begin
  76       --  For external attribute, set the environment variable
  77
  78       if Source = From_External_Attribute and then External_Name /= "" then
  79          declare
  80             Env_Var : String_Access := Getenv (External_Name);
  81
  82          begin
  83             if Env_Var = null or else Env_Var.all = "" then
  84                Setenv (Name => External_Name, Value => Value);
  85
  86                if not Silent then
  87                   Debug_Output
  88                     ("Environment variable """ & External_Name
  89                      & """ = """ & Value & '"');
  90                end if;
  91
  92             elsif not Silent then
  93                Debug_Output
  94                  ("Not overriding existing environment variable """
  95                   & External_Name & """, value is """ & Env_Var.all & '"');
  96             end if;
  97
  98             Free (Env_Var);
  99          end;
 100       end if;
 101
 102       Name_Len := External_Name'Length;
 103       Name_Buffer (1 .. Name_Len) := External_Name;
 104       Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
 105       Key := Name_Find;
 106
 107       --  Check whether the value is already defined, to properly respect the
 108       --  overriding order.
 109
 110       if Source /= External_Source'First then
 111          N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
 112
 113          if N /= null then
 114             if External_Source'Pos (N.Source) <
 115                External_Source'Pos (Source)
 116             then
 117                if not Silent then
 118                   Debug_Output
 119                     ("Not overriding existing external reference '"
 120                      & External_Name & "', value was defined in "
 121                      & N.Source'Img);
 122                end if;
 123
 124                return;
 125             end if;
 126          end if;
 127       end if;
 128
 129       Name_Len := Value'Length;
 130       Name_Buffer (1 .. Name_Len) := Value;
 131       N := new Name_To_Name'
 132                  (Key    => Key,
 133                   Source => Source,
 134                   Value  => Name_Find,
 135                   Next   => null);
 136
 137       if not Silent then
 138          Debug_Output ("Add external (" & External_Name & ") is", N.Value);
 139       end if;
 140
 141       Name_To_Name_HTable.Set (Self.Refs.all, N);
 142    end Add;
 143
 144    -----------
 145    -- Check --
 146    -----------
 147
 148    function Check
 149      (Self        : External_References;
 150       Declaration : String) return Boolean
 151    is
 152    begin
 153       for Equal_Pos in Declaration'Range loop
 154          if Declaration (Equal_Pos) = '=' then
 155             exit when Equal_Pos = Declaration'First;
 156             Add
 157               (Self          => Self,
 158                External_Name =>
 159                  Declaration (Declaration'First .. Equal_Pos - 1),
 160                Value         =>
 161                  Declaration (Equal_Pos + 1 .. Declaration'Last),
 162                Source        => From_Command_Line);
 163             return True;
 164          end if;
 165       end loop;
 166
 167       return False;
 168    end Check;
 169
 170    -----------
 171    -- Reset --
 172    -----------
 173
 174    procedure Reset (Self : External_References) is
 175    begin
 176       if Self.Refs /= null then
 177          Debug_Output ("Reset external references");
 178          Name_To_Name_HTable.Reset (Self.Refs.all);
 179       end if;
 180    end Reset;
 181
 182    --------------
 183    -- Value_Of --
 184    --------------
 185
 186    function Value_Of
 187      (Self          : External_References;
 188       External_Name : Name_Id;
 189       With_Default  : Name_Id := No_Name)
 190       return          Name_Id
 191    is
 192       Value : Name_To_Name_Ptr;
 193       Val   : Name_Id;
 194       Name  : String := Get_Name_String (External_Name);
 195
 196    begin
 197       Canonical_Case_Env_Var_Name (Name);
 198
 199       if Self.Refs /= null then
 200          Name_Len := Name'Length;
 201          Name_Buffer (1 .. Name_Len) := Name;
 202          Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
 203
 204          if Value /= null then
 205             Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
 206             return Value.Value;
 207          end if;
 208       end if;
 209
 210       --  Find if it is an environment, if it is, put value in the hash table
 211
 212       declare
 213          Env_Value : String_Access := Getenv (Name);
 214
 215       begin
 216          if Env_Value /= null and then Env_Value'Length > 0 then
 217             Name_Len := Env_Value'Length;
 218             Name_Buffer (1 .. Name_Len) := Env_Value.all;
 219             Val := Name_Find;
 220
 221             if Current_Verbosity = High then
 222                Debug_Output ("Value_Of (" & Name & ") is", Val);
 223             end if;
 224
 225             if Self.Refs /= null then
 226                Value := new Name_To_Name'
 227                  (Key    => External_Name,
 228                   Value  => Val,
 229                   Source => From_Environment,
 230                   Next   => null);
 231                Name_To_Name_HTable.Set (Self.Refs.all, Value);
 232             end if;
 233
 234             Free (Env_Value);
 235             return Val;
 236
 237          else
 238             if Current_Verbosity = High then
 239                Debug_Output
 240                  ("Value_Of (" & Name & ") is default", With_Default);
 241             end if;
 242
 243             Free (Env_Value);
 244             return With_Default;
 245          end if;
 246       end;
 247    end Value_Of;
 248
 249    ----------
 250    -- Free --
 251    ----------
 252
 253    procedure Free (Self : in out External_References) is
 254       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 255         (Name_To_Name_HTable.Instance, Instance_Access);
 256    begin
 257       if Self.Refs /= null then
 258          Reset (Self);
 259          Unchecked_Free (Self.Refs);
 260       end if;
 261    end Free;
 262
 263    --------------
 264    -- Set_Next --
 265    --------------
 266
 267    procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
 268    begin
 269       E.Next := Next;
 270    end Set_Next;
 271
 272    ----------
 273    -- Next --
 274    ----------
 275
 276    function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
 277    begin
 278       return E.Next;
 279    end Next;
 280
 281    -------------
 282    -- Get_Key --
 283    -------------
 284
 285    function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
 286    begin
 287       return E.Key;
 288    end Get_Key;
 289
 290 end Prj.Ext;