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-2011, 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   is
71      Key : Name_Id;
72      N   : Name_To_Name_Ptr;
73
74   begin
75      Name_Len := External_Name'Length;
76      Name_Buffer (1 .. Name_Len) := External_Name;
77      Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
78      Key := Name_Find;
79
80      --  Check whether the value is already defined, to properly respect the
81      --  overriding order.
82
83      if Source /= External_Source'First then
84         N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
85
86         if N /= null then
87            if External_Source'Pos (N.Source) <
88               External_Source'Pos (Source)
89            then
90               if Current_Verbosity = High then
91                  Debug_Output
92                    ("Not overridding existing variable '" & External_Name
93                     & "', value was defined in " & N.Source'Img);
94               end if;
95               return;
96            end if;
97         end if;
98      end if;
99
100      Name_Len := Value'Length;
101      Name_Buffer (1 .. Name_Len) := Value;
102      N := new Name_To_Name'
103                 (Key    => Key,
104                  Source => Source,
105                  Value  => Name_Find,
106                  Next   => null);
107
108      if Current_Verbosity = High then
109         Debug_Output ("Add external (" & External_Name & ") is", N.Value);
110      end if;
111
112      Name_To_Name_HTable.Set (Self.Refs.all, N);
113   end Add;
114
115   -----------
116   -- Check --
117   -----------
118
119   function Check
120     (Self        : External_References;
121      Declaration : String) return Boolean
122   is
123   begin
124      for Equal_Pos in Declaration'Range loop
125         if Declaration (Equal_Pos) = '=' then
126            exit when Equal_Pos = Declaration'First;
127            Add
128              (Self          => Self,
129               External_Name =>
130                 Declaration (Declaration'First .. Equal_Pos - 1),
131               Value         =>
132                 Declaration (Equal_Pos + 1 .. Declaration'Last),
133               Source        => From_Command_Line);
134            return True;
135         end if;
136      end loop;
137
138      return False;
139   end Check;
140
141   -----------
142   -- Reset --
143   -----------
144
145   procedure Reset (Self : External_References) is
146   begin
147      if Self.Refs /= null then
148         Debug_Output ("Reset external references");
149         Name_To_Name_HTable.Reset (Self.Refs.all);
150      end if;
151   end Reset;
152
153   --------------
154   -- Value_Of --
155   --------------
156
157   function Value_Of
158     (Self          : External_References;
159      External_Name : Name_Id;
160      With_Default  : Name_Id := No_Name)
161      return          Name_Id
162   is
163      Value : Name_To_Name_Ptr;
164      Val   : Name_Id;
165      Name  : String := Get_Name_String (External_Name);
166
167   begin
168      Canonical_Case_Env_Var_Name (Name);
169
170      if Self.Refs /= null then
171         Name_Len := Name'Length;
172         Name_Buffer (1 .. Name_Len) := Name;
173         Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
174
175         if Value /= null then
176            Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
177            return Value.Value;
178         end if;
179      end if;
180
181      --  Find if it is an environment, if it is, put value in the hash table
182
183      declare
184         Env_Value : String_Access := Getenv (Name);
185
186      begin
187         if Env_Value /= null and then Env_Value'Length > 0 then
188            Name_Len := Env_Value'Length;
189            Name_Buffer (1 .. Name_Len) := Env_Value.all;
190            Val := Name_Find;
191
192            if Current_Verbosity = High then
193               Debug_Output ("Value_Of (" & Name & ") is", Val);
194            end if;
195
196            if Self.Refs /= null then
197               Value := new Name_To_Name'
198                 (Key    => External_Name,
199                  Value  => Val,
200                  Source => From_Environment,
201                  Next   => null);
202               Name_To_Name_HTable.Set (Self.Refs.all, Value);
203            end if;
204
205            Free (Env_Value);
206            return Val;
207
208         else
209            if Current_Verbosity = High then
210               Debug_Output
211                 ("Value_Of (" & Name & ") is default", With_Default);
212            end if;
213
214            Free (Env_Value);
215            return With_Default;
216         end if;
217      end;
218   end Value_Of;
219
220   ----------
221   -- Free --
222   ----------
223
224   procedure Free (Self : in out External_References) is
225      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
226        (Name_To_Name_HTable.Instance, Instance_Access);
227   begin
228      if Self.Refs /= null then
229         Reset (Self);
230         Unchecked_Free (Self.Refs);
231      end if;
232   end Free;
233
234   --------------
235   -- Set_Next --
236   --------------
237
238   procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
239   begin
240      E.Next := Next;
241   end Set_Next;
242
243   ----------
244   -- Next --
245   ----------
246
247   function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
248   begin
249      return E.Next;
250   end Next;
251
252   -------------
253   -- Get_Key --
254   -------------
255
256   function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
257   begin
258      return E.Key;
259   end Get_Key;
260
261end Prj.Ext;
262