1---------------------------------------------------------------------- 2-- Rules.Unsafe_Elaboration - Package body -- 3-- -- 4-- This software is (c) Adalog/Alstom 2004-2013. -- 5-- The Ada Controller is free software; you can redistribute it -- 6-- and/or modify it under terms of the GNU General Public License -- 7-- as published by the Free Software Foundation; either version 2, -- 8-- or (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-- ASIS 32with 33 Asis.Compilation_Units, 34 Asis.Declarations, 35 Asis.Elements, 36 Asis.Expressions, 37 Asis.Iterator; 38 39-- Adalog 40with 41 Thick_Queries, 42 Utilities; 43 44-- Adactl 45with 46 Framework.Language, 47 Framework.Rules_Manager, 48 Framework.Symbol_Table; 49 50package body Rules.Unsafe_Elaboration is 51 use Asis.Iterator; 52 use Framework, Framework.Control_Manager; 53 54 -- Algorithm: 55 -- 56 -- This rule controls only library unit (generic) packages. 57 -- 58 -- The unit is traversed, excluding any inner subprogram. 59 -- For every call or instantiation encountered: 60 -- - if the called/instantiated element is outside the current unit, check that 61 -- appropriate pragmas are provided for its enclosing unit 62 -- - if the called subprogram is inside the current unit, traverse its body 63 -- - if the called entry is inside the current unit, there is nothing to do 64 -- (local tasks are traversed anyway) 65 -- - if the instantiated generic is a package (forget SP), traverse the instantiated 66 -- template. 67 -- 68 -- The declaration of the current unit is passed to the traversal to allow the comparison of units. 69 -- Note that the /specifications/ must be compared to avoid wrong messages, if elaboration calls a local 70 -- subprogram, that is also exported by the package. 71 -- 72 -- Single tasks are traversed normally, since they are started during elaboration. 73 -- Task type specifications need to be traversed too, since they can contain expressions evaluated 74 -- at elaboration time. Strictly speaking, it is necessary to traverse task type bodies only 75 -- if an object of the type is created; however, this would include composite objects with 76 -- a task subcomponent, possibly created by an allocator... Not worth the burden, therefore we 77 -- traverse task bodies too. No big deal, since it can create only false positives in some unlikely 78 -- cases. 79 -- 80 -- Entry calls are treated like SP calls, since for dependencies, what counts is the place where 81 -- the task type is declared, which is obviously the same unit as where the entry is declared. 82 -- 83 -- Since all the interesting properties are static, there is no point in traversing (or checking) 84 -- the same element twice. A symbol table (containing nothing) keeps track of elements that have 85 -- been already analyzed. 86 -- 87 -- Note that it is /not/ necessary to check for banned units in case of recursive traversal, 88 -- since we traverse only units inside the current unit. 89 90 Rule_Used : Boolean := False; 91 Save_Used : Boolean; 92 Usage : Basic_Rule_Context; 93 94 package Analyzed is new Framework.Symbol_Table.Data_Access (Null_State); 95 96 ---------- 97 -- Help -- 98 ---------- 99 100 procedure Help is 101 use Utilities; 102 begin 103 User_Message ("Rule: " & Rule_Id); 104 User_Message ("Controls elaboration code of (generic) packages that may cause elaboration issues"); 105 User_Message; 106 User_Message ("Parameter(s): none"); 107 end Help; 108 109 ----------------- 110 -- Add_Control -- 111 ----------------- 112 113 procedure Add_Control (Ctl_Label : in Wide_String; 114 Ctl_Kind : in Control_Kinds) 115 is 116 use Framework.Language; 117 begin 118 if Parameter_Exists then 119 Parameter_Error (Rule_Id, "No parameter allowed"); 120 end if; 121 122 if Rule_Used then 123 Parameter_Error (Rule_Id, "Rule can be specified only once"); 124 end if; 125 126 Usage := Basic.New_Context (Ctl_Kind, Ctl_Label); 127 Rule_Used := True; 128 end Add_Control; 129 130 ------------- 131 -- Command -- 132 ------------- 133 134 procedure Command (Action : Framework.Rules_Manager.Rule_Action) is 135 use Framework.Rules_Manager; 136 begin 137 case Action is 138 when Clear => 139 Rule_Used := False; 140 when Suspend => 141 Save_Used := Rule_Used; 142 Rule_Used := False; 143 when Resume => 144 Rule_Used := Save_Used; 145 end case; 146 end Command; 147 148 149 ---------------- 150 -- Check_Unit -- 151 ---------------- 152 153 procedure Check_Unit (Unit : in Asis.Compilation_Unit; 154 For_Unit : in Asis.Compilation_Unit; 155 Name : in Asis.Name) 156 is 157 -- Unit is an external unit used by elaboration calls or instantiations from For_Unit. 158 -- Name is the name of the called or instantiated program unit 159 -- Check appropriate pragmas. 160 use Asis, Asis.Compilation_Units, Asis.Declarations, Asis.Elements, Asis.Expressions; 161 use Framework.Reports, Thick_Queries; 162 163 Has_Pragma : constant Pragma_Set := Corresponding_Pragma_Set (Names (Unit_Declaration (Unit)) (1)); 164 165 function Applicable_Context_Clauses return Context_Clause_List is 166 -- For a spec: returns its context clauses 167 -- For a body: returns the context clauses of the spec + the ones of the body 168 begin 169 if Unit_Kind (For_Unit) in A_Library_Unit_Body then 170 return Context_Clause_Elements (Corresponding_Declaration (For_Unit), Include_Pragmas => True) 171 & Context_Clause_Elements (For_Unit, Include_Pragmas => True); 172 else 173 return Context_Clause_Elements (For_Unit, Include_Pragmas => True); 174 end if; 175 end Applicable_Context_Clauses; 176 177 begin -- Check_Unit 178 if Unit_Origin (Unit) /= An_Application_Unit then --## rule line off Use_Ultimate_Origin ## we work on Unit here 179 return; 180 end if; 181 182 if Has_Pragma (A_Preelaborate_Pragma) 183 or Has_Pragma (A_Pure_Pragma) 184 or Has_Pragma (A_Shared_Passive_Pragma) 185 or Has_Pragma (A_Remote_Types_Pragma) 186 or Has_Pragma (A_Remote_Call_Interface_Pragma) 187 then 188 -- no elaboration control needed 189 return; 190 end if; 191 192 declare 193 Context_Clauses : constant Context_Clause_List := Applicable_Context_Clauses; 194 begin 195 for C in Context_Clauses'Range loop 196 if ( Pragma_Kind (Context_Clauses (C)) = An_Elaborate_Pragma 197 or else Pragma_Kind (Context_Clauses (C)) = An_Elaborate_All_Pragma) 198 and then 199 Is_Equal (Enclosing_Compilation_Unit 200 (Corresponding_Name_Declaration 201 (Simple_Name 202 (Actual_Parameter 203 (Pragma_Argument_Associations (Context_Clauses (C)) (1))))), 204 Unit) 205 then 206 return; 207 end if; 208 end loop; 209 end; 210 211 if Is_Part_Of_Instance (Name) then 212 Report (Rule_Id, 213 Usage, 214 Get_Location (Unit_Declaration (For_Unit)), 215 Defining_Name_Image (Names (Unit_Declaration (Unit)) (1)) 216 & " used in elaboration code through instantiation at " 217 & Image (Get_Location (Ultimate_Enclosing_Instantiation (Name))) 218 & ", needs pragma Elaborate or Elaborate_All"); 219 else 220 Report (Rule_Id, 221 Usage, 222 Get_Location (Unit_Declaration (For_Unit)), 223 Defining_Name_Image (Names (Unit_Declaration (Unit)) (1)) 224 & " used in elaboration code at " & Image (Get_Location (Name)) 225 & ", needs pragma Elaborate or Elaborate_All"); 226 end if; 227 end Check_Unit; 228 229 230 -------------- 231 -- Traverse -- 232 -------------- 233 234 type Traverse_Info is 235 record 236 Force_Body : Boolean; 237 Unit : Asis.Compilation_Unit; 238 end record; 239 240 procedure Pre_Operation (Element : in Asis.Element; 241 Control : in out Asis.Traverse_Control; 242 State : in out Traverse_Info); 243 244 procedure Post_Operation (Element : in Asis.Element; 245 Control : in out Asis.Traverse_Control; 246 State : in out Traverse_Info) is null; 247 248 procedure Traverse is new Asis.Iterator.Traverse_Element (Traverse_Info, 249 Pre_Operation, 250 Post_Operation); 251 252 253 ------------------- 254 -- Pre_Operation -- 255 ------------------- 256 257 procedure Pre_Operation (Element : in Asis.Element; 258 Control : in out Asis.Traverse_Control; 259 State : in out Traverse_Info) 260 is 261 use Asis, Asis.Declarations, Asis.Elements, Asis.Expressions; 262 use Thick_Queries; 263 264 procedure Check_Name (Name : Asis.Name; Must_Traverse : out Boolean) is 265 -- Checks that there is an elaboration pragma for the unit that contains Name 266 -- Must_Traverse is true if further analysis of some body is necessary. 267 -- Since what is to be traversed depends on the caller, it is better to have 268 -- an "out" boolean than to traverse from inside this procedure 269 use Asis.Compilation_Units; 270 271 Name_Unit : Asis.Compilation_Unit; 272 begin 273 Must_Traverse := False; 274 if Is_Nil (Name) -- Pointer to subprogram... 275 or else Expression_Kind (Name) = An_Attribute_Reference -- Attribute function 276 or else Is_Nil (Corresponding_Name_Definition (Name)) -- Some predefined stuff 277 or else Analyzed.Is_Present (Name) -- Already seen 278 then 279 return; 280 end if; 281 Analyzed.Store (Name, (null record)); 282 283 Name_Unit := Enclosing_Compilation_Unit (Corresponding_Name_Declaration (Name)); 284 285 if Is_Equal (Corresponding_Declaration (Name_Unit), Corresponding_Declaration (State.Unit)) then 286 -- Internal call/instantiation 287 if not Is_Part_Of_Instance (Corresponding_Name_Declaration (Name)) then 288 -- Except those that are inside an expanded generic unit 289 -- (dependences are checked on the instantiation) (Ticket #38) 290 Must_Traverse := True; 291 end if; 292 else 293 Check_Unit (Name_Unit, State.Unit, Name); 294 end if; 295 end Check_Name; 296 297 procedure Check_Subprogram (Call : Asis.Element) is 298 -- This procedure because procedure calls and function calls are treated the same 299 -- (/not/ entry calls!) 300 use Framework.Reports, Utilities; 301 302 Must_Traverse : Boolean; 303 Ignored : Asis.Traverse_Control := Continue; 304 Call_Descr : Call_Descriptor; 305 Called_Body : Asis.Declaration; 306 begin 307 Check_Name (Called_Simple_Name (Call), Must_Traverse); 308 if not Must_Traverse then 309 return; 310 end if; 311 312 Call_Descr := Corresponding_Call_Description (Call); 313 case Call_Descr.Kind is 314 when A_Regular_Call => 315 -- Let's go to a real body (or expression) 316 Called_Body := Call_Descr.Declaration; 317 loop 318 case Declaration_Kind (Called_Body) is 319 when A_Procedure_Declaration 320 | A_Function_Declaration 321 | A_Generic_Procedure_Declaration 322 | A_Generic_Function_Declaration 323 | A_Procedure_Instantiation 324 | A_Function_Instantiation 325 => 326 Called_Body := Corresponding_Body (Called_Body); 327 when An_Expression_Function_Declaration => -- Ada 2012 328 -- Like Analyze_Body, on the result expression 329 Traverse (Result_Expression (Called_Body), Ignored, State); 330 exit; 331 when A_Null_Procedure_Declaration => 332 exit; 333 when A_Procedure_Body_Declaration 334 | A_Function_Body_Declaration 335 => 336 -- A real body (at last!) 337 State.Force_Body := True; 338 Traverse (Called_Body, Ignored, State); 339 exit; 340 when A_Procedure_Body_Stub 341 | A_Function_Body_Stub 342 => 343 Called_Body := Corresponding_Subunit (Called_Body); 344 when A_Procedure_Renaming_Declaration 345 | A_Function_Renaming_Declaration 346 => 347 Called_Body := Simple_Name (Renamed_Entity (Called_Body)); 348 if Expression_Kind (Called_Body) = An_Identifier then 349 Called_Body := Corresponding_Name_Declaration (Called_Body); 350 else 351 -- some weird construct, necessarily involving pointers to subprograms, renaming of entries.. 352 Called_Body := Nil_Element; 353 end if; 354 when A_Formal_Function_Declaration 355 | A_Formal_Procedure_Declaration 356 => 357 Called_Body := Nil_Element; 358 when Not_A_Declaration => 359 -- this should happen only when the body is given by a pragma import 360 Assert (Element_Kind (Called_Body) = A_Pragma, 361 "Unsafe_Elaboration: not a declaration or pragma"); 362 Called_Body := Nil_Element; 363 when others => 364 Failure ("Unsafe_Elaboration: not a callable entity declaration", Called_Body); 365 end case; 366 exit when Is_Nil (Called_Body); 367 end loop; 368 369 when A_Predefined_Entity_Call 370 | An_Attribute_Call 371 | An_Enumeration_Literal 372 => 373 null; 374 when A_Dereference_Call | A_Dispatching_Call => 375 Uncheckable (Rule_Id, 376 False_Negative, 377 Get_Location (Call), 378 "Dispatching or dynamic call in elaboration code, can't check elaboration"); 379 end case; 380 end Check_Subprogram; 381 382 Must_Traverse : Boolean; 383 Ignored : Asis.Traverse_Control := Continue; 384 begin -- Pre_Operation 385 case Element_Kind (Element) is 386 when A_Declaration => 387 case Declaration_Kind (Element) is 388 -- Ignore: 389 -- All program units except tasks, since tasks can be started during elaboration 390 -- (generic) formal parameters 391 when A_Procedure_Declaration 392 | A_Generic_Procedure_Declaration 393 394 | A_Function_Declaration 395 | An_Expression_Function_Declaration 396 | A_Generic_Function_Declaration 397 398 | A_Parameter_Specification 399 | A_Formal_Declaration 400 => 401 Control := Abandon_Children; 402 when A_Protected_Body_Declaration => 403 -- Nothing happens here at elaboration time (but specifications need to be 404 -- traversed, since there can be expressions in entry families or components) 405 Control := Abandon_Children; 406 when A_Procedure_Body_Declaration 407 | A_Function_Body_Declaration 408 => 409 if State.Force_Body then 410 State.Force_Body := False; 411 else 412 Control := Abandon_Children; 413 end if; 414 when A_Package_Instantiation => 415 Check_Name (Simple_Name (Generic_Unit_Name (Element)), Must_Traverse); 416 if Must_Traverse then 417 Traverse (Corresponding_Declaration (Element), Ignored, State); 418 if not Is_Nil (Corresponding_Body (Element)) then 419 Traverse (Corresponding_Body (Element), Ignored, State); 420 end if; 421 end if; 422 when A_Procedure_Instantiation 423 | A_Function_Instantiation 424 => 425 Check_Name (Simple_Name (Generic_Unit_Name (Element)), Must_Traverse); 426 -- Nothing to traverse for instantiations of generic SP. 427 when others => 428 null; 429 end case; 430 431 when An_Expression => 432 case Expression_Kind (Element) is 433 when A_Function_Call => 434 Check_Subprogram (Element); 435 when others => 436 null; 437 end case; 438 439 when A_Statement => 440 case Statement_Kind (Element) is 441 when A_Procedure_Call_Statement => 442 Check_Subprogram (Element); 443 when An_Entry_Call_Statement => 444 -- Check the task [type] name, 445 Check_Name (Called_Simple_Name (Element), Must_Traverse); 446 -- But there is nothing to traverse for entries 447 when others => 448 null; 449 end case; 450 451 when others => 452 null; 453 end case; 454 end Pre_Operation; 455 456 457 ------------------ 458 -- Process_Unit -- 459 ------------------ 460 461 procedure Process_Unit (Unit : in Asis.Compilation_Unit) is 462 use Asis, Asis.Compilation_Units, Asis.Elements; 463 464 Control : Traverse_Control := Continue; 465 State : Traverse_Info := (False, Unit); 466 begin 467 if not Rule_Used then 468 return; 469 end if; 470 Rules_Manager.Enter (Rule_Id); 471 472 case Unit_Kind (Unit) is 473 when A_Package 474 | A_Generic_Package 475 | A_Package_Body 476 => 477 Traverse (Unit_Declaration (Unit), Control, State); 478 when others => 479 null; 480 end case; 481 end Process_Unit; 482 483begin -- Rules.Unsafe_Elaboration 484 Framework.Rules_Manager.Register (Rule_Id, 485 Rules_Manager.Semantic, 486 Help_CB => Help'Access, 487 Add_Control_CB => Add_Control'Access, 488 Command_CB => Command'Access); 489end Rules.Unsafe_Elaboration; 490