1------------------------------------------------------------------------------ 2-- -- 3-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- 4-- -- 5-- A S I S . A D A _ E N V I R O N M E N T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- 10-- -- 11-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 3, or (at your option) any later -- 14-- version. ASIS-for-GNAT is distributed in the hope that it will be -- 15-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- -- 19-- -- 20-- -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception distributed with GNAT; see -- 24-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- 28-- Software Engineering Laboratory of the Swiss Federal Institute of -- 29-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- 30-- Scientific Research Computer Center of Moscow State University (SRCC -- 31-- MSU), Russia, with funding partially provided by grants from the Swiss -- 32-- National Science Foundation and the Swiss Academy of Engineering -- 33-- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- 34-- (http://www.adaccore.com). -- 35-- -- 36------------------------------------------------------------------------------ 37 38with Ada.Characters.Handling; use Ada.Characters.Handling; 39with Ada.Strings; use Ada.Strings; 40with Ada.Strings.Fixed; use Ada.Strings.Fixed; 41 42with Asis.Errors; use Asis.Errors; 43with Asis.Exceptions; use Asis.Exceptions; 44 45with Asis.Set_Get; use Asis.Set_Get; 46 47with A4G.A_Debug; use A4G.A_Debug; 48with A4G.A_Opt; use A4G.A_Opt; 49with A4G.A_Output; use A4G.A_Output; 50with A4G.Contt; use A4G.Contt; 51with A4G.Contt.TT; use A4G.Contt.TT; 52with A4G.Contt.UT; use A4G.Contt.UT; 53with A4G.EE_Cache; use A4G.EE_Cache; 54with A4G.GNAT_Int; 55with A4G.Vcheck; use A4G.Vcheck; 56 57with Output; use Output; 58 59package body Asis.Ada_Environments is 60 61 Package_Name : constant String := "Asis.Ada_Environments."; 62 63 --------------- 64 -- Associate -- 65 --------------- 66 67 procedure Associate 68 (The_Context : in out Asis.Context; 69 Name : Wide_String; 70 Parameters : Wide_String := Default_Parameters) 71 is 72 S_Parameters : constant String := Trim (To_String (Parameters), Both); 73 Cont : Context_Id; 74 begin 75 76 Cont := Get_Cont_Id (The_Context); 77 78 if not A4G.A_Opt.Is_Initialized then 79 80 Set_Error_Status 81 (Status => Initialization_Error, 82 Diagnosis => Package_Name & "Associate: " 83 & "called for non-initialized ASIS"); 84 85 raise ASIS_Failed; 86 87 end if; 88 89 if Is_Opened (Cont) then 90 Set_Error_Status 91 (Status => Value_Error, 92 Diagnosis => Package_Name & "Associate: " 93 & "the Context has already been opened"); 94 raise ASIS_Inappropriate_Context; 95 end if; 96 97 if Cont = Non_Associated then 98 -- this is the first association for a given Context 99 Cont := Allocate_New_Context; 100 Set_Cont (The_Context, Cont); 101 else 102 Erase_Old (Cont); 103 end if; 104 105 Verify_Context_Name (To_String (Name), Cont); 106 Process_Context_Parameters (S_Parameters, Cont); 107 108 Set_Is_Associated (Cont, True); 109 110 Save_Context (Cont); 111 Set_Current_Cont (Nil_Context_Id); 112 113 exception 114 when ASIS_Inappropriate_Context => 115 Set_Is_Associated (Cont, False); 116 raise; 117 when ASIS_Failed => 118 Set_Is_Associated (Cont, False); 119 120 if Status_Indicator = Unhandled_Exception_Error then 121 Add_Call_Information (Outer_Call => Package_Name & "Associate"); 122 end if; 123 124 raise; 125 when Ex : others => 126 Set_Is_Associated (Cont, False); 127 128 Report_ASIS_Bug 129 (Query_Name => Package_Name & "Associate", 130 Ex => Ex); 131 end Associate; 132 133 ----------- 134 -- Close -- 135 ----------- 136 137 procedure Close (The_Context : in out Asis.Context) is 138 Cont : Context_Id; 139 begin 140 Cont := Get_Cont_Id (The_Context); 141 Reset_Context (Cont); 142 143 if not Is_Opened (Cont) then 144 Set_Error_Status (Status => Value_Error, 145 Diagnosis => Package_Name & "Close: " & 146 "the Context is not open"); 147 raise ASIS_Inappropriate_Context; 148 end if; 149 150 if Debug_Flag_C or else 151 Debug_Lib_Model or else 152 Debug_Mode 153 then 154 Write_Str ("Closing Context "); 155 Write_Int (Int (Cont)); 156 Write_Eol; 157 Print_Units (Cont); 158 Print_Trees (Cont); 159 end if; 160 161 Set_Is_Opened (Cont, False); 162 163 Set_Current_Cont (Nil_Context_Id); 164 165 Reset_Cache; 166 167 exception 168 when ASIS_Inappropriate_Context => 169 raise; 170 when ASIS_Failed => 171 Set_Current_Cont (Nil_Context_Id); 172 173 if Status_Indicator = Unhandled_Exception_Error then 174 Add_Call_Information (Outer_Call => Package_Name & "Close"); 175 end if; 176 177 raise; 178 when Ex : others => 179 Set_Current_Cont (Nil_Context_Id); 180 Report_ASIS_Bug 181 (Query_Name => Package_Name & "Associate", 182 Ex => Ex); 183 end Close; 184 185 ----------------- 186 -- Debug_Image -- 187 ----------------- 188 189 function Debug_Image 190 (The_Context : Asis.Context) 191 return Wide_String 192 is 193 Arg_Cont : Context_Id; 194 LT : Wide_String renames A4G.A_Types.Asis_Wide_Line_Terminator; 195 begin 196 Arg_Cont := Get_Cont_Id (The_Context); 197 Reset_Context (Arg_Cont); 198 199 return LT & "Context Debug_Image: " & 200 LT & "Context Id is" & 201 Context_Id'Wide_Image (Arg_Cont) & 202 LT & To_Wide_String (Debug_String (The_Context)); 203 exception 204 when Ex : others => 205 Report_ASIS_Bug 206 (Query_Name => Package_Name & "Debug_Image", 207 Ex => Ex); 208 end Debug_Image; 209 210 ------------------ 211 -- Default_Name -- 212 ------------------ 213 214 function Default_Name return Wide_String is 215 begin 216 return Nil_Asis_Wide_String; 217 end Default_Name; 218 219 ------------------------ 220 -- Default_Parameters -- 221 ------------------------ 222 223 function Default_Parameters return Wide_String is 224 begin 225 return Nil_Asis_Wide_String; 226 end Default_Parameters; 227 228 ---------------- 229 -- Dissociate -- 230 ---------------- 231 232 procedure Dissociate (The_Context : in out Asis.Context) is 233 Cont : Context_Id; 234 begin 235 Cont := Get_Cont_Id (The_Context); 236 237 if Is_Opened (Cont) then 238 Set_Error_Status (Status => Value_Error, 239 Diagnosis => Package_Name & "Dissociate: " 240 & "the Context is open"); 241 raise ASIS_Inappropriate_Context; 242 end if; 243 244 if Debug_Flag_C or else 245 Debug_Lib_Model or else 246 Debug_Mode 247 then 248 Write_Str ("Dissociating Context "); 249 Write_Int (Int (Cont)); 250 Write_Eol; 251 Print_Context_Parameters (Cont); 252 end if; 253 254 if Is_Associated (Cont) then 255 Erase_Old (Cont); 256 Set_Is_Associated (Cont, False); 257 end if; 258 259 exception 260 when ASIS_Inappropriate_Context => 261 raise; 262 when ASIS_Failed => 263 264 if Status_Indicator = Unhandled_Exception_Error then 265 Add_Call_Information (Outer_Call => Package_Name & "Dissociate"); 266 end if; 267 268 raise; 269 when Ex : others => 270 Report_ASIS_Bug 271 (Query_Name => Package_Name & "Dissociate", 272 Ex => Ex); 273 end Dissociate; 274 275 ------------ 276 -- Exists -- 277 ------------ 278 279 function Exists (The_Context : Asis.Context) return Boolean is 280 Cont : Context_Id; 281 begin 282 Cont := Get_Cont_Id (The_Context); 283 return Is_Associated (Cont); 284 end Exists; 285 286 ---------------------- 287 -- Has_Associations -- 288 ---------------------- 289 290 function Has_Associations 291 (The_Context : Asis.Context) 292 return Boolean 293 is 294 Cont : Context_Id; 295 begin 296 Cont := Get_Cont_Id (The_Context); 297 return Is_Associated (Cont); 298 end Has_Associations; 299 300 -------------- 301 -- Is_Equal -- 302 -------------- 303 304 function Is_Equal 305 (Left : Asis.Context; 306 Right : Asis.Context) 307 return Boolean 308 is 309 begin 310 return Get_Cont_Id (Left) = Get_Cont_Id (Right); 311 -- Should be revised 312 end Is_Equal; 313 314 ------------------ 315 -- Is_Identical -- 316 ------------------ 317 318 function Is_Identical 319 (Left : Asis.Context; 320 Right : Asis.Context) 321 return Boolean 322 is 323 begin 324 return Get_Cont_Id (Left) = Get_Cont_Id (Right); 325 end Is_Identical; 326 327 ------------- 328 -- Is_Open -- 329 ------------- 330 331 function Is_Open (The_Context : Asis.Context) return Boolean is 332 Cont : Context_Id; 333 begin 334 Cont := Get_Cont_Id (The_Context); 335 return Is_Opened (Cont); 336 end Is_Open; 337 338 ---------- 339 -- Name -- 340 ---------- 341 342 function Name (The_Context : Asis.Context) return Wide_String is 343 Cont : Context_Id; 344 begin 345 Cont := Get_Cont_Id (The_Context); 346 return To_Wide_String (Get_Context_Name (Cont)); 347 end Name; 348 349 ---------- 350 -- Open -- 351 ---------- 352 353 procedure Open (The_Context : in out Asis.Context) is 354 Cont : Context_Id; 355 Context_Tree_Mode : Tree_Mode; 356 begin 357 Cont := Get_Cont_Id (The_Context); 358 359 if not Is_Associated (Cont) then 360 Set_Error_Status (Status => Value_Error, 361 Diagnosis => Package_Name & "Open: " & 362 "the Context does not have association"); 363 raise ASIS_Inappropriate_Context; 364 elsif Is_Opened (Cont) then 365 Set_Error_Status (Status => Value_Error, 366 Diagnosis => Package_Name & "Open: " & 367 "the Context has already been opened"); 368 raise ASIS_Inappropriate_Context; 369 end if; 370 371 if Cache_EE_Results then 372 Init_EE_Cache; 373 end if; 374 375 Reset_Context (Cont); 376 Context_Tree_Mode := Tree_Processing_Mode (Cont); 377 378 if Tree_Processing_Mode (Cont) = GNSA then 379 Set_Error_Status (Status => Use_Error, 380 Diagnosis => Package_Name & "Open: " & 381 "GNSA Context mode is not allowed"); 382 raise ASIS_Inappropriate_Context; 383 end if; 384 385 Increase_ASIS_OS_Time; 386 387 Pre_Initialize (Cont); 388 A4G.Contt.Initialize (Cont); 389 -- Having these two Pre_Initialize and A4G.Contt.Initialize calling 390 -- one after another is a kind of junk, but there are some problems 391 -- with multi-context processing which have not been completely 392 -- detected and which does not allow to get rid of this definitely 393 -- redundunt "initialization" 394 395 case Context_Tree_Mode is 396 when Pre_Created | Mixed => 397 Scan_Trees_New (Cont); 398 399 when Incremental => 400 401 -- Not the best approach, unfortunately 402 begin 403 Scan_Trees_New (Cont); 404 exception 405 when Inconsistent_Incremental_Context => 406 -- Setting empty incremental context: 407 Pre_Initialize (Cont); 408 A4G.Contt.Initialize (Cont); 409 end; 410 411 when others => 412 null; 413 end case; 414 415 Set_Is_Opened (Cont, True); 416 417 Save_Context (Cont); 418 419 Set_Current_Cont (Nil_Context_Id); 420 421 exception 422 when A4G.GNAT_Int.Version_Mismatch | ASIS_Inappropriate_Context => 423 raise; 424 when ASIS_Failed => 425 Set_Is_Opened (Cont, False); 426 Set_Current_Cont (Nil_Context_Id); 427 428 if Status_Indicator = Unhandled_Exception_Error then 429 Add_Call_Information (Outer_Call => Package_Name & "Open"); 430 end if; 431 432 raise; 433 when Ex : others => 434 Set_Is_Opened (Cont, False); 435 Set_Current_Cont (Nil_Context_Id); 436 437 Report_ASIS_Bug 438 (Query_Name => Package_Name & "Open", 439 Ex => Ex); 440 end Open; 441 442 ---------------- 443 -- Parameters -- 444 ---------------- 445 446 function Parameters (The_Context : Asis.Context) return Wide_String is 447 Cont : Context_Id; 448 begin 449 Cont := Get_Cont_Id (The_Context); 450 return To_Wide_String (Get_Context_Parameters (Cont)); 451 end Parameters; 452 453end Asis.Ada_Environments; 454