1---------------------------------------------------------------------- 2-- Rules.Max_Nesting - 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 32-- Ada 33with 34 Ada.Strings.Wide_Unbounded; 35 36-- Asis 37with 38 Asis.Compilation_Units, 39 Asis.Declarations, 40 Asis.Elements; 41 42-- Adalog 43with 44 Scope_Manager, 45 Thick_Queries, 46 Utilities; 47 48-- Adactl 49with 50 Framework.Language, 51 Framework.Reports, 52 Framework.Rules_Manager; 53pragma Elaborate (Framework.Language); 54 55package body Rules.Max_Nesting is 56 use Framework, Scope_Manager; 57 58 -- Algorithm: 59 -- 60 -- Only thing worth noting is that the nesting level is one less than the depth 61 -- (i.e.: a level 2 unit is nested once). We actually count depths, not nesting, 62 -- therefore the offset is adjusted in Add_Control 63 64 type Subrules is (Sr_Default, Sr_All, Sr_Generic, Sr_Separate, Sr_Task); 65 package Subrules_Flag_Utilities is new Framework.Language.Flag_Utilities (Flags => Subrules, 66 Prefix => "Sr_" ); 67 type Used_Set is array (Subrules) of Boolean; 68 Not_Used : constant Used_Set := (others => False); 69 70 Rule_Used : Used_Set := Not_Used; 71 Save_Used : Used_Set; 72 73 Max_Depth : array (Subrules, Control_Kinds) of Scope_Range := (others => (others => Scope_Range'Last)); 74 Labels : array (Subrules, Control_Kinds) of Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; 75 76 Not_Counted : Scope_Range := 0; 77 -- Number of active scopes not counted for the Sr_All subrule depth 78 -- i.e.: for loops and accept statements 79 80 Generic_Count : Scope_Range := 0; 81 -- Depth for the Sr_Generic subrule 82 83 Separate_Count : Scope_Range := 0; 84 -- Depth for the Sr_Separate subrule 85 86 Task_Count : Scope_Range := 0; 87 -- Depth for the Sr_Task subrule 88 89 ---------- 90 -- Help -- 91 ---------- 92 93 procedure Help is 94 use Utilities, Subrules_Flag_Utilities; 95 begin 96 User_Message ("Rule: " & Rule_Id); 97 User_Message ("Control scopes nested deeper than a given limit."); 98 User_Message; 99 Help_On_Flags (Header => "Parameter(1):", Footer => "(optional, default=all)", Extra_Value => ""); 100 User_Message ("Parameter(2): <maximum allowed nesting level>"); 101 end Help; 102 103 ----------------- 104 -- Add_Control -- 105 ----------------- 106 107 procedure Add_Control (Ctl_Label : in Wide_String; Ctl_Kind : in Control_Kinds) is 108 use Ada.Strings.Wide_Unbounded; 109 use Framework.Language, Subrules_Flag_Utilities; 110 111 Max : Asis.ASIS_Integer; 112 Sr : Subrules; 113 begin 114 if not Parameter_Exists then 115 Parameter_Error (Rule_Id, "max nesting value expected"); 116 end if; 117 118 Sr := Get_Flag_Parameter (Allow_Any => True); 119 if Sr = Sr_Default then 120 Sr := Sr_All; 121 end if; 122 Max := Get_Integer_Parameter (Min => 0); 123 124 if Max_Depth (Sr, Ctl_Kind) /= Scope_Range'Last then 125 Parameter_Error (Rule_Id, "this rule can be specified only once for each of check, search and count"); 126 end if; 127 Max_Depth (Sr, Ctl_Kind) := Scope_Range (Max) + 1; 128 Labels (Sr, Ctl_Kind) := To_Unbounded_Wide_String (Ctl_Label); 129 130 Rule_Used (Sr) := True; 131 exception 132 when Constraint_Error => 133 Parameter_Error (Rule_Id, 134 "specified nesting greater than allowed maximum of" 135 & Scope_Range'Wide_Image (Scope_Range'Last - 1)); 136 end Add_Control; 137 138 ------------- 139 -- Command -- 140 ------------- 141 142 procedure Command (Action : Framework.Rules_Manager.Rule_Action) is 143 use Ada.Strings.Wide_Unbounded, Framework.Rules_Manager; 144 begin 145 case Action is 146 when Clear => 147 Rule_Used := Not_Used; 148 Max_Depth := (others => (others => Scope_Range'Last)); 149 Labels := (others => (others => Null_Unbounded_Wide_String)); 150 when Suspend => 151 Save_Used := Rule_Used; 152 Rule_Used := Not_Used; 153 when Resume => 154 Rule_Used := Save_Used; 155 end case; 156 end Command; 157 158 159 ----------- 160 -- Reset -- 161 ----------- 162 163 procedure Reset is 164 -- Must reset global counters to 0, otherwise they will be left for next unit 165 -- at the nesting level we were on when something bad happened 166 begin 167 Not_Counted := 0; 168 Generic_Count := 0; 169 Separate_Count := 0; 170 Task_Count := 0; 171 end Reset; 172 173 --------------- 174 -- Do_Report -- 175 --------------- 176 177 procedure Do_Report (Sr : Subrules; Depth : Scope_Range; Scope : Asis.Element) is 178 use Ada.Strings.Wide_Unbounded; 179 use Asis, Asis.Declarations, Asis.Elements; 180 use Utilities, Subrules_Flag_Utilities, Framework.Reports; 181 Scope_Body : Asis.Declaration; 182 begin 183 -- Don't report on body if there is an explicit spec 184 case Declaration_Kind (Scope) is 185 when A_Procedure_Body_Declaration 186 | A_Function_Body_Declaration 187 | A_Package_Body_Declaration 188 => 189 Scope_Body := Scope; 190 if Is_Subunit (Scope_Body) then 191 Scope_Body := Corresponding_Body_Stub (Scope_Body); 192 end if; 193 if not Is_Nil (Corresponding_Declaration (Scope_Body)) then 194 return; 195 end if; 196 when A_Task_Body_Declaration 197 | A_Protected_Body_Declaration 198 => 199 -- Those always have an explicit spec 200 return; 201 when others => 202 null; 203 end case; 204 205 -- We check only if it is equal to the first forbidden level. 206 -- It is not useful to issue a message if there are even deeper levels. 207 if Depth > Max_Depth (Sr, Check) then 208 Report (Rule_Id, 209 To_Wide_String (Labels (Sr, Check)), 210 Check, 211 Get_Location (Scope), 212 Choose (Sr = Sr_All, "", Image (Sr, Lower_Case) & ' ') 213 & "nesting deeper than" & Scope_Range'Wide_Image (Max_Depth (Sr, Check)-1) 214 & " (" & Trim_All(Scope_Range'Wide_Image (Depth-1)) & ')'); -- Nesting is Depth-1 215 elsif Depth > Max_Depth (Sr, Search) then 216 Report (Rule_Id, 217 To_Wide_String (Labels (Sr, Search)), 218 Search, 219 Get_Location (Scope), 220 Choose (Sr = Sr_All, "", Image (Sr, Lower_Case) & ' ') 221 & "nesting deeper than" & Scope_Range'Wide_Image (Max_Depth (Sr, Search)-1) 222 & " (" & Trim_All(Scope_Range'Wide_Image (Depth-1)) & ')'); -- Nesting is Depth-1 223 end if; 224 225 -- But counting is independent 226 if Depth > Max_Depth (Sr, Count) then 227 Report (Rule_Id, 228 To_Wide_String (Labels (Sr, Count)), 229 Count, 230 Get_Location (Scope), 231 ""); 232 end if; 233 end Do_Report; 234 235 236 ------------------------- 237 -- Process_Scope_Enter -- 238 ------------------------- 239 240 procedure Process_Scope_Enter (Scope : in Asis.Element) is 241 use Asis, Asis.Compilation_Units, Asis.Elements; 242 use Thick_Queries; 243 begin 244 if Rule_Used = Not_Used then 245 return; 246 end if; 247 Rules_Manager.Enter (Rule_Id); 248 249 -- Only Sr_Separate is interested in stubs (to report on stub rather than on separate body) 250 if Declaration_Kind (Scope) in A_Body_Stub then 251 if Rule_Used (Sr_Separate) then 252 Do_Report (Sr_Separate, Separate_Count+1, Scope); -- Separate_Count+1 since the stub is not entered 253 end if; 254 return; 255 end if; 256 257 if Rule_Used (Sr_All) then 258 -- Do not count exception handlers and statements other than blocks 259 case Element_Kind (Scope) is 260 when A_Statement => 261 if Statement_Kind (Scope) /= A_Block_Statement then 262 Not_Counted := Not_Counted + 1; 263 return; 264 end if; 265 when An_Exception_Handler => 266 Not_Counted := Not_Counted + 1; 267 return; 268 when others => 269 null; 270 end case; 271 Do_Report (Sr_All, Current_Depth - Not_Counted, Scope); 272 end if; 273 274 -- Count generic nesting 275 if Rule_Used (Sr_Generic) 276 and then Is_Generic_Unit (Scope) 277 then 278 Generic_Count := Generic_Count + 1; 279 Do_Report (Sr_Generic, Generic_Count, Scope); 280 end if; 281 282 -- Count task nesting 283 if Rule_Used (Sr_Task) then 284 case Declaration_Kind (Scope) is 285 when A_Single_Task_Declaration | A_Task_Type_Declaration => 286 -- No need to increment task_count, a task cannot be declared in a task spec 287 Do_Report (Sr_Task, Task_Count+1, Scope); 288 when A_Task_Body_Declaration => 289 Task_Count := Task_Count + 1; 290 when others => 291 null; 292 end case; 293 end if; 294 295 if Rule_Used (Sr_Separate) 296 and then Is_Compilation_Unit (Scope) 297 and then Unit_Class (Enclosing_Compilation_Unit (Scope)) = A_Separate_Body 298 then 299 Separate_Count := Separate_Count + 1; 300 end if; 301 end Process_Scope_Enter; 302 303 ------------------------ 304 -- Process_Scope_Exit -- 305 ------------------------ 306 307 procedure Process_Scope_Exit (Scope : in Asis.Element) is 308 use Asis, Asis.Compilation_Units, Asis.Elements; 309 use Thick_Queries; 310 begin 311 if Rule_Used = Not_Used then 312 return; 313 end if; 314 Rules_Manager.Enter (Rule_Id); 315 316 if Declaration_Kind (Scope) in A_Body_Stub then 317 return; 318 end if; 319 320 if Rule_Used (Sr_All) then 321 case Element_Kind (Scope) is 322 when A_Statement => 323 if Statement_Kind (Scope) /= A_Block_Statement then 324 Not_Counted := Not_Counted - 1; 325 end if; 326 when An_Exception_Handler => 327 Not_Counted := Not_Counted - 1; 328 when others => 329 null; 330 end case; 331 end if; 332 333 if Rule_Used (Sr_Generic) 334 and then Is_Generic_Unit (Scope) 335 then 336 Generic_Count := Generic_Count - 1; 337 end if; 338 339 if Rule_Used (Sr_Task) then 340 case Declaration_Kind (Scope) is 341 when A_Task_Body_Declaration => 342 Task_Count := Task_Count - 1; 343 when others => 344 null; 345 end case; 346 end if; 347 348 if Rule_Used (Sr_Separate) 349 and then Is_Compilation_Unit (Scope) 350 and then Unit_Class (Enclosing_Compilation_Unit (Scope)) = A_Separate_Body 351 then 352 Separate_Count := Separate_Count - 1; 353 end if; 354 end Process_Scope_Exit; 355 356begin -- Rules.Max_Nesting 357 Framework.Rules_Manager.Register (Rule_Id, 358 Rules_Manager.Semantic, 359 Help_CB => Help'Access, 360 Add_Control_CB => Add_Control'Access, 361 Command_CB => Command'Access, 362 Reset_CB => Reset'Access); 363end Rules.Max_Nesting; 364