1---------------------------------------------------------------------- 2-- Rules.Barrier_Expressions - Package body -- 3-- -- 4-- This software is (c) Adalog 2004-2005. The Ada Controller is -- 5-- free software; you can redistribute it and/or modify it under -- 6-- terms of the GNU General Public License as published by the -- 7-- Free Software Foundation; either version 2, or (at your option) -- 8-- any later version. This unit is distributed in the hope that -- 9-- it will be useful, but WITHOUT ANY WARRANTY; without even the -- 10-- implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- 11-- PURPOSE. See the GNU General Public License for more details. -- 12-- You should have received a copy of the GNU General Public -- 13-- License distributed with this program; see file COPYING. If -- 14-- not, write to the Free Software Foundation, 59 Temple Place - -- 15-- 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.Definitions, 39 Asis.Elements, 40 Asis.Expressions; 41 42-- Adalog 43with 44 Thick_Queries, 45 Utilities; 46 47-- AdaControl 48with 49 Framework.Language; 50pragma Elaborate (Framework.Language); 51 52package body Rules.Barrier_Expressions is 53 use Framework, Framework.Control_Manager; 54 55 type Keyword is (K_Entity, K_Allocation, K_Any_Component, 56 K_Any_Variable, K_Arithmetic_Operator, K_Array_Aggregate, 57 K_Comparison_Operator, K_Conversion, K_Dereference, 58 K_Indexing, K_Function_Attribute, K_Local_Function, 59 K_Logical_Operator, K_Record_Aggregate, K_Value_Attribute); 60 package Keyword_Flag_Utilities is new Framework.Language.Flag_Utilities (Keyword, "K_"); 61 62 -- In the following record, Types (K) is true if the check must be performed for K, 63 -- i.e. the <entity> is /not/ allowed for K 64 type Key_Context is new Root_Context with 65 record 66 Types : Control_Kinds_Set; 67 end record; 68 Contexts : Context_Store; 69 70 Rule_Used : Control_Kinds_Set := (others => False); 71 Save_Used : Control_Kinds_Set; 72 Labels : array (Control_Kinds) of Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; 73 74 ---------- 75 -- Help -- 76 ---------- 77 78 procedure Help is 79 use Utilities, Keyword_Flag_Utilities; 80 begin 81 User_Message ("Rule: " & Rule_Id); 82 User_Message ("Control constucts used in protected entry barriers"); 83 User_Message; 84 Help_On_Flags ("Parameter(s):", Extra_Value => "<entity>"); 85 end Help; 86 87 88 ----------------- 89 -- Add_Control -- 90 ----------------- 91 92 procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is 93 use Ada.Strings.Wide_Unbounded; 94 use Framework.Language, Keyword_Flag_Utilities, Utilities; 95 96 Key : Keyword; 97 Spec : Entity_Specification; 98 Cont : Key_Context; 99 begin 100 if Rule_Used (Ctl_Kind) then 101 Parameter_Error (Rule_Id, "rule already specified for " & To_Lower (Control_Kinds'Wide_Image (Ctl_Kind))); 102 end if; 103 Cont.Types := (others => True); 104 Cont.Types (Ctl_Kind) := False; 105 106 while Parameter_Exists loop 107 Key := Get_Flag_Parameter (Allow_Any => True); 108 109 if Key = K_Entity then 110 Spec := Get_Entity_Parameter; 111 else 112 Spec := Value (Image (Key)); 113 end if; 114 115 begin 116 Associate (Contexts, Spec, Cont); 117 exception 118 when Already_In_Store => 119 Cont := Key_Context (Association (Contexts, Spec)); 120 if Cont.Types (Ctl_Kind) then 121 Cont.Types (Ctl_Kind) := False; 122 Update (Contexts, Cont); 123 else 124 Parameter_Error (Rule_Id, "parameter already provided for " 125 & To_Lower (Control_Kinds'Wide_Image (Ctl_Kind)) 126 & ": " & Image (Spec)); 127 end if; 128 end; 129 end loop; 130 131 Labels (Ctl_Kind) := To_Unbounded_Wide_String (Ctl_Label); 132 Rule_Used (Ctl_Kind) := True; 133 end Add_Control; 134 135 136 ------------- 137 -- Command -- 138 ------------- 139 140 procedure Command (Action : in Framework.Rules_Manager.Rule_Action) is 141 use Framework.Rules_Manager; 142 begin 143 case Action is 144 when Clear => 145 Rule_Used := (others => False); 146 Clear (Contexts); 147 when Suspend => 148 Save_Used := Rule_Used; 149 Rule_Used := (others => False); 150 when Resume => 151 Rule_Used := Save_Used; 152 end case; 153 end Command; 154 155 156 ------------------------------- 157 -- Process_Entry_Declaration -- 158 ------------------------------- 159 160 procedure Process_Entry_Declaration (Decl : in Asis.Declaration) is 161 use Asis.Declarations; 162 163 procedure Check_Expression (Exp : in Asis.Expression) is 164 use Asis, Asis.Definitions, Asis.Elements, Asis.Expressions; 165 use Keyword_Flag_Utilities, Thick_Queries, Utilities; 166 167 procedure Do_Report (Message : in Wide_String; 168 Context : in Root_Context'Class; 169 Identifier : in Asis.Element := Nil_Element; 170 Loc : in Location := Get_Location (Exp)) 171 is 172 use Framework.Reports, Ada.Strings.Wide_Unbounded; 173 S : Control_Kinds_Set; 174 begin 175 if Context = No_Matching_Context then 176 if Is_Nil (Identifier) then 177 S := Rule_Used; 178 else 179 declare 180 Alternate_Context : constant Root_Context'Class 181 := Matching_Context (Contexts, Identifier, Extend_To => All_Extensions); 182 begin 183 if Alternate_Context = No_Matching_Context then 184 S := Rule_Used; 185 else 186 S := Key_Context (Alternate_Context).Types and Rule_Used; 187 end if; 188 end; 189 end if; 190 else 191 S := Key_Context (Context).Types and Rule_Used; 192 end if; 193 194 if S (Check) then 195 Report (Rule_Id, To_Wide_String (Labels (Check)), Check, Loc, Message); 196 elsif S (Search) then 197 Report (Rule_Id, To_Wide_String (Labels (Search)), Search, Loc, Message); 198 end if; 199 200 if S (Count) then 201 Report (Rule_Id, To_Wide_String (Labels (Count)), Count, Loc, ""); 202 end if; 203 end Do_Report; 204 205 begin -- Check_Expression 206 case Expression_Kind (Exp) is 207 when Not_An_Expression => 208 Failure (Rule_Id & ": Not_An_Expression"); 209 210 when An_Identifier => 211 declare 212 Used_Names : constant Asis.Expression_List := Used_Identifiers (Exp); 213 Name_Decl : Asis.Declaration; 214 begin 215 for N in Used_Names'Range loop 216 Name_Decl := Corresponding_Name_Declaration (Used_Names(N)); 217 case Declaration_Kind (Name_Decl) is 218 when A_Package_Declaration 219 | A_Package_Body_Declaration 220 | A_Package_Renaming_Declaration 221 => 222 -- Can appear only as prefix => Harmless 223 null; 224 when A_Function_Declaration 225 | An_Expression_Function_Declaration -- Ada 2012 226 | A_Function_Body_Declaration 227 | A_Function_Renaming_Declaration 228 => 229 -- Can be a call or a prefix, but the case of the call was handled as 230 -- A_Function_Call 231 null; 232 when A_Type_Declaration 233 | A_Subtype_Declaration 234 => 235 -- Can appear in a membership choice list 236 null; 237 when A_Variable_Declaration 238 | An_Object_Renaming_Declaration 239 | A_Single_Protected_Declaration 240 | A_Loop_Parameter_Specification -- Consider this (and next) as variables, 241 | An_Entry_Index_Specification -- although they are strictly speaking constants 242 => 243 Do_Report ("variable", 244 Control_Manager.Association (Contexts, Image (K_Any_Variable)), 245 Used_Names(N)); 246 when A_Component_Declaration => 247 -- This can be: 248 -- A component of a protected element: boolean fields always allowed, others checked 249 -- A component of a record type: nothing to check, the check is performed on the data 250 -- that encloses the component. 251 if Definition_Kind (Enclosing_Element (Name_Decl)) = A_Protected_Definition then 252 -- A field of the protected element, boolean fields always allowed 253 if To_Upper (Full_Name_Image 254 (Subtype_Simple_Name 255 (Component_Definition_View 256 (Object_Declaration_View (Name_Decl))))) 257 /= "STANDARD.BOOLEAN" 258 then 259 Do_Report ("non-boolean protected component", 260 Control_Manager.Association (Contexts, Image (K_Any_Component)), 261 Used_Names(N)); 262 end if; 263 end if; 264 when A_Constant_Declaration 265 | A_Number_Declaration 266 => 267 -- always allowed 268 null; 269 when others => 270 Failure (Rule_Id 271 & ": unexpected declaration kind " 272 & Declaration_Kinds'Wide_Image (Declaration_Kind (Name_Decl)), 273 Used_Names(N)); 274 end case; 275 end loop; 276 end; 277 when An_Integer_Literal 278 | A_String_Literal 279 | A_Real_Literal 280 | A_Character_Literal 281 | An_Enumeration_Literal 282 | A_Null_Literal 283 => 284 -- always allowed 285 null; 286 287 when An_Operator_Symbol => 288 -- Already handled as A_Function_Call 289 null; 290 291 when An_Attribute_Reference => 292 if Is_Callable_Construct (Exp) then 293 Do_Report ("callable attribute", 294 Control_Manager.Association (Contexts, Image (K_Function_Attribute)), 295 Exp); 296 else 297 Do_Report ("value attribute", 298 Control_Manager.Association (Contexts, Image (K_Value_Attribute)), 299 Exp); 300 end if; 301 302 when An_And_Then_Short_Circuit 303 | An_Or_Else_Short_Circuit 304 => 305 Do_Report ("short-circuit control form", 306 Control_Manager.Association (Contexts, Image (K_Logical_Operator)), 307 Loc => Get_Next_Word_Location (Short_Circuit_Operation_Left_Expression (Exp))); 308 309 -- Check left and right expressions 310 Check_Expression (Short_Circuit_Operation_Left_Expression (Exp)); 311 Check_Expression (Short_Circuit_Operation_Right_Expression (Exp)); 312 313 when A_Parenthesized_Expression => 314 -- Check the expression within parenthesis 315 Check_Expression (Expression_Parenthesized (Exp)); 316 317 when A_Record_Aggregate => 318 Do_Report ("record aggregate", 319 Control_Manager.Association (Contexts, Image (K_Record_Aggregate))); 320 321 -- Record_Component_Associations + Record_Component_Choices/Component_Expression 322 declare 323 Record_Associations : constant Asis.Association_List := Record_Component_Associations (Exp); 324 begin 325 for Assoc in Record_Associations'Range loop 326 Check_Expression (Component_Expression (Record_Associations (Assoc))); 327 end loop; 328 end; 329 330 when An_Extension_Aggregate => 331 Do_Report ("record extension", 332 Control_Manager.Association (Contexts, Image (K_Record_Aggregate))); 333 334 -- Extension_Aggregate_Expression 335 -- Record_Component_Associations + Record_Component_Choices/Component_Expression 336 Check_Expression (Extension_Aggregate_Expression (Exp)); 337 declare 338 Record_Associations : constant Asis.Association_List := 339 Record_Component_Associations (Exp); 340 begin 341 for Assoc in Record_Associations'Range loop 342 Check_Expression (Component_Expression (Record_Associations (Assoc))); 343 end loop; 344 end; 345 346 when A_Positional_Array_Aggregate 347 | A_Named_Array_Aggregate 348 => 349 Do_Report ("array aggregate", 350 Control_Manager.Association (Contexts, Image (K_Array_Aggregate))); 351 352 -- Array_Component_Associations + Array_Component_Choices/Component_Expression 353 declare 354 Array_Associations : constant Asis.Association_List := 355 Array_Component_Associations (Exp); 356 begin 357 for Assoc in Array_Associations'Range loop 358 declare 359 Choices : constant Asis.Element_List := 360 Array_Component_Choices (Array_Associations (Assoc)); 361 Choice : Asis.Element; 362 begin 363 for Choice_Index in Choices'Range loop 364 Choice := Choices (Choice_Index); 365 if not Is_Nil (Choice) then 366 case Element_Kind (Choice) is 367 when An_Expression => 368 Check_Expression (Choice); 369 when A_Definition => 370 case Definition_Kind (Choice) is 371 when An_Others_Choice => 372 null; 373 when A_Discrete_Range => 374 case Discrete_Range_Kind (Choice) is 375 when Not_A_Discrete_Range => 376 Failure (Rule_Id & ": Array_Aggregate . Discrete_Range_Kind"); 377 when A_Discrete_Subtype_Indication 378 | A_Discrete_Range_Attribute_Reference 379 => 380 null; 381 when A_Discrete_Simple_Expression_Range => 382 Check_Expression (Lower_Bound (Choice)); 383 Check_Expression (Upper_Bound (Choice)); 384 end case; 385 when others => 386 Failure (Rule_Id & ": Array_Aggregate . Definition_Kind"); 387 end case; 388 when others => 389 Failure (Rule_Id & ": Array_Aggregate . Element_Kind"); 390 end case; 391 end if; 392 end loop; 393 end; 394 Check_Expression (Component_Expression (Array_Associations (Assoc))); 395 end loop; 396 end; 397 398 when An_In_Membership_Test 399 | A_Not_In_Membership_Test 400 => 401 Do_Report ("membership test", 402 Control_Manager.Association (Contexts, Image (K_Logical_Operator)), 403 Loc => Get_Next_Word_Location (Membership_Test_Expression (Exp))); 404 405 -- Check both tested expression and each membership choice 406 Check_Expression (Membership_Test_Expression (Exp)); 407 declare 408 Choices : constant Asis.Element_List := Membership_Test_Choices (Exp); 409 begin 410 for C in Choices'Range loop 411 if Element_Kind (Choices (C)) = An_Expression then 412 Check_Expression (Choices (C)); 413 else 414 -- A range 415 case Constraint_Kind (Choices (C)) is 416 when A_Range_Attribute_Reference => 417 null; 418 when A_Simple_Expression_Range => 419 Check_Expression (Lower_Bound (Choices (C))); 420 Check_Expression (Upper_Bound (Choices (C))); 421 when others => 422 Failure (Rule_Id & ": Membership_Test_Range => invalid Constraint_Kind"); 423 end case; 424 end if; 425 end loop; 426 end; 427 428 when An_Indexed_Component => 429 Do_Report ("indexing", 430 Control_Manager.Association (Contexts, Image (K_Indexing))); 431 432 -- Check for implicit dereference 433 if Is_Access_Expression (Prefix (Exp)) then 434 Do_Report ("dereference", 435 Control_Manager.Association (Contexts, Image (K_Dereference))); 436 end if; 437 -- Check both prefix and indexes of the component 438 Check_Expression (Prefix (Exp)); 439 declare 440 Indexes : constant Asis.Expression_List := Index_Expressions (Exp); 441 begin 442 for I in Indexes'Range loop 443 Check_Expression (Indexes (I)); 444 end loop; 445 end; 446 447 when A_Slice => 448 Do_Report ("slice", 449 Control_Manager.Association (Contexts, Image (K_Indexing))); 450 451 -- Check for implicit dereference 452 if Is_Access_Expression (Prefix (Exp)) then 453 Do_Report ("dereference", 454 Control_Manager.Association (Contexts, Image (K_Dereference))); 455 end if; -- Check both slice prefix and range 456 Check_Expression (Prefix (Exp)); 457 declare 458 The_Range : constant Asis.Discrete_Range := Slice_Range (Exp); 459 begin 460 case Discrete_Range_Kind (The_Range) is 461 when Not_A_Discrete_Range => 462 Failure (Rule_Id & ": Slice_Range => Not_A_Discrete_Range"); 463 when A_Discrete_Subtype_Indication 464 | A_Discrete_Range_Attribute_Reference 465 => 466 null; 467 when A_Discrete_Simple_Expression_Range => 468 Check_Expression (Lower_Bound (The_Range)); 469 Check_Expression (Upper_Bound (The_Range)); 470 end case; 471 end; 472 473 when A_Selected_Component => 474 -- Check for implicit dereference 475 if Is_Access_Expression (Prefix (Exp)) then 476 Do_Report ("dereference", 477 Control_Manager.Association (Contexts, Image (K_Dereference))); 478 end if; 479 -- Check both prefix and selector 480 Check_Expression (Prefix (Exp)); 481 Check_Expression (Selector (Exp)); 482 483 when A_Function_Call => 484 -- Checks about the call itself 485 declare 486 Called : constant Call_Descriptor := Corresponding_Call_Description (Exp); 487 begin 488 case Called.Kind is 489 when A_Regular_Call => 490 if Definition_Kind (Enclosing_Element (Called.Declaration)) = A_Protected_Definition 491 and then Is_Nil (External_Call_Target (Exp)) 492 then 493 -- It is a call to a protected function of the same PO 494 Do_Report ("local function call", 495 Control_Manager.Association (Contexts, Image (K_Local_Function)), 496 Called_Simple_Name (Exp)); 497 else 498 Do_Report ("non-local function call", Matching_Context (Contexts, 499 Called_Simple_Name (Exp), 500 Extend_To => All_Extensions)); 501 end if; 502 when A_Predefined_Entity_Call => 503 case Operator_Kind (Called_Simple_Name (Exp)) is 504 when Not_An_Operator => 505 Failure (Rule_Id & ": Not_An_Operator"); 506 when An_And_Operator 507 | An_Or_Operator 508 | An_Xor_Operator 509 | A_Not_Operator 510 => 511 Do_Report ("predefined logical operator", 512 Control_Manager.Association (Contexts, Image (K_Logical_Operator)), 513 Loc => Get_Location (Prefix (Exp))); 514 when An_Equal_Operator 515 | A_Not_Equal_Operator 516 | A_Less_Than_Operator 517 | A_Less_Than_Or_Equal_Operator 518 | A_Greater_Than_Operator 519 | A_Greater_Than_Or_Equal_Operator 520 => 521 Do_Report ("predefined comparison operator", 522 Control_Manager.Association (Contexts, Image (K_Comparison_Operator)), 523 Loc => Get_Location (Prefix (Exp))); 524 when others => 525 Do_Report ("predefined arithmetic operator", 526 Control_Manager.Association (Contexts, Image (K_Arithmetic_Operator)), 527 Loc => Get_Location (Prefix (Exp))); 528 end case; 529 530 when An_Attribute_Call => 531 -- Will handle it when traversing the prefix (because we need to handle value 532 -- attributes anyway) 533 null; 534 535 when A_Dereference_Call => 536 Do_Report ("dereference", 537 Control_Manager.Association (Contexts, Image (K_Dereference))); 538 539 when A_Dispatching_Call => 540 -- Same as regular call 541 Do_Report ("non-local function call", Matching_Context (Contexts, Called_Simple_Name (Exp))); 542 543 when An_Enumeration_Literal => 544 -- Allways allowed 545 null; 546 end case; 547 548 end; 549 -- Check prefix 550 Check_Expression (Prefix (Exp)); 551 -- Check each parameter 552 declare 553 Parameters : constant Asis.Association_List := Function_Call_Parameters (Exp); 554 begin 555 for Index in Parameters'Range loop 556 Check_Expression (Actual_Parameter (Parameters (Index))); 557 end loop; 558 end; 559 560 when An_Explicit_Dereference => 561 Do_Report ("dereference", 562 Control_Manager.Association (Contexts, Image (K_Dereference))); 563 Check_Expression (Prefix (Exp)); 564 565 when A_Type_Conversion 566 | A_Qualified_Expression 567 => 568 Do_Report ("conversion or qualified expression", 569 Control_Manager.Association (Contexts, Image (K_Conversion))); 570 Check_Expression (Converted_Or_Qualified_Expression (Exp)); 571 572 when An_Allocation_From_Subtype => 573 Do_Report ("allocation", 574 Control_Manager.Association (Contexts, Image (K_Allocation))); 575 576 when An_Allocation_From_Qualified_Expression => 577 Do_Report ("allocation", 578 Control_Manager.Association (Contexts, Image (K_Allocation))); 579 Check_Expression (Allocator_Qualified_Expression (Exp)); 580 581 pragma Warnings(Off); -- others covers nothing for versions of gnat that do not support the extension 582 when others => 583 -- Corresponds to GNAT extension: A_Conditional_Expression 584 Reports.Uncheckable (Rule_Id, False_Negative, Get_Location (Exp), "Use of compiler specific extension"); 585 pragma Warnings (On); 586 end case; 587 end Check_Expression; 588 589 590 begin -- Process_Entry_Declaration 591 if Rule_Used = (Control_Kinds => False) then 592 return; 593 end if; 594 Rules_Manager.Enter (Rule_Id); 595 596 Check_Expression (Entry_Barrier (Decl)); 597 end Process_Entry_Declaration; 598 599begin -- Rules.Barrier_Expressions 600 Framework.Rules_Manager.Register (Rule_Id, 601 Rules_Manager.Semantic, 602 Help_CB => Help'Access, 603 Add_Control_CB => Add_Control'Access, 604 Command_CB => Command'Access); 605end Rules.Barrier_Expressions; 606