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