aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/prj-ext.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/prj-ext.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/prj-ext.adb261
1 files changed, 261 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/prj-ext.adb b/gcc-4.8.3/gcc/ada/prj-ext.adb
new file mode 100644
index 000000000..5d49fa443
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/prj-ext.adb
@@ -0,0 +1,261 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;