1---------------------------------------------------------------------- 2-- Rules.Case_Statement - Package body -- 3-- -- 4-- This software is (c) The European Organisation for the Safety -- 5-- of Air Navigation (EUROCONTROL) and Adalog 2004-2005. The Ada -- 6-- Controller is free software; you can redistribute it and/or -- 7-- modify it under terms of the GNU General Public License as -- 8-- published by the Free Software Foundation; either version 2, or -- 9-- (at your option) any later version. This unit is distributed -- 10-- in the hope that it will be useful, but WITHOUT ANY WARRANTY; -- 11-- without even the implied warranty of MERCHANTABILITY or FITNESS -- 12-- FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 13-- for more details. You should have received a copy of the GNU -- 14-- General Public License distributed with this program; see file -- 15-- COPYING. If not, write to the Free Software Foundation, 59 -- 16-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- 17-- -- 18-- As a special exception, if other files instantiate generics -- 19-- from the units of this program, or if you link this unit with -- 20-- other files to produce an executable, this unit does not by -- 21-- itself cause the resulting executable to be covered by the GNU -- 22-- General Public License. This exception does not however -- 23-- invalidate any other reasons why the executable file might be -- 24-- covered by the GNU Public License. -- 25-- -- 26-- This software is distributed in the hope that it will be -- 27-- useful, but WITHOUT ANY WARRANTY; without even the implied -- 28-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- 29-- PURPOSE. -- 30---------------------------------------------------------------------- 31-- Ada 32with 33 Ada.Strings.Wide_Unbounded; 34 35-- Asis 36with 37 Asis.Declarations, 38 Asis.Elements, 39 Asis.Statements; 40 41-- Adalog 42with 43 A4G_Bugs, 44 Thick_Queries, 45 Utilities; 46 47-- Adactl 48with 49 Framework.Language, 50 Framework.Language.Shared_Keys; 51pragma Elaborate (Framework.Language); 52 53package body Rules.Case_Statement is 54 55 use Asis, Framework, Thick_Queries; 56 57 type Subrules is (Others_Span, Paths, Range_Span, Values, Values_If_Others); 58 package Subrules_Flag_Utilities is new Framework.Language.Flag_Utilities (Subrules); 59 60 type Usage is array (Subrules) of Control_Kinds_Set; 61 Rule_Used : Usage := (others => (others => False)); 62 Save_Used : Usage; 63 64 Labels : array (Subrules, Control_Kinds) of Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; 65 66 Bounds : array (Subrules, Control_Kinds) of Framework.Language.Shared_Keys.Bounds_Values 67 := (others => (others => (0, 0))); 68 69 ---------- 70 -- Help -- 71 ---------- 72 73 procedure Help is 74 use Utilities, Framework.Language.Shared_Keys; 75 begin 76 User_Message ("Rule: "& Rule_Id); 77 User_Message ("Controls various sizes related to the case statement"); 78 User_Message; 79 Subrules_Flag_Utilities.Help_On_Flags (Header => "Parameter(1) :"); 80 User_Message ("Parameter(2..3): <bound> <value>"); 81 User_Message (" (at least one parameter required)"); 82 Help_On_Bounds (Header => "<bound>: "); 83 end Help; 84 85 ----------------- 86 -- Add_Control -- 87 ----------------- 88 89 procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is 90 use Framework.Language, Framework.Language.Shared_Keys, Subrules_Flag_Utilities; 91 use Ada.Strings.Wide_Unbounded; 92 93 Subrule_Name : Subrules; 94 begin 95 if not Parameter_Exists then 96 Parameter_Error (Rule_Id, "parameters required"); 97 end if; 98 99 Subrule_Name := Get_Flag_Parameter (Allow_Any => False); 100 if Rule_Used (Subrule_Name) (Ctl_Kind) then 101 Parameter_Error (Rule_Id, "rule already specified for " & Control_Kinds'Wide_Image (Ctl_Kind)); 102 end if; 103 104 if not Parameter_Exists then 105 Parameter_Error (Rule_Id, "two or three parameters required"); 106 end if; 107 Bounds (Subrule_Name, Ctl_Kind) := Get_Bounds_Parameters (Rule_Id); 108 Labels (Subrule_Name, Ctl_Kind) := To_Unbounded_Wide_String (Ctl_Label); 109 Rule_Used (Subrule_Name)(Ctl_Kind) := True; 110 end Add_Control; 111 112 ------------- 113 -- Command -- 114 ------------- 115 116 procedure Command (Action : in Framework.Rules_Manager.Rule_Action) is 117 use Framework.Rules_Manager; 118 begin 119 case Action is 120 when Clear => 121 Rule_Used := (others => (others => False)); 122 when Suspend => 123 Save_Used := Rule_Used; 124 Rule_Used := (others => (others => False)); 125 when Resume => 126 Rule_Used := Save_Used; 127 end case; 128 end Command; 129 130 ------------------ 131 -- Check_Report -- 132 ------------------ 133 134 procedure Check_Report (Subrule_Name : Subrules; 135 Value : Biggest_Natural; 136 Message : Wide_String; 137 Elem : Asis.Element) 138 is 139 use Ada.Strings.Wide_Unbounded; 140 use Framework.Reports; 141 begin 142 if Rule_Used (Subrule_Name) (Check) and then Value < Bounds (Subrule_Name, Check).Min then 143 Report (Rule_Id, 144 To_Wide_String (Labels (Subrule_Name, Check)), 145 Check, 146 Get_Location (Elem), 147 "too few " & Message 148 & " (" & Biggest_Int_Img (Value) & ')'); 149 elsif Rule_Used (Subrule_Name) (Search) and then Value < Bounds (Subrule_Name, Search).Min then 150 Report (Rule_Id, 151 To_Wide_String (Labels (Subrule_Name, Search)), 152 Search, 153 Get_Location (Elem), 154 "too few " & Message 155 & " (" & Biggest_Int_Img (Value) & ')'); 156 end if; 157 158 if Rule_Used (Subrule_Name) (Count) and then Value < Bounds (Subrule_Name, Count).Min then 159 Report (Rule_Id, 160 To_Wide_String (Labels (Subrule_Name, Count)), 161 Count, 162 Get_Location (Elem), 163 ""); 164 end if; 165 166 if Rule_Used (Subrule_Name) (Check) and then Value > Bounds (Subrule_Name, Check).Max then 167 Report (Rule_Id, 168 To_Wide_String (Labels (Subrule_Name, Check)), 169 Check, 170 Get_Location (Elem), 171 "too many " & Message 172 & " (" & Biggest_Int_Img (Value) & ')'); 173 elsif Rule_Used (Subrule_Name) (Search) and then Value > Bounds (Subrule_Name, Search).Max then 174 Report (Rule_Id, 175 To_Wide_String (Labels (Subrule_Name, Search)), 176 Search, 177 Get_Location (Elem), 178 "too many " & Message 179 & " (" & Biggest_Int_Img (Value) & ')'); 180 end if; 181 182 if Rule_Used (Subrule_Name) (Count) and then Value > Bounds (Subrule_Name, Count).Max then 183 Report (Rule_Id, 184 To_Wide_String (Labels (Subrule_Name, Count)), 185 Count, 186 Get_Location (Elem), 187 ""); 188 end if; 189 end Check_Report; 190 191 ---------------------------- 192 -- Process_Case_Statement -- 193 ---------------------------- 194 195 procedure Process_Case_Statement (Statement : in Asis.Statement) is 196 use Asis.Elements, Asis.Statements; 197 use Framework.Reports; 198 199 Non_Evaluable : exception; 200 201 -- Compute the number of cases covered by all case alternatives 202 -- (including discrete ranges) excluding the "when others" alternative 203 function Count_Non_Others_Choices (Case_Paths : in Path_List) return Biggest_Natural is 204 use Utilities; 205 Count : Biggest_Natural := 0; 206 begin 207 -- We know that the last path is for "when others": 208 for CP in List_Index range Case_Paths'First .. Case_Paths'Last - 1 loop 209 declare 210 Path_Elements : constant Element_List := Case_Statement_Alternative_Choices (Case_Paths (CP)); 211 Temp : Extended_Biggest_Natural; 212 begin 213 for PE in Path_Elements'Range loop 214 if Definition_Kind (Path_Elements (PE)) = A_Discrete_Range then 215 if Discrete_Range_Kind (Path_Elements (PE)) = A_Discrete_Subtype_Indication 216 and then not Is_Nil (Corresponding_Static_Predicates (Subtype_Simple_Name (Path_Elements (PE)))) 217 then 218 -- A subtype with static predicate used for a choice: we don't know (yet) how to evaluate this 219 Uncheckable (Rule_Id, 220 False_Negative, 221 Get_Location (Path_Elements (PE)), 222 "(others_span) Use of subtype with static predicate"); 223 raise Non_Evaluable; 224 end if; 225 Temp := Discrete_Constraining_Lengths (Path_Elements (PE))(1); 226 if Temp = Not_Static then 227 -- it IS static, but the evaluator cannot evaluate it... 228 -- unless it is of a generic formal type 229 Uncheckable (Rule_Id, 230 False_Negative, 231 Get_Location (Path_Elements (PE)), 232 "(others_span) Could not evaluate bounds of expression"); 233 raise Non_Evaluable; 234 end if; 235 Count := Count + Temp; 236 237 elsif Element_Kind (Path_Elements (PE)) = An_Expression then 238 Count := Count + 1; 239 240 else 241 Failure ("Unexpected path kind:", Path_Elements (PE)); 242 end if; 243 end loop; 244 end; 245 end loop; 246 247 return Count; 248 end Count_Non_Others_Choices; 249 250 procedure Process_Min_Others_Range is 251 use Asis.Declarations; 252 Case_Paths : constant Path_List := Statement_Paths (Statement); 253 Subtype_Span : Extended_Biggest_Int; 254 begin 255 -- Don't waste time if there is no "when others" choice (must be last) 256 if Definition_Kind (Case_Statement_Alternative_Choices 257 (Case_Paths (Case_Paths'Last))(1)) /= An_Others_Choice 258 then 259 return; 260 end if; 261 262 if not Is_Nil (Corresponding_Static_Predicates (Case_Expression (Statement))) then 263 Uncheckable (Rule_Id, 264 False_Negative, 265 Get_Location (Case_Expression (Statement)), 266 "(others_span) Expression is of a subtype with static predicate"); 267 return; 268 end if; 269 270 Subtype_Span := Discrete_Constraining_Lengths (A4G_Bugs.Corresponding_Expression_Type 271 (Case_Expression (Statement))) (1); 272 if Subtype_Span = Not_Static then 273 Subtype_Span := Discrete_Constraining_Lengths (Corresponding_First_Subtype 274 (A4G_Bugs.Corresponding_Expression_Type 275 (Case_Expression (Statement))))(1); 276 if Subtype_Span = Not_Static then 277 -- Hmmm... this one IS static, so there is something we can't evaluate 278 -- or it is from a generic formal type 279 -- give up 280 Uncheckable (Rule_Id, 281 False_Negative, 282 Get_Location (Case_Expression (Statement)), 283 "(others_span) Could not evaluate bounds of expression"); 284 return; 285 end if; 286 end if; 287 288 Check_Report (Others_Span, 289 Value => Subtype_Span - Count_Non_Others_Choices (Case_Paths), 290 Message => "values covered by ""others"" in case statement", 291 Elem => Case_Paths (Case_Paths'Last)); 292 293 exception 294 when Non_Evaluable => 295 return; 296 end Process_Min_Others_Range; 297 298 -- 299 -- max_values is the number of values covered by the subtype 300 -- of the case selector 301 -- 302 procedure Process_Max_Values is 303 Subtype_Span : Extended_Biggest_Int; 304 Case_Paths : constant Path_List := Statement_Paths (Statement); 305 Has_Others : constant Boolean := Definition_Kind (Case_Statement_Alternative_Choices 306 (Case_Paths (Case_Paths'Last)) (1)) = An_Others_Choice; 307 begin 308 if not Is_Nil (Corresponding_Static_Predicates (Case_Expression (Statement))) then 309 Uncheckable (Rule_Id, 310 False_Negative, 311 Get_Location (Case_Expression (Statement)), 312 "(values) Expression is of a subtype with static predicate"); 313 return; 314 end if; 315 316 Subtype_Span := Discrete_Constraining_Lengths (A4G_Bugs.Corresponding_Expression_Type 317 (Case_Expression (Statement))) (1); 318 if Subtype_Span = Not_Static then 319 return; 320 end if; 321 322 Check_Report (Values, 323 Value => Subtype_Span, 324 Message => "values for subtype of selector in case statement", 325 Elem => Statement); 326 327 if Has_Others then 328 Check_Report (Values_If_Others, 329 Value => Subtype_Span, 330 Message => "values for subtype of selector in case statement with ""others""", 331 Elem => Statement); 332 end if; 333 334 exception 335 when Non_Evaluable => 336 return; 337 end Process_Max_Values; 338 339 procedure Process_Min_Paths is 340 begin 341 Check_Report (Paths, 342 Value => Statement_Paths (Statement)'Length, 343 Message => "paths in case statement", 344 Elem => Statement); 345 end Process_Min_Paths; 346 347 begin -- Process_Case_Statement 348 if Rule_Used = (Subrules => (Control_Kinds => False)) then 349 return; 350 end if; 351 Rules_Manager.Enter (Rule_Id); 352 353 if Rule_Used (Values) /= (Control_Kinds => False) 354 or Rule_Used (Values_If_Others) /= (Control_Kinds => False) 355 then 356 Process_Max_Values; 357 end if; 358 359 if Rule_Used (Paths) /= (Control_Kinds => False) then 360 Process_Min_Paths; 361 end if; 362 363 if Rule_Used (Others_Span) /= (Control_Kinds => False) then 364 Process_Min_Others_Range; 365 end if; 366 end Process_Case_Statement; 367 368 ------------------ 369 -- Process_Path -- 370 ------------------ 371 372 procedure Process_Path (Path : Asis.Path) is 373 use Asis.Elements, Asis.Statements; 374 use Framework.Reports, Utilities; 375 376 Choices : constant Asis.Element_List := Case_Statement_Alternative_Choices (Path); 377 Nb_Val : Extended_Biggest_Natural; 378 begin 379 if Rule_Used (Range_Span) = (Control_Kinds => False) then 380 return; 381 end if; 382 Rules_Manager.Enter (Rule_Id); 383 384 for C in Choices'Range loop 385 case Definition_Kind (Choices (C)) is 386 when Not_A_Definition -- An_Expression 387 | An_Others_Choice 388 => 389 null; 390 when A_Discrete_Range => 391 if Discrete_Range_Kind (Choices (C)) /= A_Discrete_Subtype_Indication 392 or else Is_Nil (Corresponding_Static_Predicates (Subtype_Simple_Name (Choices (C)))) 393 then 394 -- Normal case 395 Nb_Val := Discrete_Constraining_Lengths (Choices (C)) (1); 396 if Nb_Val = Not_Static then 397 -- This was supposed to be static, but for some reason we can't evaluate it 398 -- Maybe it is a generic formal type 399 -- Give up 400 Uncheckable (Rule_Id, 401 False_Negative, 402 Get_Location (Choices (C)), 403 "(range_span) Could not evaluate discrete range"); 404 return; 405 end if; 406 407 Check_Report (Range_Span, 408 Value => Nb_Val, 409 Message => "values in choice range", 410 Elem => Choices (C)); 411 else 412 Uncheckable (Rule_Id, 413 False_Negative, 414 Get_Location (Choices(C)), 415 "(range_span) Range is of a subtype with static predicate"); 416 end if; 417 418 when others => 419 Failure ("Wrong definition in case path"); 420 end case; 421 end loop; 422 end Process_Path; 423 424begin -- Rules.Case_Statement 425 Rules_Manager.Register (Rule_Id, 426 Rules_Manager.Semantic, 427 Help_CB => Help'Access, 428 Add_Control_CB => Add_Control'Access, 429 Command_CB => Command'Access); 430end Rules.Case_Statement; 431