1------------------------------------------------------------------------------ 2-- -- 3-- COMMON ASIS TOOLS COMPONENTS LIBRARY -- 4-- -- 5-- A S I S _ U L . G L O B A L _ S T A T E . D A T A -- 6-- B o d y -- 7-- -- 8-- Copyright (C) 2010-2013, AdaCore -- 9-- -- 10-- Asis Utility Library (ASIS UL) is free software; you can redistribute it -- 11-- and/or modify it under terms of the GNU General Public License as -- 12-- published by the Free Software Foundation; either version 2, or (at your -- 13-- option) any later version. ASIS UL is distributed in the hope that it -- 14-- will be useful, but WITHOUT ANY WARRANTY; without even the implied -- 15-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- 16-- GNU General Public License for more details. You should have received a -- 17-- copy of the GNU General Public License distributed with GNAT; see file -- 18-- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- 19-- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- 20-- -- 21-- ASIS UL is maintained by AdaCore (http://www.adacore.com). -- 22-- -- 23------------------------------------------------------------------------------ 24 25with Ada.Characters.Handling; use Ada.Characters.Handling; 26 27with Asis.Declarations; use Asis.Declarations; 28with Asis.Elements; use Asis.Elements; 29with Asis.Exceptions; use Asis.Exceptions; 30with Asis.Expressions; use Asis.Expressions; 31with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; 32with Asis.Statements; use Asis.Statements; 33with Asis.Extensions; use Asis.Extensions; 34with Asis.Extensions.Strings; use Asis.Extensions.Strings; 35 36with Asis.Set_Get; use Asis.Set_Get; 37 38with Atree; use Atree; 39with Sinfo; use Sinfo; 40with Einfo; use Einfo; 41 42with ASIS_UL.Utilities; use ASIS_UL.Utilities; 43 44package body ASIS_UL.Global_State.Data is 45 46 ------------------- 47 -- Is_Global_For -- 48 ------------------- 49 50 function Is_Global_For 51 (Scope : Scope_Id; 52 Node : GS_Node_Id) 53 return Boolean 54 is 55 Node_Encl_Scope : constant GS_Node_Id := GS_Node_Enclosing_Scope (Node); 56 Node_Scope_Level : constant Positive := 57 GS_Node_Scope_Level (Node_Encl_Scope); 58 59 Scope_Encl_Scope : GS_Node_Id; 60 Result : Boolean := False; 61 begin 62 63 pragma Assert (GS_Node_Scope_Level (Scope) > 0); 64 65 if GS_Node_Kind (Node_Encl_Scope) in Global_Nodes then 66 -- If variable is defined in a global scope (package or outter task 67 -- environment), it is global for any scope 68 Result := True; 69 elsif Node_Scope_Level < GS_Node_Scope_Level (Scope) then 70 Scope_Encl_Scope := GS_Node_Enclosing_Scope (Scope); 71 72 while GS_Node_Scope_Level (Scope_Encl_Scope) /= Node_Scope_Level loop 73 Scope_Encl_Scope := GS_Node_Enclosing_Scope (Scope_Encl_Scope); 74 end loop; 75 76 Result := Scope_Encl_Scope = Node_Encl_Scope; 77 78 end if; 79 80 return Result; 81 end Is_Global_For; 82 83 --------------------------------- 84 -- Is_Global_For_Current_Scope -- 85 --------------------------------- 86 87 function Is_Global_For_Current_Scope 88 (Def_Name : Asis.Element) 89 return Boolean 90 is 91 Result : Boolean := True; 92 Encl_Scope_Node : Node_Id := Scope (Node (Def_Name)); 93 Curr_Scope_Node : constant Node_Id := Current_Scope_Tree_Node; 94 begin 95 96 -- If the enclosing scope is a package or package body, all variables 97 -- defined in the package should be considered as global, because their 98 -- lifetime extends to the complete program execution 99 100 if Ekind (Encl_Scope_Node) = E_Package or else 101 Ekind (Encl_Scope_Node) = E_Generic_Package or else 102 Ekind (Encl_Scope_Node) = E_Package_Body 103 then 104 105 if Encl_Scope_Node = Curr_Scope_Node then 106 return True; 107 end if; 108 109 end if; 110 111 -- If Enclosing_Scope is a single task declaration, we may have to 112 -- adjust Encl_Scope_Node: for local entities declared in the package 113 -- body it will point to the artificial task type entity: 114 115 if Ekind (Encl_Scope_Node) = E_Task_Type 116 and then 117 not Comes_From_Source (Encl_Scope_Node) 118 then 119 Encl_Scope_Node := Corresponding_Body (Parent (Encl_Scope_Node)); 120 end if; 121 122 while Present (Encl_Scope_Node) loop 123 124 if Encl_Scope_Node = Curr_Scope_Node then 125 Result := False; 126 exit; 127 end if; 128 129 Encl_Scope_Node := Scope (Encl_Scope_Node); 130 end loop; 131 132 return Result; 133 end Is_Global_For_Current_Scope; 134 135 --------------------- 136 -- Store_Reference -- 137 --------------------- 138 139 procedure Store_Reference 140 (N : GS_Node_Id; 141 At_SLOC : String_Loc; 142 Reference_Kind : Reference_Kinds) 143 is 144 begin 145 146 if Reference_Kind = Read 147 or else 148 Reference_Kind = Read_Write 149 then 150 Add_Link_To_SLOC_List 151 (To_Node => Current_Scope, 152 To_List => Direct_Read_References, 153 Link_To_Add => (Node => N, SLOC => At_SLOC)); 154 155-- if GS_Node_Kind (Current_Scope) in Task_Nodes 156-- or else 157-- GS_Is_Foreign_Thread (Current_Scope) 158-- then 159-- Add_Node_To_List 160-- (To_Node => N, 161-- To_List => Direct_Read_References, 162-- Link_To_Add => (Node => Current_Scope, SLOC => At_SLOC)); 163-- end if; 164 165 end if; 166 167 if Reference_Kind = Write 168 or else 169 Reference_Kind = Read_Write 170 then 171 Add_Link_To_SLOC_List 172 (To_Node => Current_Scope, 173 To_List => Direct_Write_References, 174 Link_To_Add => (Node => N, SLOC => At_SLOC)); 175 176-- if GS_Node_Kind (Current_Scope) in Task_Nodes 177-- or else 178-- GS_Is_Foreign_Thread (Current_Scope) 179-- then 180-- Add_Node_To_List 181-- (To_Node => N, 182-- To_List => Direct_Write_References, 183-- Link_To_Add => (Node => Current_Scope, SLOC => At_SLOC)); 184-- end if; 185 186 end if; 187 188 end Store_Reference; 189 190 ------------------------ 191 -- Local subprograms -- 192 ------------------------ 193 194 function Get_Reference_Kind 195 (Identifier : Asis.Element) 196 return Reference_Kinds; 197 -- Checks if Identifier (that is supposed to be An_Identifier) Element is 198 -- read, write or read-write reference. Returns Not_A_Reference if 199 -- Identifier is not of An_Identifier kind. 200 -- 201 -- This function does not check if Identifier is indeed a reference to a 202 -- data object, this should be checked before the call. 203 204 ------------------------------- 205 -- Check_If_Global_Reference -- 206 ------------------------------- 207 208 procedure Check_If_Global_Reference 209 (Element : Asis.Element; 210 Definition : out Asis.Element; 211 Is_Global_Reference : out Boolean; 212 Can_Be_Accessed_By_Local_Task : out Boolean; 213 Reference_Kind : out Reference_Kinds; 214 Compute_Reference_Kind : Boolean := False) 215 is 216 Tmp : Asis.Element; 217-- Decl_Element : Asis.Element; 218 begin 219 -- This implementation does not care very much about performance... 220 221 Is_Global_Reference := False; 222 Can_Be_Accessed_By_Local_Task := False; 223 Reference_Kind := Not_A_Reference; 224 225 begin 226 if Flat_Element_Kind (Element) = A_Defining_Identifier then 227 -- For a variable declaration, the definition IS the element 228 Definition := Element; 229 else 230 Definition := Corresponding_Name_Definition (Element); 231 end if; 232 exception 233 when ASIS_Inappropriate_Element => 234 -- El is definitely not a reference to a variable! 235 return; 236 end; 237 238 if Defining_Name_Kind (Definition) /= A_Defining_Identifier 239 or else 240 Nkind (Node (Definition)) /= N_Defining_Identifier -- statememt names 241 or else 242 (Ekind (Node (Definition)) /= E_Variable and then 243 Ekind (Node (Definition)) /= E_Generic_In_Parameter and then 244 Ekind (Node (Definition)) /= E_Generic_In_Out_Parameter and then 245 Ekind (Node (Definition)) not in Formal_Kind) 246 then 247 -- This is also not a variable reference for sure 248 return; 249 end if; 250 251 -- Formal parameters are not enclosed in a surrounding declaration. 252 -- Treat them like variable declarations. 253 if Ekind (Node (Definition)) in Formal_Kind then 254 Is_Global_Reference := 255 (Is_Global_For_Current_Scope (Definition)); 256 else 257 258 Tmp := Enclosing_Element (Definition); 259 260 case Declaration_Kind (Tmp) is 261 when A_Variable_Declaration | 262 A_Formal_Object_Declaration => 263 264-- if not (Is_Concurrent (Definition) 265-- -- We do not count references to task or protected objects. 266-- or else 267-- Gnatcheck.ASIS_Utilities.Is_Volatile (Definition) 268-- or else 269-- Is_Atomic (Definition) 270-- or else 271-- Is_Reference_To_Councurrent_Component (Element)) 272-- then 273 Is_Global_Reference := 274 (Is_Global_For_Current_Scope (Definition)); 275 276-- if not Is_Global_Reference then 277-- Can_Be_Accessed_By_Local_Task := 278-- Can_Be_Accessed_By_Enclosed_Tasks (Tmp); 279-- end if; 280 281-- end if; 282 283 when An_Object_Renaming_Declaration => 284 285 -- We have to unwind the renaming in order to detect what data 286 -- object is really referenced. There are two specal situations 287 -- here: 288 -- 289 -- 1. The renamed object is a function call or a component 290 -- thereof. In this case we have a constant declaration, we 291 -- do not store this as a reference. 292 -- 293 -- 2. When unwinding renamings, we may go through some access 294 -- value(s). But here we do not care about indirect access 295 -- through the access values, the corresponding diagnostic 296 -- should be generated separately. 297 298 -- We have to unwind renaming by recursive calls to this 299 -- procedure, because Corresponding_Base_Entity stops if the 300 -- renaming object is a component of another object 301 302 Tmp := Corresponding_Base_Entity (Tmp); 303 304 case Expression_Kind (Tmp) is 305 306 when An_Identifier => 307 null; 308 when An_Explicit_Dereference | 309 An_Indexed_Component | 310 A_Slice | 311 An_Attribute_Reference => 312 Tmp := Prefix (Tmp); 313 314 when A_Type_Conversion => 315 Tmp := Converted_Or_Qualified_Expression (Tmp); 316 317 when A_Selected_Component => 318 -- In case of A.B we may have a component of A or an 319 -- expanded name of B 320 321 if Is_Component (Tmp) then 322 Tmp := Prefix (Tmp); 323 else 324 Tmp := Selector (Tmp); 325 end if; 326 327 when others => 328 -- Is_Global_Reference is False. 329 -- Here we have either impossible cases (such as an 330 -- aggregate) or cases that make this renaming a constant 331 -- declaration (such as a function call or an enumeration 332 -- literal). So: 333 return; 334 end case; 335 336 Check_If_Global_Reference 337 (Element => Tmp, 338 Definition => Definition, 339 Is_Global_Reference => Is_Global_Reference, 340 Can_Be_Accessed_By_Local_Task => Can_Be_Accessed_By_Local_Task, 341 Reference_Kind => Reference_Kind); 342 343 when A_Constant_Declaration | 344 -- we care about variables only! 345 A_Choice_Parameter_Specification | 346 A_Single_Task_Declaration | 347 A_Single_Protected_Declaration => 348 Is_Global_Reference := False; 349 when others => 350 pragma Assert (False); 351 null; 352 end case; 353 354 end if; 355 356 if (Is_Global_Reference 357 or else 358 Can_Be_Accessed_By_Local_Task) 359 and then 360 Compute_Reference_Kind 361 then 362 Reference_Kind := Get_Reference_Kind (Element); 363 end if; 364 365 end Check_If_Global_Reference; 366 367 ------------------------ 368 -- Get_Reference_Kind -- 369 ------------------------ 370 371 function Get_Reference_Kind 372 (Identifier : Asis.Element) 373 return Reference_Kinds 374 is 375 Result : Reference_Kinds := Not_A_Reference; 376 377 Enclosing : Asis.Element; 378 Enclosing_Old : Asis.Element := Identifier; 379 -- When going up the ASIS tree, 380 -- Enclosing = Enclosing_Element (Enclosing_Old) 381 382 begin 383 384 -- Variable declarations (at the package-level) should be counted as 385 -- writes when there is an initialization expression, and not at all 386 -- otherwise. 387 if Flat_Element_Kind (Identifier) = A_Defining_Identifier then 388 Enclosing := Enclosing_Element (Enclosing_Old); 389 390 if Flat_Element_Kind (Enclosing) = A_Variable_Declaration or else 391 Flat_Element_Kind (Enclosing) = A_Formal_Object_Declaration 392 then 393 if not Is_Nil (Initialization_Expression (Enclosing)) then 394 Result := Write; 395 end if; 396 -- else the declaration is not a reference 397 end if; 398 399 elsif Expression_Kind (Identifier) = An_Identifier then 400 Enclosing := Enclosing_Element (Enclosing_Old); 401 402 loop 403 404 case Flat_Element_Kind (Enclosing) is 405 406 when An_Assignment_Statement => 407 408 if Is_Equal 409 (Enclosing_Old, Assignment_Variable_Name (Enclosing)) 410 then 411 if Expression_Kind (Enclosing_Old) = An_Identifier then 412 Result := Write; 413 else 414 -- Update to a part of an aggregate counts as 415 -- read-write (useful for SPARK generation) 416 Result := Read_Write; 417 end if; 418 else 419 Result := Read; 420 end if; 421 422 exit; 423 424 when A_Parameter_Association => 425 Enclosing_Old := Enclosing; 426 Enclosing := Enclosing_Element (Enclosing_Old); 427 428 if Expression_Kind (Enclosing) = A_Function_Call then 429 Result := Read; 430 431 elsif Expression_Kind (Called_Name (Enclosing)) = 432 An_Attribute_Reference 433 then 434 Result := Read; 435 else 436 Enclosing := 437 Get_Parameter_Declaration (Enclosing_Old); 438 439 case Mode_Kind (Enclosing) is 440 when A_Default_In_Mode | 441 An_In_Mode => 442 Result := Read; 443 when An_Out_Mode => 444 Result := Write; 445 when An_In_Out_Mode => 446 Result := Read_Write; 447 when others => 448 null; 449 pragma Assert (False); 450 end case; 451 452 end if; 453 454 exit; 455 when Flat_Expression_Kinds => 456 457 case Expression_Kind (Enclosing) is 458 when An_Attribute_Reference => 459 460 if Attribute_Kind (Enclosing) = An_Access_Attribute 461 or else 462 (Attribute_Kind (Enclosing) = 463 An_Implementation_Defined_Attribute 464 and then 465 To_Lower (To_String 466 (Name_Image 467 (Attribute_Designator_Identifier 468 (Enclosing)))) = 469 "unrestricted_access") 470 then 471 -- An access value pointing to this object is 472 -- created, we have no idea how it is used, so: 473 Result := Read_Write; 474 else 475 -- For all other cases related to attributes, only 476 -- read access is possible 477 Result := Read; 478 end if; 479 480 exit; 481 482 when An_Indexed_Component => 483 -- If is is an index value - it is a read access 484 485 if not Is_Equal 486 (Prefix (Enclosing), Enclosing_Old) 487 then 488 Result := Read; 489 exit; 490 end if; 491 492 when A_Function_Call => 493 Result := Read; 494 exit; 495 when others => 496 -- Continue bottom-up traversal... 497 null; 498 end case; 499 500 when others => 501 Result := Read; 502 exit; 503 end case; 504 505 Enclosing_Old := Enclosing; 506 Enclosing := Enclosing_Element (Enclosing_Old); 507 end loop; 508 509 end if; 510 511 pragma Warnings (Off); 512 return Result; 513 pragma Warnings (On); 514 515 end Get_Reference_Kind; 516 517 ------------------------------ 518 -- Process_Global_Reference -- 519 ------------------------------ 520 521 procedure Process_Global_Reference 522 (Element : Asis.Element; 523 Definition : Asis.Element; 524 Reference_Kind : Reference_Kinds) 525-- Local_Var_Accessed_By_Local_Tasks : Boolean) 526 is 527 Encl_Element : constant Asis.Element := 528 Enclosing_Element (Enclosing_Element (Definition)); 529 Encl_Scope : Scope_Id; 530 Def_Node : GS_Node_Id; 531 begin 532 -- If the enclosing scope is a package or package body, use it 533 534 if Flat_Element_Kind (Encl_Element) = A_Package_Declaration 535 or else Flat_Element_Kind (Encl_Element) 536 = A_Generic_Package_Declaration 537 or else Flat_Element_Kind (Encl_Element) = A_Package_Body_Declaration 538 then 539 Encl_Scope := Corresponding_Node (Encl_Element); 540 else 541 Encl_Scope := No_Scope; 542 end if; 543 544 Def_Node := Corresponding_Node (Definition, Encl_Scope); 545 546 pragma Assert (Present (Def_Node)); 547 pragma Assert (Reference_Kind /= Not_A_Reference); 548 549-- if Local_Var_Accessed_By_Local_Tasks then 550-- Set_Is_Local_Var_Accessed_By_Local_Tasks (Def_Node); 551-- end if; 552 553 Store_Reference 554 (N => Def_Node, 555 At_SLOC => Build_GNAT_Location (Element), 556 Reference_Kind => Reference_Kind); 557 end Process_Global_Reference; 558 559end ASIS_UL.Global_State.Data; 560