| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
