diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/prj-ext.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/prj-ext.adb | 261 |
1 files changed, 0 insertions, 261 deletions
diff --git a/gcc-4.7/gcc/ada/prj-ext.adb b/gcc-4.7/gcc/ada/prj-ext.adb deleted file mode 100644 index 5d49fa443..000000000 --- a/gcc-4.7/gcc/ada/prj-ext.adb +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . E X T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2011, 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) - is - Key : Name_Id; - N : Name_To_Name_Ptr; - - begin - 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 Current_Verbosity = High then - Debug_Output - ("Not overridding existing variable '" & 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 Current_Verbosity = High 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; |