1---------------------------------------------------------------------- 2-- Rules.Directly_Accessed_Globals - Package body -- 3-- -- 4-- This software is (c) CSEE and Adalog 2004-2006. The Ada -- 5-- Controller is free software; you can redistribute it and/or -- 6-- modify it under terms of the GNU General Public License as -- 7-- published by the Free Software Foundation; either version 2, or -- 8-- (at your option) any later version. This unit is distributed -- 9-- in the hope that it will be useful, but WITHOUT ANY WARRANTY; -- 10-- without even the implied warranty of MERCHANTABILITY or FITNESS -- 11-- FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 12-- for more details. You should have received a copy of the GNU -- 13-- General Public License distributed with this program; see file -- 14-- COPYING. If not, write to the Free Software Foundation, 59 -- 15-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- 16-- -- 17-- As a special exception, if other files instantiate generics -- 18-- from the units of this program, or if you link this unit with -- 19-- other files to produce an executable, this unit does not by -- 20-- itself cause the resulting executable to be covered by the GNU -- 21-- General Public License. This exception does not however -- 22-- invalidate any other reasons why the executable file might be -- 23-- covered by the GNU Public License. -- 24-- -- 25-- This software is distributed in the hope that it will be -- 26-- useful, but WITHOUT ANY WARRANTY; without even the implied -- 27-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- 28-- PURPOSE. -- 29---------------------------------------------------------------------- 30 31-- Ada 32with 33 Ada.Strings.Wide_Unbounded; 34 35-- Asis 36with 37 Asis.Declarations, 38 Asis.Elements, 39 Asis.Expressions; 40 41-- Adalog 42with 43 Binary_Map, 44 Thick_Queries, 45 Utilities; 46 47-- AdaControl 48with 49 Framework.Language; 50pragma Elaborate (Framework.Language); 51 52package body Rules.Directly_Accessed_Globals is 53 use Framework, Framework.Control_Manager; 54 55 type Filters is (F_Plain, F_Accept, F_Protected); 56 package Filter_Flags_Utilities is new Framework.Language.Flag_Utilities (Filters, "F_"); 57 use Filter_Flags_Utilities; 58 59 Rule_Used : Boolean := False; 60 Save_Used : Boolean; 61 Rule_Context : Basic_Rule_Context; 62 Flags : array (Filters) of Boolean := (others => False); 63 64 type Variable_Info is 65 record 66 Owner_Pack : Asis.Element; 67 Var_Loc : Location; 68 Read_Proc : Asis.Defining_Name; 69 Write_Proc : Asis.Defining_Name; 70 end record; 71 72 package Variables_Map is new Binary_Map 73 (Key_Type => Ada.Strings.Wide_Unbounded.Unbounded_Wide_String, 74 Value_Type => Variable_Info, 75 "<" => Ada.Strings.Wide_Unbounded."<", 76 ">" => Ada.Strings.Wide_Unbounded.">"); 77 78 Global_Variables : Variables_Map.Map; 79 80 ---------- 81 -- Help -- 82 ---------- 83 84 procedure Help is 85 use Utilities; 86 begin 87 User_Message ("Rule: " & Rule_Id); 88 User_Message ("Control global package variables accessed by other than dedicated subprograms"); 89 User_Message; 90 Help_On_Flags (Header => "Parameter(s):", Footer => "(optional)"); 91 end Help; 92 93 ----------------- 94 -- Add_Control -- 95 ----------------- 96 97 procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is 98 use Framework.Language, Utilities; 99 F : Filters; 100 begin 101 if Rule_Used then 102 Parameter_Error (Rule_Id, "this rule can be specified only once"); 103 end if; 104 105 if Parameter_Exists then 106 while Parameter_Exists loop 107 F := Get_Flag_Parameter (Allow_Any => False); 108 if Flags (F) then 109 Parameter_Error (Rule_Id, Image (F, Lower_Case) & " already given"); 110 end if; 111 Flags (F) := True; 112 end loop; 113 else 114 Flags := (others => True); 115 end if; 116 117 Rule_Context := Basic.New_Context (Ctl_Kind, Ctl_Label); 118 Rule_Used := True; 119 end Add_Control; 120 121 ------------- 122 -- Command -- 123 ------------- 124 125 procedure Command (Action : Framework.Rules_Manager.Rule_Action) is 126 use Framework.Rules_Manager; 127 begin 128 case Action is 129 when Clear => 130 Rule_Used := False; 131 Flags := (others => False); 132 when Suspend => 133 Save_Used := Rule_Used; 134 Rule_Used := False; 135 when Resume => 136 Rule_Used := Save_Used; 137 end case; 138 end Command; 139 140 ---------------------------------- 141 -- Process_Variable_Declaration -- 142 ---------------------------------- 143 144 procedure Process_Variable_Declaration (Decl : in Asis.Declaration) is 145 use Asis, Asis.Declarations, Asis.Elements; 146 use Ada.Strings.Wide_Unbounded, Thick_Queries, Utilities, Variables_Map; 147 begin 148 if not Rule_Used then 149 return; 150 end if; 151 Rules_Manager.Enter (Rule_Id); 152 153 if Declaration_Kind (Enclosing_Element (Decl)) /= A_Package_Body_Declaration then 154 return; 155 end if; 156 157 -- Note that since we are in a package /body/, the declaration is always processed 158 -- before any use. 159 declare 160 Name_List : constant Asis.Name_List := Names (Decl); 161 begin 162 for I in Name_List'Range loop 163 Add (Global_Variables, 164 To_Unbounded_Wide_String (To_Upper (Full_Name_Image (Name_List (I)))), 165 Variable_Info'(Owner_Pack => Enclosing_Element (Decl), 166 Var_Loc => Get_Location (Name_List (I)), 167 Read_Proc | Write_Proc => Nil_Element)); 168 end loop; 169 end; 170 end Process_Variable_Declaration; 171 172 ------------------------ 173 -- Process_Identifier -- 174 ------------------------ 175 176 procedure Process_Identifier (Name : in Asis.Expression) is 177 use Asis, Asis.Declarations, Asis.Elements, Asis.Expressions; 178 use Ada.Strings.Wide_Unbounded, Framework.Reports, Thick_Queries,Utilities, Variables_Map; 179 Good_Name : Asis.Expression; 180 Name_Decl : Asis.Declaration; 181 begin 182 if not Rule_Used then 183 return; 184 end if; 185 Rules_Manager.Enter (Rule_Id); 186 187 if Expression_Kind (Name) /= An_Identifier then 188 -- An_Operator_Symbol f.e., cannot be a variable 189 return; 190 end if; 191 192 Good_Name := Ultimate_Name (Name, No_Component => True); 193 if Is_Nil (Good_Name) then 194 -- Dynamic renaming... 195 Uncheckable (Rule_Id, 196 False_Negative, 197 Get_Location (Name), 198 "Name is dynamic renaming"); 199 return; 200 end if; 201 202 if Expression_Kind (Good_Name) = An_Attribute_Reference then 203 -- can happen when Name is a renaming of an attribute 204 -- certainly not a variable 205 return; 206 end if; 207 208 Name_Decl := Corresponding_Name_Declaration (Good_Name); 209 if Is_Nil (Name_Decl) then 210 -- Some predefined stuff... 211 return; 212 end if; 213 214 case Declaration_Kind (Name_Decl) is 215 when A_Variable_Declaration 216 | A_Single_Task_Declaration 217 | A_Single_Protected_Declaration 218 => 219 null; 220 when others => 221 -- Not a variable 222 return; 223 end case; 224 225 -- Here we have an acceptable variable 226 227 declare 228 Var_Name : constant Unbounded_Wide_String := To_Unbounded_Wide_String (To_Upper (Full_Name_Image (Good_Name))); 229 Var_Info : Variable_Info := Fetch (Global_Variables, Var_Name); 230 231 Usage : constant Expression_Usage_Kinds := Expression_Usage_Kind (Name); 232 233 Unit_Name : constant Asis.Defining_Name := Enclosing_Program_Unit (Name, Including_Accept => True); 234 Unit_Decl : constant Asis.Declaration := Enclosing_Element (Unit_Name); 235 Unit_Kind : constant Declaration_Kinds := Declaration_Kind (Unit_Decl) ; 236 237 Encl_Unit_Decl : Asis.Element; 238 begin 239 if Usage = Untouched then 240 -- Since we used Ultimate_Name, we won't be fooled by renamings. 241 -- => we can allow them at any place 242 return; 243 end if; 244 245 case Unit_Kind is 246 when A_Procedure_Body_Declaration 247 | A_Function_Body_Declaration 248 | An_Entry_Declaration -- Case of accept 249 | An_Entry_Body_Declaration -- Case of protected entry 250 => 251 null; 252 when others => 253 Report (Rule_Id, 254 Rule_Context, 255 Get_Location (Name), 256 "use of variable """ & Name_Image (Good_Name) & """ not from callable entity"); 257 return; 258 end case; 259 260 Encl_Unit_Decl := Enclosing_Element (Unit_Decl); 261 if Element_Kind (Encl_Unit_Decl) = A_Definition then 262 -- A_Task_Definition 263 Encl_Unit_Decl := Enclosing_Element (Encl_Unit_Decl); 264 end if; 265 case Declaration_Kind (Encl_Unit_Decl) is 266 when A_Single_Task_Declaration => 267 if not Flags (F_Accept) then 268 Report (Rule_Id, 269 Rule_Context, 270 Get_Location (Name), 271 "use of variable """ & Name_Image (Good_Name) & """ from accept"); 272 elsif not Is_Equal (Corresponding_Body (Enclosing_Element (Encl_Unit_Decl)), Var_Info.Owner_Pack) then 273 Report (Rule_Id, 274 Rule_Context, 275 Get_Location (Name), 276 "use of variable """ & Name_Image (Good_Name) & """ from nested task object"); 277 end if; 278 279 when A_Task_Type_Declaration => 280 if Flags (F_Accept) then 281 Report (Rule_Id, 282 Rule_Context, 283 Get_Location (Name), 284 "use of variable """ & Name_Image (Good_Name) & """ from accept of a task type"); 285 else 286 Report (Rule_Id, 287 Rule_Context, 288 Get_Location (Name), 289 "use of variable """ & Name_Image (Good_Name) & """ from accept"); 290 end if; 291 292 when A_Protected_Body_Declaration => 293 if not Flags (F_Protected) then 294 Report (Rule_Id, 295 Rule_Context, 296 Get_Location (Name), 297 "use of variable """ & Name_Image (Good_Name) 298 & """ from subprogram of a protected type or object"); 299 elsif Declaration_Kind (Corresponding_Declaration (Encl_Unit_Decl)) 300 /= A_Single_Protected_Declaration 301 then 302 Report (Rule_Id, 303 Rule_Context, 304 Get_Location (Name), 305 "use of variable """ 306 & Name_Image (Good_Name) 307 & """ from subprogram of a protected type"); 308 elsif not Is_Equal (Enclosing_Element (Encl_Unit_Decl), Var_Info.Owner_Pack) then 309 Report (Rule_Id, 310 Rule_Context, 311 Get_Location (Name), 312 "use of variable """ 313 & Name_Image (Good_Name) 314 & """ from nested protected object"); 315 end if; 316 317 when others => -- Plain 318 if not Flags (F_Plain) then 319 Report (Rule_Id, 320 Rule_Context, 321 Get_Location (Name), 322 "use of variable """ 323 & Name_Image (Good_Name) 324 & """ from a non-protected subprogram"); 325 elsif Declaration_Kind (Corresponding_Declaration (Unit_Decl)) in A_Generic_Declaration then 326 Report (Rule_Id, 327 Rule_Context, 328 Get_Location (Name), 329 "use of variable """ & Name_Image (Good_Name) & """ from generic subprogram"); 330 elsif not Is_Equal (Encl_Unit_Decl, Var_Info.Owner_Pack) then 331 Report (Rule_Id, 332 Rule_Context, 333 Get_Location (Name), 334 "use of variable """ & Name_Image (Good_Name) & """ from nested subprogram"); 335 end if; 336 end case; 337 338 case Usage is 339 when Untouched => 340 Failure ("Untouched did not return"); 341 342 when Read => 343 if Is_Nil (Var_Info.Read_Proc) then 344 Var_Info.Read_Proc := Unit_Name; 345 Add (Global_Variables, Var_Name, Var_Info); 346 elsif not Is_Equal (Var_Info.Read_Proc, Unit_Name) then 347 Report (Rule_Id, 348 Rule_Context, 349 Get_Location (Name), 350 "variable """ & Name_Image (Good_Name) 351 & """ is already read from " & Defining_Name_Image (Var_Info.Read_Proc) 352 & " at " & Image (Get_Location (Enclosing_Element (Var_Info.Read_Proc)))); 353 end if; 354 355 when Write => 356 if Is_Nil (Var_Info.Write_Proc) then 357 Var_Info.Write_Proc := Unit_Name; 358 Add (Global_Variables, Var_Name, Var_Info); 359 elsif not Is_Equal (Var_Info.Write_Proc, Unit_Name) then 360 Report (Rule_Id, 361 Rule_Context, 362 Get_Location (Name), 363 "variable """ & Name_Image (Good_Name) 364 & """ is already written from " & Defining_Name_Image (Var_Info.Write_Proc) 365 & " at " & Image (Get_Location (Enclosing_Element (Var_Info.Write_Proc)))); 366 end if; 367 368 when Read_Write 369 | Unknown -- Consider Unknown as Read-Write, therefore creating false positives 370 => -- That's better than false negatives! 371 if Usage = Unknown then 372 Uncheckable (Rule_Id, 373 False_Positive, 374 Get_Location (Name), 375 "variable """ & Name_Image (Good_Name) 376 & """ used as parameter of dispatching call, treated as in-out"); 377 end if; 378 379 if Is_Nil (Var_Info.Read_Proc) then 380 Var_Info.Read_Proc := Unit_Name; 381 Add (Global_Variables, Var_Name, Var_Info); 382 elsif not Is_Equal (Var_Info.Read_Proc, Unit_Name) then 383 Report (Rule_Id, 384 Rule_Context, 385 Get_Location (Name), 386 "variable """ & Name_Image (Good_Name) 387 & """ is already read from " & Defining_Name_Image (Var_Info.Read_Proc) 388 & " at " & Image (Get_Location (Enclosing_Element (Var_Info.Read_Proc)))); 389 end if; 390 391 if Is_Nil (Var_Info.Write_Proc) then 392 Var_Info.Write_Proc := Unit_Name; 393 Add (Global_Variables, Var_Name, Var_Info); 394 elsif not Is_Equal (Var_Info.Write_Proc, Unit_Name) then 395 Report (Rule_Id, 396 Rule_Context, 397 Get_Location (Name), 398 "variable """ & Name_Image (Good_Name) 399 & """ is already written from " & Defining_Name_Image (Var_Info.Write_Proc) 400 & " at " & Image (Get_Location (Enclosing_Element (Var_Info.Write_Proc)))); 401 end if; 402 end case; 403 end; 404 405 exception 406 when Not_Present => 407 -- From Fetch: this is not a package variable 408 return; 409 end Process_Identifier; 410 411 ------------------------------- 412 -- Post_Process_Package_Body -- 413 ------------------------------- 414 415 procedure Post_Process_Package_Body (Element : in Asis.Element) is 416 use Variables_Map, Ada.Strings.Wide_Unbounded; 417 418 procedure Check_One (Key : Unbounded_Wide_String; Var_Info : in out Variable_Info) is 419 use Asis.Elements; 420 use Framework.Reports, Utilities; 421 begin 422 if not Is_Equal (Var_Info.Owner_Pack, Element) then 423 -- Possible with nested packages 424 return; 425 end if; 426 427 if Is_Nil (Var_Info.Read_Proc) then 428 Report (Rule_Id, 429 Rule_Context, 430 Var_Info.Var_Loc, 431 "variable """ & To_Title (To_Wide_String (Key)) & """ is not read from any subprogram"); 432 end if; 433 434 if Is_Nil (Var_Info.Write_Proc) then 435 Report (Rule_Id, 436 Rule_Context, 437 Var_Info.Var_Loc, 438 "variable """ & To_Title (To_Wide_String (Key)) & """ is not written from any subprogram"); 439 end if; 440 441 -- Read_Proc/Write_Proc are the defining names of the procs 442 -- The Enclosing_Element is the declaration, whose Enclosing_Element is the package body 443 -- or protected body declaration. 444 -- Since we already checked that the procs that are not protected are declared immediately 445 -- within the same package as the variable, the bodies can be different only if the procs 446 -- come from different protected objects or tasks. 447 if (not Is_Nil (Var_Info.Read_Proc) and not Is_Nil (Var_Info.Write_Proc)) 448 and then not Is_Equal (Enclosing_Element (Enclosing_Element (Var_Info.Read_Proc)), 449 Enclosing_Element (Enclosing_Element (Var_Info.Write_Proc))) 450 then 451 Report (Rule_Id, 452 Rule_Context, 453 Var_Info.Var_Loc, 454 "variable """ & To_Title (To_Wide_String (Key)) 455 & """ is read and written from different protected objects or tasks"); 456 end if; 457 458 raise Delete_Current; 459 end Check_One; 460 461 procedure Check_All is new Variables_Map.Iterate (Check_One); 462 463 begin -- Post_Process_Package_Body 464 Check_All (Global_Variables); 465 end Post_Process_Package_Body; 466 467begin -- Rules.Directly_Accessed_Globals 468 Framework.Rules_Manager.Register (Rule_Id, 469 Rules_Manager.Semantic, 470 Help_CB => Help'Access, 471 Add_Control_CB => Add_Control'Access, 472 Command_CB => Command'Access); 473end Rules.Directly_Accessed_Globals; 474