------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . E X T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Osint; use Osint; with Ada.Unchecked_Deallocation; package body Prj.Ext is ---------------- -- Initialize -- ---------------- procedure Initialize (Self : out External_References; Copy_From : External_References := No_External_Refs) is N : Name_To_Name_Ptr; N2 : Name_To_Name_Ptr; begin if Self.Refs = null then Self.Refs := new Name_To_Name_HTable.Instance; if Copy_From.Refs /= null then N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all); while N /= null loop N2 := new Name_To_Name' (Key => N.Key, Value => N.Value, Source => N.Source, Next => null); Name_To_Name_HTable.Set (Self.Refs.all, N2); N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all); end loop; end if; end if; end Initialize; --------- -- Add -- --------- procedure Add (Self : External_References; External_Name : String; Value : String; Source : External_Source := External_Source'First; Silent : Boolean := False) is Key : Name_Id; N : Name_To_Name_Ptr; begin -- For external attribute, set the environment variable if Source = From_External_Attribute and then External_Name /= "" then declare Env_Var : String_Access := Getenv (External_Name); begin if Env_Var = null or else Env_Var.all = "" then Setenv (Name => External_Name, Value => Value); if not Silent then Debug_Output ("Environment variable """ & External_Name & """ = """ & Value & '"'); end if; elsif not Silent then Debug_Output ("Not overriding existing environment variable """ & External_Name & """, value is """ & Env_Var.all & '"'); end if; Free (Env_Var); end; end if; Name_Len := External_Name'Length; Name_Buffer (1 .. Name_Len) := External_Name; Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len)); Key := Name_Find; -- Check whether the value is already defined, to properly respect the -- overriding order. if Source /= External_Source'First then N := Name_To_Name_HTable.Get (Self.Refs.all, Key); if N /= null then if External_Source'Pos (N.Source) < External_Source'Pos (Source) then if not Silent then Debug_Output ("Not overridding existing external reference '" & External_Name & "', value was defined in " & N.Source'Img); end if; return; end if; end if; end if; Name_Len := Value'Length; Name_Buffer (1 .. Name_Len) := Value; N := new Name_To_Name' (Key => Key, Source => Source, Value => Name_Find, Next => null); if not Silent then Debug_Output ("Add external (" & External_Name & ") is", N.Value); end if; Name_To_Name_HTable.Set (Self.Refs.all, N); end Add; ----------- -- Check -- ----------- function Check (Self : External_References; Declaration : String) return Boolean is begin for Equal_Pos in Declaration'Range loop if Declaration (Equal_Pos) = '=' then exit when Equal_Pos = Declaration'First; Add (Self => Self, External_Name => Declaration (Declaration'First .. Equal_Pos - 1), Value => Declaration (Equal_Pos + 1 .. Declaration'Last), Source => From_Command_Line); return True; end if; end loop; return False; end Check; ----------- -- Reset -- ----------- procedure Reset (Self : External_References) is begin if Self.Refs /= null then Debug_Output ("Reset external references"); Name_To_Name_HTable.Reset (Self.Refs.all); end if; end Reset; -------------- -- Value_Of -- -------------- function Value_Of (Self : External_References; External_Name : Name_Id; With_Default : Name_Id := No_Name) return Name_Id is Value : Name_To_Name_Ptr; Val : Name_Id; Name : String := Get_Name_String (External_Name); begin Canonical_Case_Env_Var_Name (Name); if Self.Refs /= null then Name_Len := Name'Length; Name_Buffer (1 .. Name_Len) := Name; Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find); if Value /= null then Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value); return Value.Value; end if; end if; -- Find if it is an environment, if it is, put value in the hash table declare Env_Value : String_Access := Getenv (Name); begin if Env_Value /= null and then Env_Value'Length > 0 then Name_Len := Env_Value'Length; Name_Buffer (1 .. Name_Len) := Env_Value.all; Val := Name_Find; if Current_Verbosity = High then Debug_Output ("Value_Of (" & Name & ") is", Val); end if; if Self.Refs /= null then Value := new Name_To_Name' (Key => External_Name, Value => Val, Source => From_Environment, Next => null); Name_To_Name_HTable.Set (Self.Refs.all, Value); end if; Free (Env_Value); return Val; else if Current_Verbosity = High then Debug_Output ("Value_Of (" & Name & ") is default", With_Default); end if; Free (Env_Value); return With_Default; end if; end; end Value_Of; ---------- -- Free -- ---------- procedure Free (Self : in out External_References) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Name_To_Name_HTable.Instance, Instance_Access); begin if Self.Refs /= null then Reset (Self); Unchecked_Free (Self.Refs); end if; end Free; -------------- -- Set_Next -- -------------- procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is begin E.Next := Next; end Set_Next; ---------- -- Next -- ---------- function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is begin return E.Next; end Next; ------------- -- Get_Key -- ------------- function Get_Key (E : Name_To_Name_Ptr) return Name_Id is begin return E.Key; end Get_Key; end Prj.Ext;