1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Osint; use Osint;
28 with Ada.Unchecked_Deallocation;
30 package body Prj.Ext is
37 (Self : out External_References;
38 Copy_From : External_References := No_External_Refs)
41 N2 : Name_To_Name_Ptr;
43 if Self.Refs = null then
44 Self.Refs := new Name_To_Name_HTable.Instance;
46 if Copy_From.Refs /= null then
47 N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
49 N2 := new Name_To_Name'
54 Name_To_Name_HTable.Set (Self.Refs.all, N2);
55 N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
66 (Self : External_References;
67 External_Name : String;
69 Source : External_Source := External_Source'First;
70 Silent : Boolean := False)
76 -- For external attribute, set the environment variable
78 if Source = From_External_Attribute and then External_Name /= "" then
80 Env_Var : String_Access := Getenv (External_Name);
83 if Env_Var = null or else Env_Var.all = "" then
84 Setenv (Name => External_Name, Value => Value);
88 ("Environment variable """ & External_Name
89 & """ = """ & Value & '"');
94 ("Not overriding existing environment variable """
95 & External_Name & """, value is """ & Env_Var.all & '"');
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));
107 -- Check whether the value is already defined, to properly respect the
110 if Source /= External_Source'First then
111 N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
114 if External_Source'Pos (N.Source) <
115 External_Source'Pos (Source)
119 ("Not overridding existing external reference '"
120 & External_Name & "', value was defined in "
129 Name_Len := Value'Length;
130 Name_Buffer (1 .. Name_Len) := Value;
131 N := new Name_To_Name'
138 Debug_Output ("Add external (" & External_Name & ") is", N.Value);
141 Name_To_Name_HTable.Set (Self.Refs.all, N);
149 (Self : External_References;
150 Declaration : String) return Boolean
153 for Equal_Pos in Declaration'Range loop
154 if Declaration (Equal_Pos) = '=' then
155 exit when Equal_Pos = Declaration'First;
159 Declaration (Declaration'First .. Equal_Pos - 1),
161 Declaration (Equal_Pos + 1 .. Declaration'Last),
162 Source => From_Command_Line);
174 procedure Reset (Self : External_References) is
176 if Self.Refs /= null then
177 Debug_Output ("Reset external references");
178 Name_To_Name_HTable.Reset (Self.Refs.all);
187 (Self : External_References;
188 External_Name : Name_Id;
189 With_Default : Name_Id := No_Name)
192 Value : Name_To_Name_Ptr;
194 Name : String := Get_Name_String (External_Name);
197 Canonical_Case_Env_Var_Name (Name);
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);
204 if Value /= null then
205 Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
210 -- Find if it is an environment, if it is, put value in the hash table
213 Env_Value : String_Access := Getenv (Name);
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;
221 if Current_Verbosity = High then
222 Debug_Output ("Value_Of (" & Name & ") is", Val);
225 if Self.Refs /= null then
226 Value := new Name_To_Name'
227 (Key => External_Name,
229 Source => From_Environment,
231 Name_To_Name_HTable.Set (Self.Refs.all, Value);
238 if Current_Verbosity = High then
240 ("Value_Of (" & Name & ") is default", With_Default);
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);
257 if Self.Refs /= null then
259 Unchecked_Free (Self.Refs);
267 procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
276 function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
285 function Get_Key (E : Name_To_Name_Ptr) return Name_Id is