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