1---------------------------------------------------------------------- 2-- Framework.Language.Shared_Keys - 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-- ASIS 33with 34 Asis.Declarations, 35 Asis.Elements, 36 Asis.Expressions; 37 38-- Adacontrol 39with 40 Scope_Manager, 41 Framework.Language.Scanner; 42 43package body Framework.Language.Shared_Keys is 44 45 type Min_Max is (Not_A_Bound, Min, Max); 46 package Min_Max_Utilities is new Modifier_Utilities (Min_Max); 47 48 49 ------------------- 50 -- Is_Applicable -- 51 ------------------- 52 53 function Is_Applicable (Expected_Places : Places_Set) return Boolean is 54 use Scope_Manager, Scope_Places_Utilities, Thick_Queries; 55 use Asis, Asis.Elements; 56 Scope_Kind : constant Declaration_Kinds := Declaration_Kind (Current_Scope); 57 58 Locations : constant Modifier_Set := (S_All => False, 59 S_Block => Statement_Kind (Current_Scope) = A_Block_Statement, 60 S_Library => Current_Depth = 0, 61 S_Local => not Is_Current_Scope_Global, 62 S_Own => Scope_Kind = A_Package_Body_Declaration, 63 S_Private => In_Private_Part, 64 S_Public => (Scope_Kind = A_Package_Declaration 65 or Scope_Kind = A_Generic_Package_Declaration) 66 and not In_Private_Part, 67 S_In_Generic => Is_Generic_Unit (Current_Scope) 68 or else Is_Part_Of_Generic (Current_Scope), 69 S_Task_Body => Scope_Kind = A_Task_Body_Declaration); 70 begin 71 if Expected_Places.Specified (S_All) then 72 return True; 73 end if; 74 75 return (Expected_Places.Specified and Locations) = Expected_Places.Presence; 76 end Is_Applicable; 77 78 ----------- 79 -- Image -- 80 ----------- 81 82 function Image (Set : Places_Set; 83 Default : Places_Set := No_Places) return Wide_String 84 is 85 use Scope_Places_Utilities; 86 87 function Image (From : Scope_Places) return Wide_String is 88 use Utilities; 89 begin 90 if not Set.Specified (From) then 91 if From = Scope_Places'Last then 92 return ""; 93 else 94 return Image (From => Scope_Places'Succ (From)); 95 end if; 96 end if; 97 98 if From = Scope_Places'Last then 99 if Set.Presence (From) then 100 return Image (From, Lower_Case) & ' '; 101 else 102 return "not " & Image (From, Lower_Case) & ' '; 103 end if; 104 else 105 if Set.Presence (From) then 106 return Image (From, Lower_Case) & ' ' & Image (From => Scope_Places'Succ (From)); 107 else 108 return "not " & Image (From, Lower_Case) & ' ' & Image (From => Scope_Places'Succ (From)); 109 end if; 110 end if; 111 end Image; 112 begin -- Image 113 if Set.Specified = (Set.Specified'Range => False) or else Set = Default then 114 return ""; 115 end if; 116 117 return Image (From => Scope_Places'First); 118 end Image; 119 120 -------------------------- 121 -- Help_On_Scope_Places -- 122 -------------------------- 123 124 procedure Help_On_Scope_Places (Header : Wide_String := ""; 125 Expected : Scope_Places_Utilities.Modifier_Set := Scope_Places_Utilities.Full_Set) 126 is 127 begin 128 Scope_Places_Utilities.Help_On_Modifiers (Header => Header & " [not]", Expected => Expected); 129 end Help_On_Scope_Places; 130 131 132 ------------------------------ 133 -- Get_Places_Set_Modifiers -- 134 ------------------------------ 135 136 function Get_Places_Set_Modifiers (Allow_All : Boolean := True) return Places_Set is 137 use Scope_Places_Utilities, Framework.Language.Scanner; 138 Result : Places_Set := No_Places; 139 Loc : Scope_Places; 140 Found : Boolean; 141 Presence : Boolean; 142 begin 143 loop 144 Presence := not Get_Modifier ("NOT"); 145 Get_Modifier (Loc, Found, Expected => (S_All => Allow_All, others => True)); 146 exit when not Found; 147 if Loc = S_All and not Presence then 148 Syntax_Error ("""all"" cannot be specified with ""not""", Current_Token.Position); 149 end if; 150 Result.Specified (Loc) := True; 151 Result.Presence (Loc) := Presence; 152 end loop; 153 154 if Result = No_Places then 155 return Everywhere; 156 elsif Result.Specified (S_All) and Result.Specified /= Empty_Set then 157 Syntax_Error ("""all"" cannot be specified with other locations", Current_Token.Position); 158 else 159 return Result; 160 end if; 161 end Get_Places_Set_Modifiers; 162 163 --------------------------- 164 -- Get_Bounds_Parameters -- 165 --------------------------- 166 167 function Get_Bounds_Parameters (Rule_Id : Wide_String; 168 Bound_Min : Thick_Queries.Biggest_Int := 0; 169 Bound_Max : Thick_Queries.Biggest_Int := Thick_Queries.Biggest_Natural'Last; 170 Allow_Single : Boolean := False) 171 return Bounds_Values 172 is 173 use Thick_Queries, Min_Max_Utilities; 174 175 Min_Given : Boolean := False; 176 Max_Given : Boolean := False; 177 Result : Bounds_Values := (Bound_Min, Bound_Max); 178 begin 179 if Allow_Single and then Is_Integer_Parameter then 180 Result.Min := Get_Integer_Parameter (Min => Bound_Min, Max => Bound_Max); 181 Result.Max := Result.Min; --## rule line off Assignments 182 return Result; 183 end if; 184 185 while Parameter_Exists loop 186 case Min_Max'(Get_Modifier (Required => False)) is 187 when Not_A_Bound => 188 exit; 189 when Min => 190 if Min_Given then 191 Parameter_Error (Rule_Id, "Min value given more than once"); 192 end if; 193 Result.Min := Get_Integer_Parameter (Min => Bound_Min, Max => Bound_Max); 194 Min_Given := True; 195 when Max => 196 if Max_Given then 197 Parameter_Error (Rule_Id, "Max value given more than once"); 198 end if; 199 Result.Max := Get_Integer_Parameter (Min => Bound_Min, Max => Bound_Max); 200 Max_Given := True; 201 end case; 202 end loop; 203 204 if Result.Min > Result.Max then 205 Parameter_Error (Rule_Id, "Min value must be less than Max"); 206 end if; 207 208 return Result; 209 end Get_Bounds_Parameters; 210 211 ----------- 212 -- Is_In -- 213 ----------- 214 215 function Is_In (Val : Thick_Queries.Biggest_Int; Bounds : Bounds_Values) return Boolean is 216 begin 217 return Val in Bounds.Min .. Bounds.Max; 218 end Is_In; 219 220 ----------------- 221 -- Bound_Image -- 222 ----------------- 223 224 function Bound_Image (Bounds : Language.Shared_Keys.Bounds_Values) return Wide_String is 225 use Thick_Queries; 226 begin 227 if Bounds.Min = Bounds.Max then 228 return "not " & Biggest_Int_Img (Bounds.Min); 229 elsif Bounds.Min = Biggest_Int'First then 230 return "more than " & Biggest_Int_Img (Bounds.Max); 231 elsif Bounds.Max = Biggest_Int'Last then 232 return "less than " & Biggest_Int_Img (Bounds.Min); 233 else 234 return "not in " & Biggest_Int_Img (Bounds.Min) & " .. " & Biggest_Int_Img (Bounds.Max); 235 end if; 236 end Bound_Image; 237 238 -------------------- 239 -- Help_On_Bounds -- 240 -------------------- 241 242 procedure Help_On_Bounds (Header : Wide_String := "") is 243 begin 244 Min_Max_Utilities.Help_On_Modifiers (Header => Header, Expected => (Not_A_Bound => False, others => True)); 245 end Help_On_Bounds; 246 247 ----------- 248 -- Image -- 249 ----------- 250 251 function Image (Item : Thick_Queries.Type_Categories) return Wide_String is 252 use Thick_Queries; 253 begin 254 case Item is 255 when Not_A_Type => 256 return ""; 257 when An_Enumeration_Type => 258 return "()"; 259 when A_Signed_Integer_Type => 260 return "RANGE"; 261 when A_Modular_Type => 262 return "MOD"; 263 when A_Fixed_Point_Type => 264 return "DELTA"; 265 when A_Floating_Point_Type => 266 return "DIGITS"; 267 when An_Array_Type => 268 return "ARRAY"; 269 when A_Record_Type => 270 return "RECORD"; 271 when A_Tagged_Type => 272 return "TAGGED"; 273 when An_Extended_Tagged_Type => 274 return "EXTENSION"; 275 when An_Access_Type => 276 return "ACCESS"; 277 when A_Derived_Type => 278 return "NEW"; 279 when A_Private_Type => 280 return "PRIVATE"; 281 when A_Task_Type => 282 return "TASK"; 283 when A_Protected_Type => 284 return "PROTECTED"; 285 end case; 286 end Image; 287 288 ----------- 289 -- Value -- 290 ----------- 291 292 function Value (Spec : Entity_Specification) return Categories is 293 begin 294 if Spec.Kind /= Regular_Id then 295 return Cat_Any; 296 end if; 297 return Value (To_Wide_String (Spec.Specification)); 298 end Value; 299 300 301 ----------- 302 -- Value -- 303 ----------- 304 305 function Value (Spec : Wide_String) return Categories is 306 begin 307 if Spec = "()" then 308 return Cat_Enum; 309 else 310 return Categories'Wide_Value ("CAT_" & Spec); 311 end if; 312 exception 313 when Constraint_Error => 314 return Cat_Any; 315 end Value; 316 317 ------------- 318 -- Matches -- 319 ------------- 320 321 Match_Table : constant array (Thick_Queries.Type_Categories) of Categories 322 := (Thick_Queries.Not_A_Type => Cat_Any, 323 -- For Matches: Since Cat_Any is eliminated first, will return false 324 Thick_Queries.An_Enumeration_Type => Cat_Enum, 325 Thick_Queries.A_Signed_Integer_Type => Cat_Range, 326 Thick_Queries.A_Modular_Type => Cat_Mod, 327 Thick_Queries.A_Fixed_Point_Type => Cat_Delta, 328 Thick_Queries.A_Floating_Point_Type => Cat_Digits, 329 Thick_Queries.An_Array_Type => Cat_Array, 330 Thick_Queries.A_Record_Type => Cat_Record, 331 Thick_Queries.A_Tagged_Type => Cat_Tagged, 332 Thick_Queries.An_Extended_Tagged_Type => Cat_Extension, 333 Thick_Queries.An_Access_Type => Cat_Access, 334 Thick_Queries.A_Derived_Type => Cat_New, 335 Thick_Queries.A_Private_Type => Cat_Private, 336 Thick_Queries.A_Task_Type => Cat_Task, 337 Thick_Queries.A_Protected_Type => Cat_Protected); 338 339 function Matches (Elem : in Asis.Element; 340 Cat : in Categories; 341 Follow_Derived : in Boolean := False; 342 Privacy : in Thick_Queries.Privacy_Policy := Thick_Queries.Stop_At_Private; 343 Separate_Extension : in Boolean := False) 344 return Boolean 345 is 346 use Thick_Queries; 347 begin 348 if Cat = Cat_Any then 349 return True; 350 end if; 351 return Match_Table (Type_Category (Elem, Follow_Derived, Privacy, Separate_Extension)) = Cat; 352 end Matches; 353 354 355 ----------------------- 356 -- Matching_Category -- 357 ----------------------- 358 359 function Matching_Category (Elem : in Asis.Element; 360 From_Cats : in Categories_Utilities.Unconstrained_Modifier_Set; 361 Follow_Derived : in Boolean := False; 362 Privacy : in Thick_Queries.Privacy_Policy := Thick_Queries.Stop_At_Private; 363 Separate_Extension : in Boolean := False) 364 return Categories 365 is 366 use Thick_Queries; 367 Cat : constant Categories := Match_Table (Type_Category (Elem, Follow_Derived, Privacy, Separate_Extension)); 368 begin 369 if From_Cats (Cat) then 370 return Cat; 371 else 372 return Cat_Any; 373 end if; 374 end Matching_Category; 375 376 377 --------------------------- 378 -- Get_Aspects_Parameter -- 379 --------------------------- 380 381 function Get_Aspects_Parameter (Rule_Id : Wide_String; 382 Expected : Aspects_Set := (others => Present)) 383 return Aspects_Set 384 is 385 use Aspects_Utilities, Utilities; 386 387 Result : Aspects_Set := (others => Unspecified); 388 Temp : Aspect_Presence; 389 A : Aspects; 390 begin 391 while Parameter_Exists loop 392 if Get_Modifier ("NOT") then 393 Temp := Absent; 394 else 395 Temp := Present; 396 end if; 397 398 A := Get_Flag_Parameter (Allow_Any => False); 399 if Expected (A) /= Present then 400 Parameter_Error (Rule_Id, "aspect not allowed for this rule"); 401 end if; 402 if Result (A) /= Unspecified then 403 Parameter_Error (Rule_Id, "aspect already specified: " & Image (A, Title_Case)); 404 end if; 405 406 Result (A) := Temp; 407 end loop; 408 return Result; 409 end Get_Aspects_Parameter; 410 411 412 ------------------------------- 413 -- Corresponding_Aspects_Set -- 414 ------------------------------- 415 416 function Corresponding_Aspects_Set (Elem : Asis.Element) return Aspects_Set is 417 use Asis, Asis.Declarations, Asis.Elements, Asis.Expressions; 418 use Thick_Queries, Utilities; 419 420 Decl : Asis.Declaration; 421 Result : Aspects_Set := (others => Absent); 422 begin 423 case Element_Kind (Elem) is 424 when A_Declaration => 425 Decl := Elem; 426 when A_Defining_Name | A_Definition => 427 Decl := Enclosing_Element (Elem); 428 when An_Expression => 429 Decl := Corresponding_Name_Declaration (Simple_Name (Elem)); 430 when others => 431 Failure ("Corresponding_Aspects_Set: incorrect elem", Elem); 432 end case; 433 434 declare 435 Repr_Clauses : constant Asis.Representation_Clause_List := Corresponding_Representation_Clauses (Decl); 436 begin 437 for R in Repr_Clauses'Range loop 438 case Representation_Clause_Kind (Repr_Clauses (R)) is 439 when An_Enumeration_Representation_Clause | A_Record_Representation_Clause => 440 Result (Representation) := Present; 441 when others => 442 null; 443 end case; 444 end loop; 445 end; 446 if Declaration_Kind (Decl) = An_Ordinary_Type_Declaration 447 -- Pragma pack does not apply to objects 448 and then Corresponding_Pragma_Set (Names (Decl) (1)) (A_Pack_Pragma) 449 then 450 Result (Pack) := Present; 451 end if; 452 453 if not Is_Nil (Attribute_Clause_Expression (A_Size_Attribute, Decl)) then 454 Result (Size) := Present; 455 end if; 456 457 if not Is_Nil (Attribute_Clause_Expression (A_Component_Size_Attribute, Decl)) then 458 Result (Component_Size) := Present; 459 end if; 460 461 return Result; 462 end Corresponding_Aspects_Set; 463end Framework.Language.Shared_Keys; 464