1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              P R J . E X T                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2000-2013, Free Software Foundation, Inc.         --
10--                                                                          --
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.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Osint;    use Osint;
27
28with Ada.Unchecked_Deallocation;
29
30package body Prj.Ext is
31
32   ----------------
33   -- Initialize --
34   ----------------
35
36   procedure Initialize
37     (Self      : out External_References;
38      Copy_From : External_References := No_External_Refs)
39   is
40      N  : Name_To_Name_Ptr;
41      N2 : Name_To_Name_Ptr;
42   begin
43      if Self.Refs = null then
44         Self.Refs := new Name_To_Name_HTable.Instance;
45
46         if Copy_From.Refs /= null then
47            N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
48            while N /= null loop
49               N2 := new Name_To_Name'
50                           (Key    => N.Key,
51                            Value  => N.Value,
52                            Source => N.Source,
53                            Next   => null);
54               Name_To_Name_HTable.Set (Self.Refs.all, N2);
55               N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
56            end loop;
57         end if;
58      end if;
59   end Initialize;
60
61   ---------
62   -- Add --
63   ---------
64
65   procedure Add
66     (Self          : External_References;
67      External_Name : String;
68      Value         : String;
69      Source        : External_Source := External_Source'First;
70      Silent        : Boolean := False)
71   is
72      Key : Name_Id;
73      N   : Name_To_Name_Ptr;
74
75   begin
76      --  For external attribute, set the environment variable
77
78      if Source = From_External_Attribute and then External_Name /= "" then
79         declare
80            Env_Var : String_Access := Getenv (External_Name);
81
82         begin
83            if Env_Var = null or else Env_Var.all = "" then
84               Setenv (Name => External_Name, Value => Value);
85
86               if not Silent then
87                  Debug_Output
88                    ("Environment variable """ & External_Name
89                     & """ = """ & Value & '"');
90               end if;
91
92            elsif not Silent then
93               Debug_Output
94                 ("Not overriding existing environment variable """
95                  & External_Name & """, value is """ & Env_Var.all & '"');
96            end if;
97
98            Free (Env_Var);
99         end;
100      end if;
101
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));
105      Key := Name_Find;
106
107      --  Check whether the value is already defined, to properly respect the
108      --  overriding order.
109
110      if Source /= External_Source'First then
111         N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
112
113         if N /= null then
114            if External_Source'Pos (N.Source) <
115               External_Source'Pos (Source)
116            then
117               if not Silent then
118                  Debug_Output
119                    ("Not overridding existing external reference '"
120                     & External_Name & "', value was defined in "
121                     & N.Source'Img);
122               end if;
123
124               return;
125            end if;
126         end if;
127      end if;
128
129      Name_Len := Value'Length;
130      Name_Buffer (1 .. Name_Len) := Value;
131      N := new Name_To_Name'
132                 (Key    => Key,
133                  Source => Source,
134                  Value  => Name_Find,
135                  Next   => null);
136
137      if not Silent then
138         Debug_Output ("Add external (" & External_Name & ") is", N.Value);
139      end if;
140
141      Name_To_Name_HTable.Set (Self.Refs.all, N);
142   end Add;
143
144   -----------
145   -- Check --
146   -----------
147
148   function Check
149     (Self        : External_References;
150      Declaration : String) return Boolean
151   is
152   begin
153      for Equal_Pos in Declaration'Range loop
154         if Declaration (Equal_Pos) = '=' then
155            exit when Equal_Pos = Declaration'First;
156            Add
157              (Self          => Self,
158               External_Name =>
159                 Declaration (Declaration'First .. Equal_Pos - 1),
160               Value         =>
161                 Declaration (Equal_Pos + 1 .. Declaration'Last),
162               Source        => From_Command_Line);
163            return True;
164         end if;
165      end loop;
166
167      return False;
168   end Check;
169
170   -----------
171   -- Reset --
172   -----------
173
174   procedure Reset (Self : External_References) is
175   begin
176      if Self.Refs /= null then
177         Debug_Output ("Reset external references");
178         Name_To_Name_HTable.Reset (Self.Refs.all);
179      end if;
180   end Reset;
181
182   --------------
183   -- Value_Of --
184   --------------
185
186   function Value_Of
187     (Self          : External_References;
188      External_Name : Name_Id;
189      With_Default  : Name_Id := No_Name)
190      return          Name_Id
191   is
192      Value : Name_To_Name_Ptr;
193      Val   : Name_Id;
194      Name  : String := Get_Name_String (External_Name);
195
196   begin
197      Canonical_Case_Env_Var_Name (Name);
198
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);
203
204         if Value /= null then
205            Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
206            return Value.Value;
207         end if;
208      end if;
209
210      --  Find if it is an environment, if it is, put value in the hash table
211
212      declare
213         Env_Value : String_Access := Getenv (Name);
214
215      begin
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;
219            Val := Name_Find;
220
221            if Current_Verbosity = High then
222               Debug_Output ("Value_Of (" & Name & ") is", Val);
223            end if;
224
225            if Self.Refs /= null then
226               Value := new Name_To_Name'
227                 (Key    => External_Name,
228                  Value  => Val,
229                  Source => From_Environment,
230                  Next   => null);
231               Name_To_Name_HTable.Set (Self.Refs.all, Value);
232            end if;
233
234            Free (Env_Value);
235            return Val;
236
237         else
238            if Current_Verbosity = High then
239               Debug_Output
240                 ("Value_Of (" & Name & ") is default", With_Default);
241            end if;
242
243            Free (Env_Value);
244            return With_Default;
245         end if;
246      end;
247   end Value_Of;
248
249   ----------
250   -- Free --
251   ----------
252
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);
256   begin
257      if Self.Refs /= null then
258         Reset (Self);
259         Unchecked_Free (Self.Refs);
260      end if;
261   end Free;
262
263   --------------
264   -- Set_Next --
265   --------------
266
267   procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
268   begin
269      E.Next := Next;
270   end Set_Next;
271
272   ----------
273   -- Next --
274   ----------
275
276   function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
277   begin
278      return E.Next;
279   end Next;
280
281   -------------
282   -- Get_Key --
283   -------------
284
285   function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
286   begin
287      return E.Key;
288   end Get_Key;
289
290end Prj.Ext;
291